From b8a522c1dea44f61fec6edd9fe37dcff35d241d2 Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Fri, 28 Aug 2026 23:39:13 +0200 Subject: [PATCH] Initial import --- README.md | 46 ++- examples/simple.png | Bin 0 -> 10183 bytes examples/simple.rkt | 41 +++ info.bak | 27 ++ info.rkt | 21 ++ main.rkt | 39 +++ private/windows.rkt | 632 ++++++++++++++++++++++++++++++++++++++++ scrbl/racket-tray.scrbl | 44 +++ tests/basic.rkt | 10 + 9 files changed, 859 insertions(+), 1 deletion(-) create mode 100644 examples/simple.png create mode 100644 examples/simple.rkt create mode 100644 info.bak create mode 100644 info.rkt create mode 100644 main.rkt create mode 100644 private/windows.rkt create mode 100644 scrbl/racket-tray.scrbl create mode 100644 tests/basic.rkt diff --git a/README.md b/README.md index 1d804fd..a66d009 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,47 @@ # racket-tray -A tray icon for racket. \ No newline at end of file +A small system tray API for Racket. + +Version 0.1 implements Windows directly through the Win32 API. It uses the +native `HWND` of an existing Racket `frame%`/`dialog%`, `Shell_NotifyIconW`, and +`SetWindowSubclass`. No additional native DLL is required. + +```racket +#lang racket/gui + +(require racket-tray) + +(define frame + (new frame% + [label "Tray example"] + [width 400] + [height 250])) + +(define tray + (mk-tray frame + "example.png" + (λ () + (send frame show #t)))) + +(tray-set-menu! + tray + (list + (list "Open" + (λ () (send frame show #t))) + 'separator + (list "Exit" + (λ () + (tray-close tray) + (send frame show #f))))) + +(send frame show #t) +``` + +`mk-tray` and `tray-set-icon!` accept both Windows `.ico` files and `.png` +files. PNG transparency is preserved when the image is converted to the native +Windows tray icon. + +`tray-set-menu!` also accepts a `popup-menu%` object directly, or `#f` to +remove the context menu. + +At the moment non-Windows platforms report that the operation is unsupported. diff --git a/examples/simple.png b/examples/simple.png new file mode 100644 index 0000000000000000000000000000000000000000..57e3d377934d6354b16b0a4cb62b6853bbf2dbe5 GIT binary patch literal 10183 zcmV;&Cpg%NP)?G0jvrxvBTwdXLt+v&&P{rJ@BXXe45)d5DKz*T?+~ZcP&a85LT4UP?`07cxB!&ihT2sZt^n> z1-r&RrXdsrxtceuyFM>1Kv8x|56Y>md&v%&&(7|l&&%t6HE$zJUUyAF!DEC1!Y-zj zpE=X*3`=ERWq2M-Q8vN|+1UsyC_q<2ULLv(8-^}fS?JvM9{*6m^e;{H1;`6ERLy_0 zQMGV$i*DJ07X8YjErwMmU|fB&*|6##&4v}HU|Mww`jw|!^eet@*01=cMZfHuX8rOr zEd<@tZ(9sYzirli^j(W?@pmn{Mc*~+GtV|_7MyF=%sq!%|)ZWZX(z;zgK9%67D1RMt#?E3-RKES>QuSj z!v;XV7SOK*bjty47NA)Ks22dLd4Mt;C0aUyP zl>Z$NzYU1r1WMlkN{0d^e+7z%07ZWRivA4Td=abr@gc+YNxu5)6Mgm9Cs69H5yt!Ku8w6W9OJ7i9PO(s9ObLK@`11J z@(5qu<>9{COYiw=FAek6UVPVAd*ScC+6(XaYQKNWSNr`NzS{5q+gJ0?p}v~)fA!Uz zf8AGe?k~QYbAR^LoPE{j{qAL-_spMs-ZOvndB6EDpZA*=eV)^Q@Oe)E-sk?uZ+-56 zyx?*nj$5M}O&a67qiOa~}S`KIh^8<8vG&{D;qR@Ohto z|8qVYVehj(``%|Lwmr}Ith=A_*>*qKWZN_Fj_>qXSoXfRkhmc!^=B9F-)QZ(LzkfN zMR>pcMN`c;zkv7j^9-l_Jja=T9^QXE$M6-W{pwkGPd*C|mlMx09DkbO7|YS8Se}F@ z?@4%$JP9}9@DmJ&o`Cycf4B~??0X!}y^q7W?{PTx^n+s;%a{FN-_;lPoqb`??F(CO zAJ}&Efi0&Gtl2DI^oDhNZ&(PQC&RLh&>QBh$w9Ux!?c+}yRMJVv2_6Kpa1Su)?i*& zI(YcGQx39tT}f--KVTcqJ`eB7{*9jFPr-A771fHTSaDAUVFkJ=Pr{wYfy#U$$l?C2 zIrMn2J@hzS2Oo#)KtH$+^o47GKe+bwg>!FTIQR5{b9Wy&cJ+bd%RaF0>jleaJz?3}6Xq=}n|s3aX%fSxB$z&7Fm5Cy!uW9_ zR4aQnn^yIQVb$Y>Mf0PXT#rX2-nR2Ua&Y=dxR3Q~Vj`0xw++$$Xl*4rj}@KAmF*`) z`r*fe9O=(M*Ry|5qrD%T`})DTw@*<1m%SPBJ6Q2KZHu>j&Psm>@x~DG>J>@N#$~-> zSla96)wJZ8M=L(}ncN?~dIGMzK24sZth@)o6&n!TpN-)Da2@iuY&5ei6Xis9KiW~= zqff${*B{;^z2QBQ1nBZuM0;*BM|!Vdq?0J$ z#t1hP;eP3xlVJWd31%XjB~&=UuptrZ0Hz(a2=|s3+ z`UXb2VLcI_*sRY=X2hpIV)5qfPw#9#-XG3Gy_?z=%tSC362&f(5)R%g+I4`1NI%#Q z?n4ZoyeHs2+8ecbBGjLK5x2`%;l@*%t%uiJ!%$NTZ|xm;8=6sj2dJy9L!Im-YL5K@?rc6BWE4Zv42|}lLFrqQ zVA+yHg$L40KzbsDE1VnYhINDlsFx)+>pvpm6CYu!Va1!bK9Speq#qpndo}$Ox%A+- zuP-wK+1EEPAApEI*q26n%^?vQ&JV?HS2gN=KyCeP)Og(RxLt4)TyD7CZn#_o7hEnU zTuukvE(hG68h9Ik8n**A=cmHGoez6XGVDbBHdZ{5P9l9XE4~fsrZ%M~P~m=5%MzOn zMEv5!M<4M-yzfw7IQI5xBC?z;exa_tjNp49c{ecZ>&vj0{5^SYAGr4Sf#>iO@E(jo z!^M%f-B63V+byW^xZv@4;P!Z^Xs6Q!2f^-y-R^|L;m1WEbCQm5*x>fm!BhVOyqB`z z`iu|z_TI1&@g&-}B*DVwb4Ge%E8$dnEAa`8bQacz?tjH}}tNJkSUB zJw2P~&}}b=Jr7`a8|-0l?d=2ifyYs^kL2^e;dZ?nH4S&+r4jC>!ij9V-2toB4vWPG zGYgrwSZ#E@-R7X3VRw*@vBT+b!Br2q&(4PP(+JqM^@e3jB9mh7Bb^bRzzCx-AToo%@!DqCg^o~=rvjfoq?`1nXI%EY&JV=qyxxaV7J5J zaKq{Fz`6fb*f;TE*_sT?r-@X!c~c@xn?fR;MtMR|I#)a^oFP6SUcV&1=*IM@*hedV zW4|4Zdwaw7Wnz?Gj)R1fSkZKH&Y7J26jnI&e(CT0^Szxg+9bjcUz-G0==D7oV<$2gQ#=*Kd z5tdC!Ft^I(2|+e+q;rK+>G9C74x;>sh);rUQ9Fn?5b=9@!8lu2 z?J9mlza5Rcl40AC(B#PN1qzXv8^r!2I5<%8Uqqm`a2aZD18$cSPNy3-2T3nB8pS$| z7ILitrC*=KrFRG5!l2H$Fo1{e|FaX$|B{FEe@w!y>`$OE*p4IUE;%-5KKCO)%I!Fd2-Dct2(f%yt({Dmjd+pMz<2G)x~S!4x9gNQK9@Eu582 zr0Z4^;-FkY#3w?R*$(1$tNZS_o0|-4c6^gPrze8+f<2p^&u)z^WZCW~CmGJqMeywT zHM|ZJT%I~sJbN%TS)kXOAd|>ZI_Y;PdA$=#$HzfDPKc_MXjD&&hGbeas;9?6JiG^r zUXOwLMj4r9>>jTo`p70x}7(nyb^QBGOGpjaH=tY5^4&wu3NSM=U-JDU`l z;+kyRlkgy{r2V`Nwy|tahU1e+xK5?OS?hz{ZV!&tiFlI{24@{)+vcF+Z62zpiJ;7g zhGvNfx}_rMmx-WT76%<^mnJ|nD;&C2ufp!Cg_RxMkccNkO(PlkIO?D}{wY+`xS#We+GCblWpdOto(g6*?J z*tR9ZzM%)4r&HmmX@cEmWuu*pM(nVV@wvMJ%B?d{J-icC^W&ji5=%uBA%;~!jH?o1 z%vWpv07mw(QdNBpwmNVuZ8lf?NChY3hlB)x(zCyNcPL-N^eX2az;88 zzbL-hkeSd<;+OZ%x&1k*cf>VWwlV`Xf^A)Q*iWRu z;km<%xdY-Iu$s)UdGA1ba5a?UIzzuS5r$>4jOaCSFs_Y*d0jlr>*8SEkOWKCW3caj z53agKx-GID6Fup&K(Et5Ypa3$$Yw~#bb)4Z0<>%g21IkBT;E1&p^?6fkxuqB#iF=o zJryr%2l302a~epYX|t%wx-|g|i9ZfKRcD27PM}ye_k?v#57_p+39GY?8E*&1-*%cV zY@T{pO0PhdDuijd2&UEXFcaY$2=TCd91qKeI9NaF1>3SPxUXcxRo?;|Ni{TGSzs`j zq1S4mwzwh9$wc+YE>JFvhc+t~y5%D1SFo}GCg{=66qFec++e7?k z0k$oDU|ZV_?%Y4nvtFmm13O7IG`}+=BdtaYrNNG> z6~j>VK^G`U+WLqbBScibZUxf;t%Z}vm}3apI~egIDxIKU#cSI`yeca>r=Ap;K8bCj z0w0!5LCl{J;$hyH0Q34dn3u-DaO)h5j#`+EMmh@dp8!$uE-zd*8yq`dhkZE@_KyXy ze-aD(rdT*OMZ>wiE8N?kMUAcm?z%?UZREKm%~)YD5a~LowFby4Dp4`{IaH464*6UW zG>c=Q&Em+Xk?o&n)>F|O*_131G+AuKFN}vSQ*`s{M1IVp6~BZPzmbTKM=PjU(voFn z-b_SuTO#}uB0V1Fj|oXIXLg0|KnC=-S{U^P8l`0H%@n;HGcK@?%ltG zdwYMlzvv71u3w?%%yiV6r0~@HXkm;zhm2;7Ml*DJBh)GtP7y&dCx)H_Xg*@1-Y-88;auUYXuovL zMHw*B_u*W zvoqw|)1WfBq0?w!Fq&z^`qPe;9pjUTc9GOma~rPOyKuQ{;dC&2g}=<;m#)CP^7a(3B;r3#glT2g`sTZQ>ZxiEo3?i&ChD3ijGWldZrV|onZDOW%yk)leWMR`#v#2G^&{%;VTeyai1FBUzR4cWVDvBPJ3O&jzr4XMv4sq58 zD1R#w6~nrsYEmq!CJ9hIMF=@bF&U(?84dNq7^oNd#k2B5M2Er%j|m{p5Vfy(FUiZR zq8p8CV!k-SSx~gT`bJ&$*F%LJ@q${((JN$Xcveen<9kxjm{|jOBhPW z{tBhbQc#w=0cFScqwMRGDEsCl%Dy^`vb~?7?BjHl%^ZyKcLb<>lZWc@k&sM|fn;hd zWHVx+B;)o4BDzOu7Lq-SmCj{x>v^tZN@i>1b7PzJ^F-|R7ae zfwm&H;cSlXl>W5`!_aOJ5AA~TzwuBxtTQANqad3W3;B##C{kmgn$Zo~)GpA^>kh-* zFzDw!2Hlc4XhWrQ@b3u$*`dOr)LzmhWmW{uI^Xxjfi%-IN;d5BG z`~k)V-2(Ch9YFSgkchrVHV1NW4n%x=h?mSs$nlU`_;O*RVP!1-Cm4zNwehg7j(}_D zZ%|{A!+RI-)VILX0C?-}!Yero_klNIUl|3uOj8$XxLUq!!0R*vmUTn%&=K46mregRo4t} z?OoJVo`IXx>$m<2))gX{Gs9t=*9FG842C(R?FwTiAC^^5!=C#t+*iJYm)uKv8?ZY) zu$s;EQlQzOhuKjBi(Uugs^_7b*8|$caZoR054I12Bb+in8nQXD?I=DyF~?2n*GmPB z`sFeBDH!~$iidG=IBZ|M1}C{pM^A>>iX;oEr<2-?n{+_K5AZrH@XD{ibL${H7q`NF zem&gz>)`o*6Fk>;!Bcq-UW*#u`X;#V`~Zj33#)}(@U{d_ut*ugpx46SXn^719O!0u zhBh+}>IFnR%K~<&Nnw^%T;>On&1uhwPfy5klPfnL2^z_`n?l4cdw2}X<6+3?4DP-v1I|jpuia_snM9tOnJan17~d`+zp_SOdtg_|2)}49G-fngkWZBJVyUT5QB-H zbdgG>R-=K&;)VLuHfUyqL9>vIcB0#)E!nNar^htwGeqqpzG`+tj*FB_x#Azh(h#x; z@zAGrhHl$?(3-vUh9z_l+j*^*m3}f9r0GO_ zOnZutg?4cp;_t^tL9|Pvq0NkDhHo>vp*-ao+&Gzsa=8{#nGy=A9BP$@*3oGv=nR~W zU^<}{`d}K->5Ku{uFAcT5e46Vyt`*Sp|teA~kmoGysQ=?j@giOlT zWdfaGU^+p^2&SU%k*$YXt%FLbhC;4@loZRVWe`hLC@L<)jogj6G5l$i4DE!{kphUv z@*$lrfFfN8)m$Q<+X19>+_rEAA*5;1&APem74fMFISx|K$mBO^mk5JWNlPUA1&6XY zh$d4A%|anG^MsJkj7I6ZJy7@u9xlE06t1kvz>RZfQCcZOr9w;Z5LT&~=p}ht%atD@ zU8T}OsZ>LzP@_VoMyW)BTUQEkEqgt#P53=-y%vU&H^WdmN{F)2e2B;MA(>7JXF@3F z3aLy+J~JPL5gma1?OY)n@iFZb@kIRMp!jhkgffj(4TUKAK!_Vd zy5j1KJQNN|MB$9La6R`^6kooKswxRoM7*YL@uWj&4PL21b+r^FH*Vr)-drM7(^q5Q;fL`9F$Z{A@ zH)$6OK_RmJ^W1g*^^5LB!$v*%Ao5fJs#3_VFF@%B0u;X)j-uB(N;Q1XC$h)#As)wvcmf|) zQv{ICWW}d5x!y0eEzzM!XEUirKd&9cSItbwv6J%X0#-Z``C}~+eINPi1wyFi2%wn7 zhjc0*RTHC7H8B>IAM}9uT@kdW55ea2&`W@Hh{!pRwt^gdbw(I14j78ALOT7Is2#NU>;sRFfuCz=-^*EDG5JGKJ7C5YjTRZgx2I^ZUVGc@55bAIt_LbMGU$G0A@* zRqJWaCkIoK+iC9Ca^>q`an`_QG(x-b6)4B^AfF|Ij6^t*P0|YyK8ukqPh-VX`2w19 zT1#d+r4{KyNM=R1r}(%XwuP}!&GU=*!x6ji$K`7?gXu`OSO7y-9E|h3!L;ltIAz6f z)Uwh|)=$`Buq>*P)rrgL;k#idh0Eh-?mu5b;6L z_nY^NXChvgAuM|I;-@9-u#xH<5x-CX1|nO~2LAPJh+o8!zElL$;%>05dloLG81|aG z^j1Ej(Hg9=kkN};2c=3&zadgiPKc^ybY7`shMe>O%aKna-(+*cX0gMxWhivhc~EDF zpiF0Fr?JuArg#qNZR3ylb``J8h-y+V5P-6f#UcK9K?5@tVX$9Lq{?Sg_@o`1)`ta4^O`dXkg@99WZSk z0$pmSpnOgT1W124UsHy)LE|5xfOr^W5C&W~;_{$U}~7qH?pNwmknu!IlG zvP8HfS757Yg2|w#H5b2hHG4LyRB0fsmY_na#P##}_~w--apI|Pe7|EW#4;jZLgmxE zuV&19H;-)3xK#_}76_pwqy%H*2ftwdE z;>w6$;QA{(+#Dvv&A&(B#@i9N{th2kUJ1v!-}7;4cMdJG5&1H?igucU?Eu;dy zn?8VCLvGbmFi}cmky5T)MFmz=D{%ADC0rf#pSbY~4@K_@Q1o5|ir$Yz(eOx=43EIA z_xUJ%Ee!cD#^BPvT!^J=NGhrzlPYNEDOluE8KfEuq(?SEK86QHS~TRdIN~XSU?&8Y zL*f4$#7|+xr$;ssiLLN=0(Y77xRNlJ4`n(ZiZmhQlfxlNeH!H@<&a2~kX1<_CAZ>{ z3l`!^CcRv^fUBc_jhnBMZ*=of{C)(AM?|7zWF$(*L_$0^5~ZUeP&9&%!dJT@|3x7# z?#V`}OpU7YO1j5Ls-=|b@=8=FjVNFKKB|WEAe$A#i1#!5#}Giq%9qXNle>s# zqyI-iRQ%j%DAL*xe?N$9F6n$`7f%&HIpvs4S8B*Qy_u~-1)Ya z=dvkg4vBWZ_$WxHM55%4FkDD|8wLAvaq*kexOnm?F0RW!;eRLL){xF99w9)J|TzQ(2Fhf%mD6}R4wM#;O~ zXj!;wawMcPqaY*FS*YmHJ;2{FoR&~c#HR_#aI(F`lN&%Io9+?&02Fgr(mCR1ML{+r z3Kiocas5>uF1*wo-@hJ*i+>j2+RHrLdMg~oAMjD~0VBO^3>)PiMxttR6so5LA@VCH zMWK9rBuYm{;rg3BaPdVRzJI9)3SN)Hl_62M`4=8ahIL2Ds3^KE@*L@mD9BPd;yGg5 zTIM2|!Ee^33)&~*#YBAiPZaNubiep?M!tMD`Os02OpQX>I01@C{(iR`O5T4AB_sJ% z5Xs*p%FD(wX{GYRNK_N)Q<>*Urm;+A)>VBNiHZp%_eY^*qyR<3B2e<~V<;Wb1Er${ zC>=vChA@wl&Xa_Q|0z^Y=Qr!p1dsOM>OX-hONq-dkpttbh(_g{C{`+Iqo4>Z2iN(9 z)4a}+uAoFQ@@Fu@%Em;Ylt4s}VbTgcfQ}=ng^AFB^yyKM5~eXxOXdR|Fgc2L5a|HY zVPue4ksgVvDIwBlgut#R+oI`bauj_oIVSkG zOIq=SNK~e9w&fQeD*8Uc{ZvioH)~U)pqV2qEK2GBX#S~l_5dFJH|B-!$1JHH%}2$= z?oIO4NXTdXL{eKLOC<-mNJyp;xe=(C7=iNfK`JIi(DhZ5BTzLZ0usVB0`nZnbf%TE zZGb5xC2_VnAp&Bu%?ZplD@jLAjzsm;;C9G1q%%19m)XZ8A(T&w@TsRpKr>yy{2O!f zvlYBY^e=An--v&;=xxF6%R|F|xH&AWv1E97Q}KvyzLF3AMMf}?Z50jg<|`f^Y)c5- z*I?%#_`2-2DD1Y1-e+OAOBwMKq1y`g-5eI)bmN`yyXvvzoI;pM+!V3F`Lj>p@#s%g zeD`Yf=6}8vf$v`o$E81o$aBF-Kg z)Z-lC_@Ey7TuzYog&yaR5A1QCw(R_g7Z~XJfgz7`pF5~W{?S1_@`KwauN85YyzUA1 zy&NNu_ckcvjQ{Q5)`d50SeL2WB1z*eI4?8efvJfeGlY4`QKj(=Y12%XQ7{qM^i2N z+@XTo_XoMi!Gs)e$?rY|ewgYZe#naVzjVS+_z^DpTUUd5T?zlrUqQR?FOK2=V|f4K zuc>uR9aG2DF?CEGQ^(XXbxa*o$J8-(OuV0G`hWQARk;>aB>n&Z002ovPDHLkV1nwS Bp8o&< literal 0 HcmV?d00001 diff --git a/examples/simple.rkt b/examples/simple.rkt new file mode 100644 index 0000000..1bd928b --- /dev/null +++ b/examples/simple.rkt @@ -0,0 +1,41 @@ +#lang racket/gui + +;(require racket-tray) +(require "../main.rkt") + +(define simple% + (class frame% + (super-new [label "Racket Tray"] + [width 400] + [height 250]) + + (define lbl (new message% [label "Counting tray clicks"] [parent this] + [auto-resize #t] [stretchable-width #t])) + + (define count 0) + + (define/public (count-next) + (set! count (+ count 1)) + (send lbl set-label (format "Counting tray clicks: ~a" count))) + )) + +(define frame (new simple%)) + +(define tray + (mk-tray frame + "simple.png" + (λ () + (send frame count-next) + (send frame show #t)))) + +(tray-set-menu! + tray + (list + (list "Open" (λ () (send frame show #t))) + 'separator + (list "Exit" + (λ () + (tray-close tray) + (send frame show #f))))) + +(send frame show #t) diff --git a/info.bak b/info.bak new file mode 100644 index 0000000..f67f599 --- /dev/null +++ b/info.bak @@ -0,0 +1,27 @@ +#lang info + +(define pkg-authors '(hnmdijkema)) +(define version "0.1.8") +(define license 'MIT) ; +(define collection "rackedit") +(define pkg-desc "rackedit exports the rkdt procedure, that can be used to open an editor window with a given file") + +(define scribblings + '( + ("scrbl/rkdt.scrbl" (multi-page) (library 0)) + )) + +(define deps + '("racket/gui" + "racket/base" + "simple-ini" + "rackunit-lib" + ) + ) + +(define build-deps + '("racket-doc" + "draw-doc" + "rackunit-lib" + "scribble-lib" + )) \ No newline at end of file diff --git a/info.rkt b/info.rkt new file mode 100644 index 0000000..3ddb8cc --- /dev/null +++ b/info.rkt @@ -0,0 +1,21 @@ +#lang info + +(define pkg-authors '(hnmdijkema)) +(define version "0.1.1") +(define license 'MIT) +(define collection "racket-tray") +(define pkg-desc "A tray icon for Racket") + +(define scribblings + '(("scrbl/racket-tray.scrbl" () (library 0)))) + +(define deps + '("base" + "draw-lib" + "gui-lib")) + +(define build-deps + '("racket-doc" + "gui-doc" + "rackunit-lib" + "scribble-lib")) \ No newline at end of file diff --git a/main.rkt b/main.rkt new file mode 100644 index 0000000..3e5a4f6 --- /dev/null +++ b/main.rkt @@ -0,0 +1,39 @@ +#lang racket/base + +(require racket/runtime-path) + +(provide mk-tray + tray-close + tray-set-icon! + tray-set-menu!) + +(define (unsupported who . _args) + (error who "not supported on this operating system: ~a" (system-type 'os*))) + +(define mk-tray + (λ args + (apply unsupported 'mk-tray args))) + +(define tray-close + (λ args + (apply unsupported 'tray-close args))) + +(define tray-set-icon! + (λ args + (apply unsupported 'tray-set-icon! args))) + +(define tray-set-menu! + (λ args + (apply unsupported 'tray-set-menu! args))) + +(define-runtime-module-path windows-module "private/windows.rkt") + +(when (eq? (system-type 'os*) 'windows) + (set! mk-tray + (dynamic-require windows-module 'mk-tray)) + (set! tray-close + (dynamic-require windows-module 'tray-close)) + (set! tray-set-icon! + (dynamic-require windows-module 'tray-set-icon!)) + (set! tray-set-menu! + (dynamic-require windows-module 'tray-set-menu!))) diff --git a/private/windows.rkt b/private/windows.rkt new file mode 100644 index 0000000..6187103 --- /dev/null +++ b/private/windows.rkt @@ -0,0 +1,632 @@ +#lang racket/base + +(require ffi/unsafe + ffi/unsafe/define + ffi/unsafe/os-async-channel + ffi/winapi + racket/class + racket/draw + racket/gui/base + racket/match) + +(provide mk-tray + tray-close + tray-set-icon! + tray-set-menu!) + +;; Shell_NotifyIcon constants +(define NIM_ADD #x00000000) +(define NIM_MODIFY #x00000001) +(define NIM_DELETE #x00000002) +(define NIM_SETVERSION #x00000004) + +(define NIF_MESSAGE #x00000001) +(define NIF_ICON #x00000002) +(define NIF_TIP #x00000004) +(define NIF_SHOWTIP #x00000080) + +(define NOTIFYICON_VERSION_4 4) + +;; Window messages used by NOTIFYICON_VERSION_4. +(define WM_CONTEXTMENU #x007B) +(define WM_NCDESTROY #x0082) +(define WM_USER #x0400) +(define WM_APP #x8000) +(define NIN_SELECT (+ WM_USER 0)) +(define NIN_KEYSELECT (+ WM_USER 1)) + +(define IMAGE_ICON 1) +(define LR_LOADFROMFILE #x00000010) +(define SM_CXSMICON 49) +(define SM_CYSMICON 50) + +(define BI_RGB 0) +(define DIB_RGB_COLORS 0) + +;; Windows scalar aliases. Pointer-sized values matter on 64-bit Windows. +(define _HWND _pointer) +(define _HICON _pointer) +(define _UINT_PTR _uintptr) +(define _DWORD_PTR _uintptr) +(define _WPARAM _uintptr) +(define _LPARAM _intptr) +(define _LRESULT _intptr) +(define _HBITMAP _pointer) + +(define-cstruct _BITMAPINFOHEADER + ([biSize _uint32] + [biWidth _int32] + [biHeight _int32] + [biPlanes _uint16] + [biBitCount _uint16] + [biCompression _uint32] + [biSizeImage _uint32] + [biXPelsPerMeter _int32] + [biYPelsPerMeter _int32] + [biClrUsed _uint32] + [biClrImportant _uint32])) + +(define-cstruct _ICONINFO + ([fIcon _int32] + [xHotspot _uint32] + [yHotspot _uint32] + [hbmMask _HBITMAP] + [hbmColor _HBITMAP])) + +;; NOTIFYICONDATAW as defined by shellapi.h. The uTimeout/uVersion union is +;; represented by one UINT because this package only uses uVersion. +(define-cstruct _NOTIFYICONDATAW + ([cbSize _uint32] + [hWnd _HWND] + [uID _uint32] + [uFlags _uint32] + [uCallbackMessage _uint32] + [hIcon _HICON] + [szTip (_array _uint16 128)] + [dwState _uint32] + [dwStateMask _uint32] + [szInfo (_array _uint16 256)] + [uVersion _uint32] + [szInfoTitle (_array _uint16 64)] + [dwInfoFlags _uint32] + [guidItem (_array _uint8 16)] + [hBalloonIcon _HICON])) + +(define shell32 (ffi-lib "shell32.dll")) +(define user32 (ffi-lib "user32.dll")) +(define gdi32 (ffi-lib "gdi32.dll")) +(define comctl32 (ffi-lib "comctl32.dll")) + +(define-ffi-definer define-shell32 shell32) +(define-ffi-definer define-user32 user32) +(define-ffi-definer define-gdi32 gdi32) +(define-ffi-definer define-comctl32 comctl32) + +(define-shell32 Shell_NotifyIconW + (_fun #:abi winapi + _uint32 _NOTIFYICONDATAW-pointer + -> _int32)) + +(define-user32 LoadImageW + (_fun #:abi winapi + _pointer _string/utf-16 _uint32 _int32 _int32 _uint32 + -> _pointer)) + +(define-user32 DestroyIcon + (_fun #:abi winapi _HICON -> _int32)) + +(define-user32 CreateIconIndirect + (_fun #:abi winapi _ICONINFO-pointer -> _HICON)) + +(define-user32 GetSystemMetrics + (_fun #:abi winapi _int32 -> _int32)) + +(define-gdi32 CreateDIBSection + (_fun #:abi winapi + _pointer _BITMAPINFOHEADER-pointer _uint32 _pointer _pointer _uint32 + -> _HBITMAP)) + +(define-gdi32 CreateBitmap + (_fun #:abi winapi + _int32 _int32 _uint32 _uint32 _pointer + -> _HBITMAP)) + +(define-gdi32 DeleteObject + (_fun #:abi winapi _pointer -> _int32)) + +(define _SUBCLASSPROC + (_fun #:abi winapi + _HWND _uint32 _WPARAM _LPARAM _UINT_PTR _DWORD_PTR + -> _LRESULT)) + +(define-comctl32 SetWindowSubclass + (_fun #:abi winapi + _HWND _pointer _UINT_PTR _DWORD_PTR + -> _int32)) + +(define-comctl32 RemoveWindowSubclass + (_fun #:abi winapi + _HWND _pointer _UINT_PTR + -> _int32)) + +(define-comctl32 DefSubclassProc + (_fun #:abi winapi + _HWND _uint32 _WPARAM _LPARAM + -> _LRESULT)) + +(struct tray (frame + hwnd + id + callback-message + on-click + eventspace + event-channel + event-thread + subclass-proc + icon + menu + closed?) + #:mutable) + +(define next-tray-id 1) + +(define (allocate-tray-id) + (define id next-tray-id) + (when (> id #xffff) + (error 'mk-tray "too many tray icons have been created in this process")) + (set! next-tray-id (add1 next-tray-id)) + id) + +(define (bool-result? v) + (not (zero? v))) + +(define (call-in-eventspace eventspace thunk) + (define handler-thread (eventspace-handler-thread eventspace)) + (unless handler-thread + (error 'racket-tray "the frame's eventspace has been shut down")) + (if (eq? (current-thread) handler-thread) + (parameterize ([current-eventspace eventspace]) + (thunk)) + (let ([result-channel (make-channel)]) + (parameterize ([current-eventspace eventspace]) + (queue-callback + (λ () + (with-handlers ([exn? + (λ (exn) + (channel-put result-channel (cons 'error exn)))]) + (channel-put result-channel (cons 'ok (thunk))))))) + (match (channel-get result-channel) + [(cons 'ok value) value] + [(cons 'error exn) (raise exn)])))) + +(define (make-notify-data hwnd id callback-message icon) + (define data + (cast (malloc _NOTIFYICONDATAW 'atomic) + _pointer + _NOTIFYICONDATAW-pointer)) + (memset data 0 0 (ctype-sizeof _NOTIFYICONDATAW)) + (set-NOTIFYICONDATAW-cbSize! data (ctype-sizeof _NOTIFYICONDATAW)) + (set-NOTIFYICONDATAW-hWnd! data hwnd) + (set-NOTIFYICONDATAW-uID! data id) + (set-NOTIFYICONDATAW-uCallbackMessage! data callback-message) + (set-NOTIFYICONDATAW-hIcon! data icon) + data) + +(define (set-wide-array! array text capacity) + (define source (cast text _string/utf-16 _pointer)) + (for ([i (in-range capacity)]) + (array-set! array i 0)) + (let loop ([i 0]) + (when (< i (sub1 capacity)) + (let ([code-unit (ptr-ref source _uint16 i)]) + (unless (zero? code-unit) + (array-set! array i code-unit) + (loop (add1 i))))))) + +(define (load-ico-icon icon-file) + (define width (GetSystemMetrics SM_CXSMICON)) + (define height (GetSystemMetrics SM_CYSMICON)) + (define icon + (LoadImageW #f + (path->string (path->complete-path icon-file)) + IMAGE_ICON + width + height + LR_LOADFROMFILE)) + (unless icon + (error 'mk-tray "could not load ICO file: ~a" icon-file)) + icon) + +(define (png->icon icon-file) + ;; Racket's drawing library already decodes PNG and preserves its alpha + ;; channel. Scale it to the same system-small-icon size that is used for + ;; ICO files, then turn the premultiplied pixels into a native HICON. + (define source-bitmap + (read-bitmap icon-file 'png/alpha #f #t)) + (unless (send source-bitmap ok?) + (error 'mk-tray "could not load PNG file: ~a" icon-file)) + + (define width (max 1 (GetSystemMetrics SM_CXSMICON))) + (define height (max 1 (GetSystemMetrics SM_CYSMICON))) + (define source-width (send source-bitmap get-width)) + (define source-height (send source-bitmap get-height)) + + ;; Keep the aspect ratio and center non-square images in the tray-icon area. + (define scale + (min (/ width source-width) + (/ height source-height))) + (define draw-width (max 1 (inexact->exact (round (* source-width scale))))) + (define draw-height (max 1 (inexact->exact (round (* source-height scale))))) + (define draw-x (quotient (- width draw-width) 2)) + (define draw-y (quotient (- height draw-height) 2)) + + (define bitmap (make-bitmap width height #t)) + (define dc (new bitmap-dc% [bitmap bitmap])) + (send dc draw-bitmap-section-smooth + source-bitmap + draw-x + draw-y + draw-width + draw-height + 0 + 0 + source-width + source-height) + (send dc set-bitmap #f) + + (define pixel-count (* width height)) + (define argb (make-bytes (* pixel-count 4))) + (send bitmap get-argb-pixels 0 0 width height argb #f #t) + + (define header + (make-BITMAPINFOHEADER + (ctype-sizeof _BITMAPINFOHEADER) + width + (- height) ; negative means top-down, matching Racket's row order + 1 + 32 + BI_RGB + (* pixel-count 4) + 0 + 0 + 0 + 0)) + (define bits-out (malloc _pointer 'atomic)) + (ptr-set! bits-out _pointer #f) + (define color-bitmap + (CreateDIBSection #f header DIB_RGB_COLORS bits-out #f 0)) + (unless color-bitmap + (error 'mk-tray "CreateDIBSection failed while loading PNG icon: ~a" icon-file)) + + (define mask-bitmap #f) + (define (cleanup-bitmaps!) + (when mask-bitmap + (DeleteObject mask-bitmap) + (set! mask-bitmap #f)) + (when color-bitmap + (DeleteObject color-bitmap) + (set! color-bitmap #f))) + + (with-handlers ([exn? + (λ (exn) + (cleanup-bitmaps!) + (raise exn))]) + (define dib-bits (ptr-ref bits-out _pointer)) + (unless dib-bits + (error 'mk-tray "CreateDIBSection did not return pixel storage for: ~a" icon-file)) + + ;; Racket returns A,R,G,B. A Windows 32-bit DIB uses B,G,R,A byte order. + ;; get-argb-pixels was requested premultiplied because that is the form + ;; expected by alpha-blended Windows icons. + (for ([pixel (in-range pixel-count)]) + (define source (* pixel 4)) + (define alpha (bytes-ref argb source)) + (define red (bytes-ref argb (+ source 1))) + (define green (bytes-ref argb (+ source 2))) + (define blue (bytes-ref argb (+ source 3))) + (ptr-set! dib-bits _uint8 source blue) + (ptr-set! dib-bits _uint8 (+ source 1) green) + (ptr-set! dib-bits _uint8 (+ source 2) red) + (ptr-set! dib-bits _uint8 (+ source 3) alpha)) + + ;; For modern 32-bit alpha icons the color bitmap carries transparency. + ;; ICONINFO still requires a same-sized monochrome mask for a color icon. + (define mask-stride (* 2 (quotient (+ width 15) 16))) + (define mask-size (* mask-stride height)) + (define mask-bits (malloc mask-size 'atomic)) + (memset mask-bits 0 0 mask-size) + (set! mask-bitmap + (CreateBitmap width height 1 1 mask-bits)) + (unless mask-bitmap + (error 'mk-tray "CreateBitmap failed while loading PNG icon: ~a" icon-file)) + + (define icon-info + (make-ICONINFO 1 0 0 mask-bitmap color-bitmap)) + (define icon (CreateIconIndirect icon-info)) + + ;; CreateIconIndirect copies both bitmaps, so the source GDI objects can + ;; be released immediately. The returned HICON remains owned by us. + (cleanup-bitmaps!) + (unless icon + (error 'mk-tray "CreateIconIndirect failed while loading PNG icon: ~a" icon-file)) + icon)) + +(define (load-icon icon-file) + (define name + (string-downcase + (path->string (path->complete-path icon-file)))) + (cond + [(regexp-match? #rx"[.]ico$" name) + (load-ico-icon icon-file)] + [(regexp-match? #rx"[.]png$" name) + (png->icon icon-file)] + [else + (error 'mk-tray + "expected an .ico or .png icon file; got: ~a" + icon-file)])) + +(define (low-word value) + (bitwise-and value #xffff)) + +(define (signed-word value) + (define n (low-word value)) + (if (>= n #x8000) + (- n #x10000) + n)) + +(define (x-from-wparam wparam) + (signed-word wparam)) + +(define (y-from-wparam wparam) + (signed-word (arithmetic-shift wparam -16))) + +(define (menu-spec->popup-menu menu-spec) + (cond + [(not menu-spec) #f] + [(is-a? menu-spec popup-menu%) menu-spec] + [(list? menu-spec) + (let ([popup (new popup-menu%)]) + (for ([entry (in-list menu-spec)]) + (match entry + [(or #f 'separator) + (new separator-menu-item% [parent popup])] + [(list (? string? label) (? procedure? callback)) + (unless (procedure-arity-includes? callback 0) + (error 'tray-set-menu! + "menu callback for ~e does not accept zero arguments" + label)) + (new menu-item% + [parent popup] + [label label] + [callback (λ (_item _event) (callback))])] + [_ + (error 'tray-set-menu! + "expected a popup-menu% or a list containing (list label callback), #f, or 'separator; got: ~e" + entry)])) + popup)] + [else + (error 'tray-set-menu! + "expected a popup-menu%, menu specification list, or #f; got: ~e" + menu-spec)])) + +(define (queue-eventspace-callback t thunk) + (define eventspace (tray-eventspace t)) + (unless (eventspace-shutdown? eventspace) + (with-handlers ([exn:fail? (λ (_exn) (void))]) + (parameterize ([current-eventspace eventspace]) + (queue-callback + (λ () + (unless (tray-closed? t) + (thunk)))))))) + +(define (start-event-thread! t) + (define event-thread + (thread + (λ () + (let loop () + (match (sync (tray-event-channel t)) + ['close + (void)] + ['activate + (let ([callback (tray-on-click t)]) + (when callback + (queue-eventspace-callback t callback))) + (loop)] + [(vector 'context-menu screen-x screen-y) + (queue-eventspace-callback + t + (λ () + (define menu (tray-menu t)) + (when menu + (let-values ([(x y) + (send (tray-frame t) + screen->client + screen-x + screen-y)]) + (send (tray-frame t) popup-menu menu x y))))) + (loop)] + [_ + (loop)]))))) + (set-tray-event-thread! t event-thread)) + +(define (handle-native-tray-event t wparam lparam) + ;; Racket CS evaluates foreign callbacks in atomic mode. Do not run GUI or + ;; user code here. An OS async channel is explicitly safe to use from an OS + ;; callback/thread, so forward the event to an ordinary Racket thread. + (define notification (low-word lparam)) + (cond + [(or (= notification NIN_SELECT) + (= notification NIN_KEYSELECT)) + (os-async-channel-put (tray-event-channel t) 'activate)] + [(= notification WM_CONTEXTMENU) + (os-async-channel-put + (tray-event-channel t) + (vector 'context-menu + (x-from-wparam wparam) + (y-from-wparam wparam)))] + [else + (void)])) + +(define (make-subclass-proc t) + (λ (hwnd msg wparam lparam subclass-id ref-data) + (cond + [(= msg (tray-callback-message t)) + (handle-native-tray-event t wparam lparam) + 0] + [(= msg WM_NCDESTROY) + ;; The HWND is going away. Remove the notification-area icon while the + ;; handle is still valid. Windows discards the subclass automatically + ;; as part of window destruction. + (unless (tray-closed? t) + (let ([data + (make-notify-data hwnd + (tray-id t) + (tray-callback-message t) + (tray-icon t))]) + (Shell_NotifyIconW NIM_DELETE data) + (when (tray-icon t) + (DestroyIcon (tray-icon t)) + (set-tray-icon! t #f)) + (set-tray-closed?! t #t) + (os-async-channel-put (tray-event-channel t) 'close))) + (DefSubclassProc hwnd msg wparam lparam)] + [else + (DefSubclassProc hwnd msg wparam lparam)]))) + +(define (add-notify-icon! t icon tooltip) + (define data + (make-notify-data (tray-hwnd t) + (tray-id t) + (tray-callback-message t) + icon)) + (set-NOTIFYICONDATAW-uFlags! + data + (bitwise-ior NIF_MESSAGE NIF_ICON NIF_TIP NIF_SHOWTIP)) + (set-wide-array! (NOTIFYICONDATAW-szTip data) tooltip 128) + + (unless (bool-result? (Shell_NotifyIconW NIM_ADD data)) + (error 'mk-tray "Shell_NotifyIconW failed to add the tray icon")) + + (set-NOTIFYICONDATAW-uVersion! data NOTIFYICON_VERSION_4) + (unless (bool-result? (Shell_NotifyIconW NIM_SETVERSION data)) + (Shell_NotifyIconW NIM_DELETE data) + (error 'mk-tray "Shell_NotifyIconW could not enable NOTIFYICON_VERSION_4"))) + +(define (mk-tray frame icon-file on-click-cb) + (unless (is-a? frame top-level-window<%>) + (raise-argument-error 'mk-tray "(is-a?/c top-level-window<%>)" frame)) + (unless (or (not on-click-cb) + (and (procedure? on-click-cb) + (procedure-arity-includes? on-click-cb 0))) + (raise-argument-error 'mk-tray "(or/c #f (-> any))" on-click-cb)) + + (define eventspace (send frame get-eventspace)) + (call-in-eventspace + eventspace + (λ () + (define hwnd (send frame get-handle)) + (unless hwnd + (error 'mk-tray "the frame does not have a native HWND")) + + (let* ([id (allocate-tray-id)] + [callback-message (+ WM_APP id)] + [icon (load-icon icon-file)] + [t (tray frame + hwnd + id + callback-message + on-click-cb + eventspace + (make-os-async-channel) + #f + #f + icon + #f + #f)] + [subclass-proc + (function-ptr (make-subclass-proc t) _SUBCLASSPROC)]) + ;; WM_APP through 0xBFFF is reserved for application-private messages. + (when (> callback-message #xbfff) + (DestroyIcon icon) + (error 'mk-tray + "too many simultaneously addressable tray callback messages")) + + (set-tray-subclass-proc! t subclass-proc) + (start-event-thread! t) + + (unless (bool-result? + (SetWindowSubclass hwnd subclass-proc id 0)) + (os-async-channel-put (tray-event-channel t) 'close) + (DestroyIcon icon) + (error 'mk-tray "SetWindowSubclass failed for the Racket frame")) + + (with-handlers ([exn? + (λ (exn) + (RemoveWindowSubclass hwnd subclass-proc id) + (os-async-channel-put (tray-event-channel t) 'close) + (DestroyIcon icon) + (raise exn))]) + (define frame-label (send frame get-label)) + (add-notify-icon! t icon + (if (string? frame-label) frame-label "Racket")) + t))))) + +(define (check-open-tray who t) + (unless (tray? t) + (raise-argument-error who "tray?" t)) + (when (tray-closed? t) + (error who "tray icon is already closed"))) + +(define (tray-close t) + (unless (tray? t) + (raise-argument-error 'tray-close "tray?" t)) + (unless (tray-closed? t) + (call-in-eventspace + (tray-eventspace t) + (λ () + (unless (tray-closed? t) + (let ([data + (make-notify-data (tray-hwnd t) + (tray-id t) + (tray-callback-message t) + (tray-icon t))]) + (Shell_NotifyIconW NIM_DELETE data) + (RemoveWindowSubclass (tray-hwnd t) + (tray-subclass-proc t) + (tray-id t)) + (when (tray-icon t) + (DestroyIcon (tray-icon t)) + (set-tray-icon! t #f)) + (set-tray-closed?! t #t) + (os-async-channel-put (tray-event-channel t) 'close)))))) + (void)) + +(define (tray-set-icon! t icon-file) + (check-open-tray 'tray-set-icon! t) + (call-in-eventspace + (tray-eventspace t) + (λ () + (define new-icon (load-icon icon-file)) + (define data + (make-notify-data (tray-hwnd t) + (tray-id t) + (tray-callback-message t) + new-icon)) + (set-NOTIFYICONDATAW-uFlags! data NIF_ICON) + (cond + [(bool-result? (Shell_NotifyIconW NIM_MODIFY data)) + (let ([old-icon (tray-icon t)]) + (set-tray-icon! t new-icon) + (when old-icon + (DestroyIcon old-icon)))] + [else + (DestroyIcon new-icon) + (error 'tray-set-icon! "Shell_NotifyIconW failed to change the icon")])))) + +(define (tray-set-menu! t menu-spec) + (check-open-tray 'tray-set-menu! t) + (call-in-eventspace + (tray-eventspace t) + (λ () + (set-tray-menu! t (menu-spec->popup-menu menu-spec)))) + (void)) diff --git a/scrbl/racket-tray.scrbl b/scrbl/racket-tray.scrbl new file mode 100644 index 0000000..0ab65e5 --- /dev/null +++ b/scrbl/racket-tray.scrbl @@ -0,0 +1,44 @@ +#lang scribble/manual + +@(require (for-label racket/base + racket/class + racket/gui/base + racket-tray)) + +@title{Racket Tray} +@author{hnmdijkema} + +@defmodule[racket-tray] + +Racket Tray provides a small system-tray API. Version 0.1 supports Windows. +The Windows implementation uses the native handle of an existing Racket GUI +top-level window and does not require an additional native library. + +@defproc[(mk-tray [frame (is-a?/c top-level-window<%>)] + [icon-file path-string?] + [on-click-cb (or/c #f (-> any))]) + any/c]{ +Creates a tray icon associated with @racket[frame]. @racket[icon-file] can be +a Windows @tt{.ico} file or a @tt{.png} file. PNG alpha transparency is +preserved. When the tray icon is activated, @racket[on-click-cb] is queued in +the eventspace of @racket[frame]. The returned value is passed to the other +procedures in this library. +} + +@defproc[(tray-close [tray any/c]) void?]{ +Removes the tray icon and releases the Windows resources associated with it. +} + +@defproc[(tray-set-icon! [tray any/c] + [icon-file path-string?]) void?]{ +Replaces the icon of @racket[tray] with the icon loaded from +@racket[icon-file]. Both @tt{.ico} and @tt{.png} files are accepted. +} + +@defproc[(tray-set-menu! [tray any/c] + [menu any/c]) void?]{ +Sets the context menu for @racket[tray]. @racket[menu] can be a +@racket[popup-menu%], @racket[#f], or a list. A list entry of the form +@racket[(list label callback)] creates an item, while @racket['separator] or +@racket[#f] creates a separator. Each callback is a zero-argument procedure. +} diff --git a/tests/basic.rkt b/tests/basic.rkt new file mode 100644 index 0000000..91015f7 --- /dev/null +++ b/tests/basic.rkt @@ -0,0 +1,10 @@ +#lang racket/base + +(require rackunit + racket-tray) + +;; The public module must be loadable on non-Windows platforms as well. +(check-true (procedure? mk-tray)) +(check-true (procedure? tray-close)) +(check-true (procedure? tray-set-icon!)) +(check-true (procedure? tray-set-menu!))