1(* 2 Copyright (c) 2001-7, 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*) 18 19(* 20Dialogue boxes and operations on them. 21*) 22structure Dialog: 23sig 24 type HWND and HINSTANCE 25 datatype 26 DLGCLASSES = 27 DLG_CLASS of string * Window.Style.flags 28 | DLG_BUTTON of Button.Style.flags 29 | DLG_COMBOBOX of Combobox.Style.flags 30 | DLG_EDIT of Edit.Style.flags 31 | DLG_LISTBOX of Listbox.Style.flags 32 | DLG_SCROLLBAR of Scrollbar.Style.flags 33 | DLG_STATIC of Static.Style.flags 34 35 datatype DLGTITLE = DLG_TITLERESOURCE of int | DLG_TITLESTRING of string 36 37 structure Style: 38 sig 39 include BIT_FLAGS 40 val WS_OVERLAPPED: flags and WS_POPUP: flags and WS_CHILD: flags and WS_MINIMIZE: flags 41 and WS_VISIBLE: flags and WS_DISABLED:flags and WS_CLIPSIBLINGS:flags 42 and WS_CLIPCHILDREN:flags and WS_MAXIMIZE:flags and WS_CAPTION:flags 43 and WS_BORDER:flags and WS_DLGFRAME:flags and WS_VSCROLL:flags and WS_HSCROLL:flags 44 and WS_SYSMENU:flags and WS_THICKFRAME:flags and WS_GROUP:flags and WS_TABSTOP:flags 45 and WS_MINIMIZEBOX:flags and WS_MAXIMIZEBOX:flags and WS_TILED:flags and WS_ICONIC:flags 46 and WS_SIZEBOX:flags and WS_OVERLAPPEDWINDOW:flags and WS_TILEDWINDOW:flags 47 and WS_POPUPWINDOW:flags and WS_CHILDWINDOW:flags 48 and DS_3DLOOK: flags and DS_ABSALIGN: flags and DS_CENTER: flags and DS_CENTERMOUSE: flags 49 and DS_CONTEXTHELP: flags and DS_CONTROL: flags and DS_FIXEDSYS: flags 50 and DS_LOCALEDIT: flags and DS_MODALFRAME: flags and DS_NOFAILCREATE: flags 51 and DS_NOIDLEMSG: flags and DS_SETFONT: flags and DS_SETFOREGROUND: flags 52 and DS_SYSMODAL: flags 53 end 54 55 type DLGITEMTEMPLATE = 56 { extendedStyle: int, 57 x: int, 58 y: int, 59 cx : int, 60 cy: int, 61 id: int, 62 class: DLGCLASSES, 63 title: DLGTITLE, 64 creationData: Word8Vector.vector option 65 } 66 67 type DLGTEMPLATE = 68 { style: Style.flags, 69 extendedStyle: int, 70 x : int, 71 y: int, 72 cx: int, 73 cy: int, 74 menu: Resource.RESID option, 75 class: Resource.RESID option, 76 title: string, 77 font: (int * string) option, 78 items: DLGITEMTEMPLATE list 79 } 80 81 82 val DialogBox : 83 HINSTANCE * Resource.RESID * HWND * 84 (HWND * Message.Message * 'a -> Message.LRESULT * 'a) * 'a -> int 85 val DialogBoxIndirect: HINSTANCE * DLGTEMPLATE * HWND * 86 (HWND * Message.Message * 'a -> Message.LRESULT * 'a) * 'a -> int 87 val CreateDialog : HINSTANCE * Resource.RESID * HWND * 88 (HWND * Message.Message * 'a -> Message.LRESULT * 'a) * 'a -> HWND 89 val CreateDialogIndirect: HINSTANCE * DLGTEMPLATE * HWND * 90 (HWND * Message.Message * 'a -> Message.LRESULT * 'a) * 'a -> HWND 91 92 val GetDialogBaseUnits : unit -> {horizontal: int, vertical: int} 93 94 val GetDlgCtrlID: HWND -> int 95 and GetDlgItem: HWND * int -> HWND 96 and GetDlgItemText: HWND * int -> string 97 and IsDialogMessage: HWND * Message.MSG -> bool 98 and EndDialog: HWND * int -> unit 99 100(* MessageBox and MessageBeep are in the MessageBox structure. *) 101(* 102CreateDialogIndirectParam 103CreateDialogParam 104DefDlgProc - Used to create custom dialogues 105DialogBoxIndirectParam 106DialogBoxParam 107DialogProc 108GetDlgItemInt - Ignore - probably better done with Int.toString 109SetDlgItemInt - ditto 110GetNextDlgGroupItem 111GetNextDlgTabItem 112MapDialogRect 113MessageBoxEx 114SendDlgItemMessage 115SetDlgItemText 116MessageBoxIndirect 117*) 118 119 120 val compileTemplate : DLGTEMPLATE -> Word8Vector.vector 121 val decompileTemplate : Word8Vector.vector -> DLGTEMPLATE 122end = 123struct 124 local 125 open Foreign 126 open Base 127 open Globals 128 open Window 129 open Resource 130 131 fun checkWindow c = (checkResult(not(isHNull c)); c) 132 133 (* Dialogue procedures never call DefWindowProc. *) 134 fun dlgProcRes (lres, state) = (lres, state) 135 in 136 type HWND = HWND and HINSTANCE = HINSTANCE 137 138 datatype DLGCLASSES = 139 DLG_CLASS of string * Window.Style.flags (* Named window class. *) 140 | DLG_BUTTON of Button.Style.flags 141 | DLG_EDIT of Edit.Style.flags 142 | DLG_STATIC of Static.Style.flags 143 | DLG_LISTBOX of Listbox.Style.flags 144 | DLG_SCROLLBAR of Scrollbar.Style.flags 145 | DLG_COMBOBOX of Combobox.Style.flags 146 147 datatype DLGTITLE = DLG_TITLESTRING of string | DLG_TITLERESOURCE of int 148 149 structure Style = 150 struct 151 open Window.Style (* Include all the windows styles. *) 152 153 val DS_ABSALIGN: flags = fromWord 0wx0001 154 val DS_SYSMODAL: flags = fromWord 0wx0002 155 val DS_LOCALEDIT: flags = fromWord 0wx0020 156 val DS_SETFONT: flags = fromWord 0wx0040 157 val DS_MODALFRAME: flags = fromWord 0wx0080 158 val DS_NOIDLEMSG: flags = fromWord 0wx0100 159 val DS_SETFOREGROUND: flags = fromWord 0wx0200 160 val DS_3DLOOK: flags = fromWord 0wx0004 161 val DS_FIXEDSYS: flags = fromWord 0wx0008 162 val DS_NOFAILCREATE: flags = fromWord 0wx0010 163 val DS_CONTROL: flags = fromWord 0wx0400 164 val DS_CENTER: flags = fromWord 0wx0800 165 val DS_CENTERMOUSE: flags = fromWord 0wx1000 166 val DS_CONTEXTHELP: flags = fromWord 0wx2000 167 168 val all = flags[Window.Style.all, DS_ABSALIGN, DS_SYSMODAL, DS_LOCALEDIT, DS_SETFONT, 169 DS_MODALFRAME, DS_NOIDLEMSG, DS_SETFOREGROUND, DS_3DLOOK, DS_FIXEDSYS, 170 DS_NOFAILCREATE, DS_CONTROL, DS_CENTER, DS_CENTERMOUSE, DS_CONTEXTHELP] 171 172 val intersect = 173 List.foldl (fn (a, b) => fromWord(SysWord.andb(toWord a, toWord b))) all 174 end 175 176 type DLGITEMTEMPLATE = 177 { extendedStyle: int, 178 x: int, 179 y: int, 180 cx : int, 181 cy: int, 182 id: int, 183 class: DLGCLASSES, 184 title: DLGTITLE, 185 creationData: Word8Vector.vector option 186 } 187 188 type DLGTEMPLATE = 189 { style: Style.flags, 190 extendedStyle: int, 191 x : int, 192 y: int, 193 cx: int, 194 cy: int, 195 menu: Resource.RESID option, 196 class: Resource.RESID option, 197 title: string, 198 font: (int * string) option, 199 items: DLGITEMTEMPLATE list 200 } 201 202 (* Convert between the data structures and the templates. *) 203 (* TODO: This only deals with the basic templates not the extended 204 versions. *) 205 fun decompileTemplate (w: Word8Vector.vector): DLGTEMPLATE = 206 let 207 val ptr = ref 0 208 val isExtended = PackWord32Little.subVec(w, 0) = 0wxFFFF0001 209 val _ = if isExtended then raise Fail "Extended templates not implemented" else (); 210 211 val style = PackWord32Little.subVec(w, !ptr div 4) 212 val _ = ptr := !ptr + 4; 213 val exStyle = LargeWord.toInt(PackWord32Little.subVec(w, !ptr div 4)) 214 val _ = ptr := !ptr + 4; 215 val cdit = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) 216 val _ = ptr := !ptr + 2; 217 val x = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) 218 val _ = ptr := !ptr + 2; 219 val y = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) 220 val _ = ptr := !ptr + 2; 221 val cx = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) 222 val _ = ptr := !ptr + 2; 223 val cy = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) 224 val _ = ptr := !ptr + 2; 225 226 (* Extract a null-terminated Unicode string and advance ptr beyond it. *) 227 fun getString () = 228 let 229 val start = !ptr 230 fun advance () = 231 let 232 val next = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) 233 in 234 ptr := !ptr + 2; 235 if next = 0 then () else advance() 236 end 237 in 238 advance(); 239 unicodeToString(Word8VectorSlice.vector(Word8VectorSlice.slice(w, start, SOME(!ptr-start-2)))) 240 end 241 242 fun ffffOrString(): Resource.RESID = 243 let 244 val next = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) 245 in 246 if next = 0xffff 247 then ( (* Resource identifier. *) 248 ptr := !ptr + 4; 249 Resource.IdAsInt(LargeWord.toInt(PackWord16Little.subVec(w, (!ptr-2) div 2))) 250 ) 251 else (* Resource name. *) 252 Resource.IdAsString(getString()) 253 end 254 255 (* Menu. *) 256 val menu = 257 case ffffOrString() of 258 Resource.IdAsString "" => NONE 259 | r => SOME r 260 261 (* Class. *) 262 val class = 263 case ffffOrString() of 264 Resource.IdAsString "" => NONE 265 | r => SOME r 266 267 (* Title - null terminated Unicode string. *) 268 val title = getString() 269 (* Font - only if DS_SETFONT included in the style. *) 270 val font = 271 if Style.anySet(Style.fromWord style, Style.DS_SETFONT) 272 then 273 let 274 val size = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) 275 val _ = ptr := !ptr + 2 276 val name = getString() 277 in 278 SOME(size, name) 279 end 280 else NONE 281 282 (* Items. *) 283 fun processItem _ : DLGITEMTEMPLATE = 284 let 285 (* Must be aligned onto a DWORD boundary. *) 286 val _ = while !ptr mod 4 <> 0 do ptr := !ptr + 1; 287 288 val style = PackWord32Little.subVec(w, !ptr div 4) 289 val _ = ptr := !ptr + 4; 290 val exStyle = LargeWord.toInt(PackWord32Little.subVec(w, !ptr div 4)) 291 val _ = ptr := !ptr + 4; 292 val x = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) 293 val _ = ptr := !ptr + 2; 294 val y = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) 295 val _ = ptr := !ptr + 2; 296 val cx = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) 297 val _ = ptr := !ptr + 2; 298 val cy = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) 299 val _ = ptr := !ptr + 2; 300 val id = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) 301 val _ = ptr := !ptr + 2; 302 303 val class = 304 case ffffOrString() of 305 Resource.IdAsString s => DLG_CLASS (s, Window.Style.fromWord style) 306 | Resource.IdAsInt 0x0080 => DLG_BUTTON (Button.Style.fromWord style) 307 | Resource.IdAsInt 0x0081 => DLG_EDIT (Edit.Style.fromWord style) 308 | Resource.IdAsInt 0x0082 => DLG_STATIC (Static.Style.fromWord style) 309 | Resource.IdAsInt 0x0083 => DLG_LISTBOX (Listbox.Style.fromWord style) 310 | Resource.IdAsInt 0x0084 => DLG_SCROLLBAR (Scrollbar.Style.fromWord style) 311 | Resource.IdAsInt 0x0085 => DLG_COMBOBOX (Combobox.Style.fromWord style) 312 | _ => raise Fail "Unknown dialog type" 313 314 val title = 315 case ffffOrString() of 316 Resource.IdAsString s => DLG_TITLESTRING s 317 | Resource.IdAsInt i => DLG_TITLERESOURCE i 318 319 val creation = 320 let 321 val length = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) 322 val _ = ptr := !ptr + 2; 323 val start = !ptr 324 val _ = ptr := !ptr + length 325 in 326 if length = 0 327 then NONE 328 else SOME(Word8VectorSlice.vector(Word8VectorSlice.slice(w, start, SOME length))) 329 end 330 in 331 { 332 extendedStyle = exStyle, 333 x = x, 334 y = y, 335 cx = cx, 336 cy = cy, 337 id = id, 338 class = class, 339 title = title, 340 creationData = creation 341 } 342 end 343 in 344 { style = Style.fromWord style, 345 extendedStyle = exStyle, 346 x = x, 347 y = y, 348 cx = cx, 349 cy = cy, 350 menu = menu, 351 class = class, 352 title = title, 353 font = font, 354 items = List.tabulate(cdit, processItem) 355 } 356 end; 357 358 (* Generate a dialogue template in memory. *) 359 fun compileTemplate (t: DLGTEMPLATE) = 360 let 361 val basis = Word8Array.array (18, 0w0) 362 val nullString = Word8Vector.tabulate(2, fn _ => 0w0) 363 (* Force DS_SETFONT in the style according to whether we have a font specified. *) 364 val style = 365 if #font t = NONE 366 then Style.clear(Style.DS_SETFONT, #style t) 367 else Style.flags[#style t, Style.DS_SETFONT] 368 val _ = PackWord32Little.update(basis, 0, Style.toWord style); 369 val _ = PackWord32Little.update(basis, 1, LargeWord.fromInt(#extendedStyle t)); 370 val _ = PackWord16Little.update(basis, 4, LargeWord.fromInt(List.length(#items t))); 371 val _ = PackWord16Little.update(basis, 5, LargeWord.fromInt(#x t)); 372 val _ = PackWord16Little.update(basis, 6, LargeWord.fromInt(#y t)); 373 val _ = PackWord16Little.update(basis, 7, LargeWord.fromInt(#cx t)); 374 val _ = PackWord16Little.update(basis, 8, LargeWord.fromInt(#cy t)); 375 376 fun unicodeString s = Word8Vector.concat[stringToUnicode s, nullString] 377 378 fun resOrString (Resource.IdAsString s) = unicodeString s 379 | resOrString (Resource.IdAsInt i) = 380 Word8Vector.fromList 381 [0wxff, 0wxff, Word8.fromInt i, Word8.fromInt(i div 256)] 382 val menu = 383 case #menu t of 384 NONE => nullString 385 | SOME r => resOrString r 386 387 val class = 388 case #class t of 389 NONE => nullString 390 | SOME r => resOrString r 391 392 val title = unicodeString(#title t) 393 val font = 394 case #font t of 395 SOME (size, name) => 396 [Word8Vector.fromList 397 [Word8.fromInt size, Word8.fromInt(size div 256)], 398 stringToUnicode name, nullString] 399 400 | NONE => [] 401 402 fun compileItems [] = [] 403 | compileItems((t: DLGITEMTEMPLATE) :: rest) = 404 let 405 val basis = Word8Array.array(18, 0w0) 406 val (style, class) = 407 case #class t of 408 DLG_CLASS(c, s) => (Window.Style.toWord s, Resource.IdAsString c) 409 | DLG_BUTTON s => (Button.Style.toWord s, Resource.IdAsInt 0x80) 410 | DLG_COMBOBOX s => (Combobox.Style.toWord s, Resource.IdAsInt 0x85) 411 | DLG_EDIT s => (Edit.Style.toWord s, Resource.IdAsInt 0x81) 412 | DLG_LISTBOX s => (Listbox.Style.toWord s, Resource.IdAsInt 0x83) 413 | DLG_SCROLLBAR s => (Scrollbar.Style.toWord s, Resource.IdAsInt 0x84) 414 | DLG_STATIC s => (Static.Style.toWord s, Resource.IdAsInt 0x82) 415 416 val _ = PackWord32Little.update(basis, 0, style); 417 val _ = PackWord32Little.update(basis, 1, LargeWord.fromInt(#extendedStyle t)); 418 val _ = PackWord16Little.update(basis, 4, LargeWord.fromInt(#x t)); 419 val _ = PackWord16Little.update(basis, 5, LargeWord.fromInt(#y t)); 420 val _ = PackWord16Little.update(basis, 6, LargeWord.fromInt(#cx t)); 421 val _ = PackWord16Little.update(basis, 7, LargeWord.fromInt(#cy t)); 422 val _ = PackWord16Little.update(basis, 8, LargeWord.fromInt(#id t)); 423 val title = 424 resOrString( 425 case #title t of 426 DLG_TITLESTRING s => Resource.IdAsString s 427 | DLG_TITLERESOURCE i => Resource.IdAsInt i) 428 429 val creation = 430 case #creationData t of 431 NONE => [nullString] 432 | SOME r => [r, nullString] 433 val vec = 434 Word8Vector.concat 435 (Word8ArraySlice.vector(Word8ArraySlice.full basis) :: 436 resOrString class :: title :: creation) 437 val rounding = Word8Vector.length vec mod 4 438 in 439 (* Must align onto a 4-byte boundary except for the last. *) 440 (if rounding = 0 orelse rest = nil then vec 441 else Word8Vector.concat[vec, Word8Vector.tabulate(4-rounding, fn _ => 0w0)]) :: 442 compileItems rest 443 end 444 445 val header = 446 Word8Vector.concat 447 (Word8ArraySlice.vector(Word8ArraySlice.full basis) :: menu :: class :: title :: font) 448 val rounding = Word8Vector.length header mod 4 449 val alignment = Word8Vector.tabulate(4-rounding, fn _ => 0w0) 450 in 451 Word8Vector.concat(header :: alignment :: compileItems (#items t)) 452 end 453 454 (* CreateDialogIndirect: Create a modeless dialogue using a resource. *) 455 local 456 val sysCreateDialog = 457 winCall5 (user "CreateDialogParamA") (cHINSTANCE, cRESID, cHWND, cFunction, cLPARAM) cHWND 458 in 459 fun CreateDialog (hInst, lpTemplate, hWndParent, dialogueProc, init) = 460 let 461 val _ = Message.setCallback(dlgProcRes o dialogueProc, init); 462 val res = checkWindow 463 (sysCreateDialog(hInst, lpTemplate, hWndParent, Message.mainWinProc, 0)) 464 in 465 (* Add this to the modeless dialogue list so that keyboard 466 operations will work. *) 467 Message.addModelessDialogue(res, NONE); 468 res 469 end 470 end 471 472 (* CreateDialogIndirect: Create a modeless dialogue from a template. *) 473 local 474 val sysCreateDialogIndirect = 475 winCall5 (user "CreateDialogIndirectParamA") (cHINSTANCE, cPointer, cHWND, cFunction, cLPARAM) cHWND 476 in 477 fun CreateDialogIndirect (hInst, template, hWndParent, dialogueProc, init) = 478 let 479 val _ = Message.setCallback(dlgProcRes o dialogueProc, init); 480 (* Compile the template and copy it to C memory. *) 481 val compiled = compileTemplate template 482 val size = Word8Vector.length compiled 483 open Memory 484 val templ = malloc (Word.fromInt size) 485 fun copyToBuf(i, v) = set8(templ, Word.fromInt i, v) 486 val () = Word8Vector.appi copyToBuf compiled 487 val res = checkWindow 488 (sysCreateDialogIndirect(hInst, templ, hWndParent, Message.mainWinProc, 0)) 489 val () = free templ 490 in 491 (* Add this to the modeless dialogue list so that keyboard 492 operations will work. *) 493 Message.addModelessDialogue(res, NONE); 494 res 495 end 496 end 497 498 (* DialogBox: create a dialogue using a resource. *) 499 local 500 val sysDialogBox = 501 winCall5 (user "DialogBoxParamA") (cHINSTANCE, cRESID, cHWND, cFunction, cLPARAM) cINT_PTR 502 in 503 fun DialogBox (hInst, lpTemplate, hWndParent, dialogueProc, init) = 504 let 505 (* We can use the normal window procedure as a dialogue proc. *) 506 val _ = Message.setCallback(dlgProcRes o dialogueProc, init); 507 val result = sysDialogBox(hInst, lpTemplate, hWndParent, Message.mainWinProc, 0) 508 in 509 (* How do we remove the callback? Look for the last message? *) 510 result 511 end 512 end 513 514 (* DialogBoxIndirect: create a dialogue using a template. *) 515 local 516 val sysDialogBoxIndirect = 517 winCall5 (user "DialogBoxIndirectParamA") (cHINSTANCE, cPointer, cHWND, cFunction, cLPARAM) cINT_PTR 518 in 519 fun DialogBoxIndirect (hInst, template, hWndParent, dialogueProc, init) = 520 let 521 val _ = Message.setCallback(dlgProcRes o dialogueProc, init); 522 (* Compile the template and copy it to C memory. *) 523 val compiled = compileTemplate template 524 val size = Word8Vector.length compiled 525 open Memory 526 val templ = malloc (Word.fromInt size) 527 fun copyToBuf(i, v) = set8(templ, Word.fromInt i, v) 528 val _ = Word8Vector.appi copyToBuf compiled 529 in 530 sysDialogBoxIndirect(hInst, templ, hWndParent, Message.mainWinProc, 0) 531 before free templ 532 end 533 end 534 535 (* Get average size of system font. *) 536 local 537 val getDialogBaseUnits = winCall0 (user "GetDialogBaseUnits") () cDWORDw (* Actually LONG *) 538 in 539 fun GetDialogBaseUnits() : {horizontal: int, vertical: int} = 540 let 541 val base = getDialogBaseUnits () 542 in 543 {horizontal = Word.toInt(LOWORD base), vertical = Word.toInt(HIWORD base)} 544 end 545 end 546 547 val GetDlgCtrlID = winCall1 (user "GetDlgCtrlID") cHWND cInt 548 and GetDlgItem = winCall2 (user "GetDlgItem") (cHWND, cInt) cHWND 549 550 val GetDlgItemText = Window.GetWindowText o GetDlgItem 551 552 val IsDialogMessage = winCall2 (user "IsDialogMessage") (cHWND, Message.LPMSG) cBool 553 554 val EndDialog = winCall2 (user "EndDialog") (cHWND, cINT_PTR) (successState "EndDialog") 555 end 556end; 557