1(* 2 Copyright (c) 2001, 2015 3 David C.J. Matthews 4 5 This library is free software; you can redistribute it and/or 6 modify it under the terms of the GNU Lesser General Public 7 License version 2.1 as published by the Free Software Foundation. 8 9 This library is distributed in the hope that it will be useful, 10 but WITHOUT ANY WARRANTY; without even the implied warranty of 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 Lesser General Public License for more details. 13 14 You should have received a copy of the GNU Lesser General Public 15 License along with this library; if not, write to the Free Software 16 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 17*) 18structure Class: 19sig 20 type HWND (* = Win.HWND *) and Message (* = Message.Message *) 21 and HINSTANCE (* = Globals.HINSTANCE *) 22 and HBRUSH (* = Brush.HBRUSH *) 23 and HICON (* = Icon.HICON *) 24 and HCURSOR (* = Cursor.HCURSOR *) 25 and HGDIOBJ 26 27 datatype LRESULT = 28 LRESINT of int | LRESHANDLE of HGDIOBJ 29 30 datatype 'a ATOM = 31 Registered of 32 {proc: HWND * Message * 'a -> LRESULT * 'a, className: string} 33 | SystemClass of string 34 35 val Button : unit ATOM 36 val ComboBox : unit ATOM 37 val ComboLBox : unit ATOM 38 val DDEMLEvent : unit ATOM 39 val Edit : unit ATOM 40 val ListBox : unit ATOM 41 val MDIClient : unit ATOM 42 val ScrollBar : unit ATOM 43 val Static : unit ATOM 44 45 structure Style : 46 sig 47 include BIT_FLAGS 48 49 val CS_BYTEALIGNCLIENT : flags 50 val CS_BYTEALIGNWINDOW : flags 51 val CS_CLASSDC : flags 52 val CS_DBLCLKS : flags 53 val CS_GLOBALCLASS : flags 54 val CS_HREDRAW : flags 55 val CS_KEYCVTWINDOW : flags 56 val CS_NOCLOSE : flags 57 val CS_NOKEYCVT : flags 58 val CS_OWNDC : flags 59 val CS_PARENTDC : flags 60 val CS_SAVEBITS : flags 61 val CS_VREDRAW : flags 62 end 63 64 type 'a WNDCLASSEX = 65 {style: Style.flags, 66 wndProc: HWND * Message * 'a -> LRESULT * 'a, 67 hInstance: HINSTANCE, 68 hIcon: HICON option, 69 hCursor: HCURSOR option, 70 hbrBackGround: HBRUSH option, 71 menuName: Resource.RESID option, 72 className: string, 73 hIconSm: HICON option} 74 75 val RegisterClassEx : 'a WNDCLASSEX -> 'a ATOM 76 77 val UnregisterClass : string * HINSTANCE -> unit 78 val GetClassInfoEx: HINSTANCE * string -> 'a WNDCLASSEX 79 end 80 = 81struct 82 local 83 open Foreign 84 open Base 85 open Resource 86 in 87 type Message = Message.Message 88 type HWND = HWND and HINSTANCE = HINSTANCE and HICON = HICON 89 and HBRUSH = HBRUSH and HCURSOR = HCURSOR and HGDIOBJ = HGDIOBJ 90 datatype LRESULT = datatype Message.LRESULT 91 92 structure Style = 93 struct 94 open Word32 95 type flags = Word32.word 96 val toWord = SysWord.fromLargeWord o toLargeWord 97 and fromWord = fromLargeWord o SysWord.toLargeWord 98 val flags = List.foldl (fn (a, b) => orb(a,b)) 0w0 99 fun allSet (fl1, fl2) = andb(fl1, fl2) = fl1 100 fun anySet (fl1, fl2) = andb(fl1, fl2) <> 0w0 101 fun clear (fl1, fl2) = andb(notb fl1, fl2) 102 103 val CS_VREDRAW: flags = 0wx0001 104 val CS_HREDRAW: flags = 0wx0002 105 val CS_KEYCVTWINDOW: flags = 0wx0004 106 val CS_DBLCLKS: flags = 0wx0008 107 val CS_OWNDC: flags = 0wx0020 108 val CS_CLASSDC: flags = 0wx0040 109 val CS_PARENTDC: flags = 0wx0080 110 val CS_NOKEYCVT: flags = 0wx0100 111 val CS_NOCLOSE: flags = 0wx0200 112 val CS_SAVEBITS: flags = 0wx0800 113 val CS_BYTEALIGNCLIENT: flags = 0wx1000 114 val CS_BYTEALIGNWINDOW: flags = 0wx2000 115 val CS_GLOBALCLASS: flags = 0wx4000 116 117 val all = flags[CS_VREDRAW, CS_HREDRAW, CS_KEYCVTWINDOW, CS_DBLCLKS, CS_OWNDC, 118 CS_CLASSDC, CS_NOKEYCVT, CS_NOCLOSE, CS_SAVEBITS, 119 CS_BYTEALIGNCLIENT, CS_BYTEALIGNWINDOW, CS_GLOBALCLASS] 120 121 val intersect = List.foldl (fn (a, b) => andb(a,b)) all 122 end 123 124 (* Classes are either registered by the user, in which case they have 125 ML callback functions, or they are built-in, such as Edit. *) 126 datatype 'a ATOM = 127 Registered of { proc: HWND * Message * 'a -> LRESULT * 'a, className: string } 128 | SystemClass of string 129 130 val Button: unit ATOM = SystemClass "Button" 131 and ComboBox: unit ATOM = SystemClass "ComboBox" 132 and ComboLBox: unit ATOM = SystemClass "ComboLBox" 133 and DDEMLEvent: unit ATOM = SystemClass "DDEMLEvent" 134 and Edit: unit ATOM = SystemClass "Edit" 135 and ListBox: unit ATOM = SystemClass "ListBox" 136 and MDIClient: unit ATOM = SystemClass "MDIClient" (* Maybe treat this specially. *) 137 and ScrollBar: unit ATOM = SystemClass "ScrollBar" 138 and Static: unit ATOM = SystemClass "Static" 139 140 type 'a WNDCLASSEX = 141 {style: Style.flags, 142 wndProc: HWND * Message * 'a -> LRESULT * 'a, 143 hInstance: HINSTANCE, 144 hIcon: HICON option, 145 hCursor: HCURSOR option, 146 hbrBackGround: HBRUSH option, 147 menuName: RESID option, 148 className: string, 149 hIconSm: HICON option} 150 151 local 152 val cWNDCLASSEX = cStruct12(cUint,cUintw, cFunction,cInt,cInt,cHINSTANCE,cHGDIOBJOPT, 153 cHGDIOBJOPT,cHGDIOBJOPT,cRESID,cString,cHGDIOBJOPT) 154 val { ctype = {size=sizeWndclassEx, ...}, ...} = breakConversion cWNDCLASSEX 155 val registerClassEx = winCall1 (user "RegisterClassExA") (cConstStar cWNDCLASSEX) cUint 156 in 157 fun RegisterClassEx({style: Style.flags, 158 wndProc: HWND * Message * 'a -> LRESULT * 'a, 159 hInstance: HINSTANCE, 160 hIcon: HICON option, 161 hCursor: HCURSOR option, 162 hbrBackGround: HBRUSH option, 163 menuName: RESID option, 164 className: string, 165 hIconSm: HICON option}: 'a WNDCLASSEX): 'a ATOM = 166 let 167 (* The window procedure we pass to the C call is our dispatch function 168 in the RTS. *) 169 val windowProc = Message.mainWinProc 170 val cWndClass = 171 (Word.toInt sizeWndclassEx, 172 style, 173 windowProc, 174 0, (* Class extra *) 175 0, (* Window extra *) 176 hInstance, 177 hIcon, 178 hCursor, 179 hbrBackGround, 180 getOpt(menuName, IdAsInt 0), 181 className, 182 hIconSm) 183 184 val res = registerClassEx cWndClass 185 (* The result is supposed to be an atom but it doesn't always work to 186 pass this directly to CreateWindow. *) 187 in 188 checkResult(res <> 0); 189 Registered{proc = wndProc, className = className} 190 end 191 end 192 193 local 194 (* We can't use the same definition of WNDCLASSEX as above because 195 we can't return a callback function as a result, at least at the 196 moment. 197 Also we use CallWindowProc because it does Unicode to ANSI conversion. *) 198 val cWNDCLASSEX = cStruct12(cUint,cUint, cPointer,cInt,cInt,cHINSTANCE,cHGDIOBJOPT, 199 cHGDIOBJOPT,cHGDIOBJOPT,cRESID,cString,cHGDIOBJOPT) 200 val { ctype = {size=sizeWndclassEx, ...}, ...} = breakConversion cWNDCLASSEX 201 val CallWindowProc = 202 winCall5 (user "CallWindowProcA") (cPointer, cHWND, cUint, cUINT_PTRw, cUINT_PTRw) cUINT_PTRw 203 in 204 fun GetClassInfoEx(hInst, class): 'a WNDCLASSEX = 205 let 206 val v = 207 ref(Word.toInt sizeWndclassEx, 0, Memory.null, 0, 0, hNull, 208 NONE, NONE, NONE, IdAsInt 0, "", NONE) 209 val () = winCall3(user "GetClassInfoExA") (cHINSTANCE, cString, cStar cWNDCLASSEX) 210 (successState "GetClassInfoEx") (hInst, class, v) 211 val (_, style, wproc, _, _, hInstance, hIcon, hCursor, hbrBackGround, 212 menuName, className, hIconSm) = !v 213 val mName = 214 case menuName of 215 IdAsInt 0 => NONE 216 | IdAsString "" => NONE 217 | m => SOME m 218 fun wndProc(hwnd, msg, state) = 219 let 220 val (msgId: int, wParam, lParam, freeMsg) = Message.compileMessage msg 221 val res = CallWindowProc(wproc, hwnd, msgId, wParam, lParam) 222 in 223 (Message.messageReturnFromParams(msg, wParam, lParam, res), state) 224 before freeMsg() 225 end 226 in 227 {style = Style.fromWord(LargeWord.fromInt style), wndProc = wndProc, hInstance = hInstance, 228 hIcon = hIcon, hCursor = hCursor, hbrBackGround = hbrBackGround, 229 menuName = mName, className = className, hIconSm = hIconSm }: 'a WNDCLASSEX 230 end 231 232 (* The underlying call can take either a string or an atom. I really don't 233 know which is better here. *) 234 (* TODO: We should extract the window proc and call freeCallback on it. *) 235 val UnregisterClass = 236 winCall2 (user "UnregisterClassA") (cString, cHINSTANCE) (successState "UnregisterClass") 237 end 238(* 239The following functions are used with window classes. 240GetClassInfoEx 241GetClassLong 242GetWindowLong - in Window 243SetClassLong 244SetWindowLong 245 246Obsolete Functions 247 248GetClassInfo 249GetClassWord 250GetWindowWord 251RegisterClass 252SetClassWord 253SetWindowWord 254*) 255 end 256end; 257