diff --git a/mlsource/extra/Win/Base.sml b/mlsource/extra/Win/Base.sml deleted file mode 100644 index 47540350..00000000 --- a/mlsource/extra/Win/Base.sml +++ /dev/null @@ -1,1020 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) -(* This contains various types and other values which are needed in various - modules. All the exported types are contained in other structures. *) -structure Base: -sig - val winCall0: Foreign.symbol -> unit -> 'a Foreign.conversion -> unit -> 'a - val winCall1: Foreign.symbol -> 'a Foreign.conversion -> 'b Foreign.conversion -> 'a -> 'b - val winCall2: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion -> 'c Foreign.conversion -> 'a * 'b -> 'c - val winCall3: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion -> 'd Foreign.conversion -> 'a * 'b * 'c -> 'd - val winCall4: Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion -> 'e Foreign.conversion -> - 'a * 'b * 'c * 'd -> 'e - val winCall5: - Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion -> - 'f Foreign.conversion -> 'a * 'b * 'c * 'd * 'e -> 'f - val winCall6: - Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * - 'f Foreign.conversion -> 'g Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f -> 'g - val winCall7: - Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * - 'f Foreign.conversion * 'g Foreign.conversion -> 'h Foreign.conversion -> - 'a * 'b * 'c * 'd * 'e * 'f * 'g -> 'h - val winCall8: - Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * - 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion -> 'i Foreign.conversion -> - 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h -> 'i - val winCall9: - Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * - 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion -> - 'j Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i -> 'j - val winCall10: - Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * - 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion * 'j Foreign.conversion -> - 'k Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j -> 'k - val winCall11: - Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * - 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion * 'j Foreign.conversion * 'k Foreign.conversion -> - 'l Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k -> 'l - val winCall12: - Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * - 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion * 'j Foreign.conversion * 'k Foreign.conversion * - 'l Foreign.conversion -> 'm Foreign.conversion -> - 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l -> 'm - val winCall13: - Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * - 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion * 'j Foreign.conversion * 'k Foreign.conversion * - 'l Foreign.conversion * 'm Foreign.conversion -> 'n Foreign.conversion -> - 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm -> 'n - val winCall14: - Foreign.symbol -> 'a Foreign.conversion * 'b Foreign.conversion * 'c Foreign.conversion * 'd Foreign.conversion * 'e Foreign.conversion * - 'f Foreign.conversion * 'g Foreign.conversion * 'h Foreign.conversion * 'i Foreign.conversion * 'j Foreign.conversion * 'k Foreign.conversion * - 'l Foreign.conversion * 'm Foreign.conversion * 'n Foreign.conversion -> - 'o Foreign.conversion -> 'a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l * 'm * 'n -> 'o - - val winAbi: Foreign.LowLevel.abi - - val kernel: string -> Foreign.symbol - and user: string -> Foreign.symbol - and commdlg: string -> Foreign.symbol - and gdi: string -> Foreign.symbol - and shell: string -> Foreign.symbol - and comctl: string -> Foreign.symbol - - val cSIZE_T: int Foreign.conversion - and cLPARAM: int Foreign.conversion - and cLONG_PTR: int Foreign.conversion - and cULONG_PTR: int Foreign.conversion - and cINT_PTR: int Foreign.conversion - and cUINT_PTR: int Foreign.conversion - and cDWORD: int Foreign.conversion - and cWORD: int Foreign.conversion - and cDWORD_PTR: int Foreign.conversion - and cUINT_PTRw: SysWord.word Foreign.conversion - - val cUint8w: Word8.word Foreign.conversion - and cUint16w: Word.word Foreign.conversion - and cUint32w: Word32.word Foreign.conversion - and cUintw: Word32.word Foreign.conversion - and cUlongw: Word32.word Foreign.conversion - - val cDWORDw: Word32.word Foreign.conversion - and cWORDw: Word.word Foreign.conversion - - val cBool: bool Foreign.conversion - - val successState: string -> unit Foreign.conversion - val cPOSINT: string -> int Foreign.conversion - - type POINT = { x: int, y: int } - val cPoint: POINT Foreign.conversion - type RECT = { left: int, top: int, right: int, bottom: int } - val cRect: RECT Foreign.conversion - type SIZE = { cx: int, cy: int } - val cSize: SIZE Foreign.conversion - - eqtype 'a HANDLE - val hNull: 'a HANDLE - val isHNull: 'a HANDLE -> bool - val handleOfVoidStar: Foreign.Memory.voidStar -> 'a HANDLE - and voidStarOfHandle: 'a HANDLE -> Foreign.Memory.voidStar - - eqtype HMENU and HDC and HWND and HINSTANCE and HGDIOBJ - and HDROP and HRSRC and HUPDATE - - val cHGDIOBJ: HGDIOBJ Foreign.conversion - and cHDROP: HDROP Foreign.conversion - and cHMENU: HMENU Foreign.conversion - and cHINSTANCE: HINSTANCE Foreign.conversion - and cHDC: HDC Foreign.conversion - and cHWND: HWND Foreign.conversion - val cHMENUOPT: HMENU option Foreign.conversion - and cHGDIOBJOPT: HGDIOBJ option Foreign.conversion - and cHWNDOPT: HWND option Foreign.conversion - and cHRSRC: HRSRC Foreign.conversion - and cHUPDATE: HUPDATE Foreign.conversion - - val hgdiObjNull:HGDIOBJ - and isHgdiObjNull: HGDIOBJ -> bool - and hdcNull: HDC - and isHdcNull: HDC -> bool - and hmenuNull: HMENU - and isHmenuNull: HMENU -> bool - and hinstanceNull: HINSTANCE - and isHinstanceNull: HINSTANCE -> bool - and hwndNull: HWND - - type HPALETTE = HGDIOBJ and HFONT = HGDIOBJ and HPEN = HGDIOBJ - and HBITMAP = HGDIOBJ and HRGN = HGDIOBJ and HBRUSH = HGDIOBJ - and HENHMETAFILE = HGDIOBJ and HMETAFILE = HGDIOBJ - - val cHPALETTE: HPALETTE Foreign.conversion - and cHFONT: HFONT Foreign.conversion - and cHPEN: HPEN Foreign.conversion - and cHBITMAP: HBITMAP Foreign.conversion - and cHRGN: HRGN Foreign.conversion - and cHBRUSH: HBRUSH Foreign.conversion - and cHENHMETAFILE: HENHMETAFILE Foreign.conversion - and cHMETAFILE: HMETAFILE Foreign.conversion - - - type HICON = HGDIOBJ and HCURSOR = HGDIOBJ - val cHICON: HICON Foreign.conversion - and cHCURSOR: HCURSOR Foreign.conversion - - val absConversion: - {abs: 'a -> 'b, rep: 'b -> 'a} -> 'a Foreign.conversion -> 'b Foreign.conversion - - val tableLookup: - (''a * ''b) list * ((''b -> ''a) * (''a -> ''b)) option -> (''a -> ''b) * (''b -> ''a) - and tableSetLookup: - (''a * Word32.word) list * ((Word32.word -> ''a) * (''a -> Word32.word)) option -> - (''a list -> Word32.word) * (Word32.word -> ''a list) - - val tableConversion: - (''a * ''b) list * ((''b -> ''a) * (''a -> ''b)) option -> - ''b Foreign.conversion -> ''a Foreign.conversion - (* tableSetConversion is always a cUint *) - and tableSetConversion: - (''a * Word32.word) list * ((Word32.word -> ''a) * (''a -> Word32.word)) option -> - ''a list Foreign.conversion - - val list2Vector: 'a Foreign.conversion -> 'a list -> Foreign.Memory.voidStar * int - - datatype ClassType = NamedClass of string | ClassAtom of int - val cCLASS: ClassType Foreign.conversion - - datatype ClipboardFormat = - CF_NONE | CF_TEXT | CF_BITMAP | CF_METAFILEPICT | CF_SYLK | CF_DIF | CF_TIFF | - CF_OEMTEXT | CF_DIB | CF_PALETTE | CF_PENDATA | CF_RIFF | CF_WAVE | CF_UNICODETEXT | - CF_ENHMETAFILE | CF_OWNERDISPLAY | CF_DSPTEXT | CF_DSPBITMAP | CF_DSPMETAFILEPICT | - CF_DSPENHMETAFILE | CF_PRIVATE of int | CF_GDIOBJ of int | CF_REGISTERED of int | - CF_HDROP | CF_LOCALE - val clipLookup: (ClipboardFormat -> int) * (int -> ClipboardFormat) - - datatype RESID = IdAsInt of int | IdAsString of string - val cRESID: RESID Foreign.conversion - - val STRINGOPT: string option Foreign.conversion - val cCHARARRAY: int -> string Foreign.conversion - val fromCstring: Foreign.Memory.voidStar -> string - val toCstring: string -> Foreign.Memory.voidStar (* Memory must be freed *) - val copyStringToMem: Foreign.Memory.voidStar * int * string -> unit - val fromCWord8vec: Foreign.Memory.voidStar * int -> Word8Vector.vector - val toCWord8vec: Word8Vector.vector -> Foreign.Memory.voidStar (* Memory must be freed *) - - val getStringCall: (Foreign.Memory.voidStar * int -> int) -> string - val getStringWithNullIsLength: (Foreign.Memory.voidStar * int -> int) -> string - val getVectorResult: - 'a Foreign.conversion -> (Foreign.Memory.voidStar * int -> int) -> int -> 'a vector - - eqtype HGLOBAL - val cHGLOBAL: HGLOBAL Foreign.conversion - val GlobalAlloc: int * int -> HGLOBAL - val GlobalLock: HGLOBAL -> Foreign.Memory.voidStar - val GlobalFree: HGLOBAL -> HGLOBAL - val GlobalSize: HGLOBAL -> int - val GlobalUnlock: HGLOBAL -> bool - - val HIWORD: Word32.word -> Word.word - val LOWORD: Word32.word -> Word.word - val MAKELONG: Word.word * Word.word -> Word32.word - val HIBYTE: Word.word -> Word8.word - val LOBYTE: Word.word -> Word8.word - - val unicodeToString: Word8Vector.vector -> string - val stringToUnicode: string -> Word8Vector.vector - - val GetLastError: unit -> OS.syserror - - val checkResult: bool -> unit - val raiseSysErr: unit -> 'a - - structure FindReplaceFlags: - sig - include BIT_FLAGS - val FR_DIALOGTERM : flags - val FR_DOWN : flags - val FR_FINDNEXT : flags - val FR_HIDEMATCHCASE : flags - val FR_HIDEUPDOWN : flags - val FR_HIDEWHOLEWORD : flags - val FR_MATCHCASE : flags - val FR_NOMATCHCASE : flags - val FR_NOUPDOWN : flags - val FR_NOWHOLEWORD : flags - val FR_REPLACE : flags - val FR_REPLACEALL : flags - val FR_SHOWHELP : flags - val FR_WHOLEWORD : flags - val cFindReplaceFlags: flags Foreign.conversion - end - -end = -struct - open Foreign -(* val System_isShort : vol -> bool = - RunCall.run_call1 RuntimeCalls.POLY_SYS_is_short*) - - fun absConversion {abs: 'a -> 'b, rep: 'b -> 'a} (c: 'a conversion) : 'b conversion = - let - val { load=loadI, store=storeI, ctype } = breakConversion c - fun load m = abs(loadI m) - fun store(m, v) = storeI(m, rep v) - in - makeConversion { load = load, store = store, ctype = ctype } - end - - (* In many cases we can pass a set of options as a bit set. *) - (* - fun bitsetConversion {abs, rep} = - let - val (fromC, toC, Ctype) = breakConversion INT - val fromList = List.foldl (fn(i, n) => IntInf.orb(rep i, n)) 0 - fun toList n = [abs n] (* This is a bit of a mess. *) - in - mkConversion (toList o fromCuint) (toCuint o fromList) Cuint - end*) - - (* Conversions between Word/Word32/LargeWord etc. *) - local - open Memory LowLevel - fun noFree () = () - in - local - fun load(m: voidStar): Word8.word = get8(m, 0w0) - fun store(m: voidStar, i: Word8.word) = (set8(m, 0w0, i); noFree) - in - val cUint8w: Word8.word conversion = - makeConversion{ load=load, store=store, ctype = cTypeUint8 } - end - local - fun load(m: voidStar): Word.word = get16(m, 0w0) - fun store(m: voidStar, i: Word.word) = (set16(m, 0w0, i); noFree) - in - val cUint16w: Word.word conversion = - makeConversion{ load=load, store=store, ctype = cTypeInt16 } - end - local - fun load(m: voidStar): Word32.word = get32(m, 0w0) - fun store(m: voidStar, i: Word32.word) = (set32(m, 0w0, i); noFree) - in - val cUint32w: Word32.word conversion = - makeConversion{ load=load, store=store, ctype = cTypeUint32 } - - end - val cUintw = cUint32w - (* Int should be 32-bits on Windows. *) - val _ = #size LowLevel.cTypeUint = #size LowLevel.cTypeUint32 - orelse raise Fail "unsigned int is not 32-bits" - val cUlongw = cUint32w - val _ = #size LowLevel.cTypeUlong = #size LowLevel.cTypeUint32 - orelse raise Fail "unsigned long is not 32-bits" - end - - val cDWORD = cUint32 (* Defined to be 32-bit unsigned *) - and cWORD = cUint16 (* Defined to be 16-bit unsigned *) - - val cDWORDw = cUint32w - and cWORDw = cUint16w - - (* For some reason Windows has both INT_PTR and LONG_PTR and they - are slightly different. *) - val cLONG_PTR = - if #size LowLevel.cTypePointer = 0w4 - then cLong - else cInt64 - - val cINT_PTR = - if #size LowLevel.cTypePointer = 0w4 - then cInt - else cInt64 - - val cULONG_PTR = - if #size LowLevel.cTypePointer = 0w4 - then cUlong - else cUint64 - - val cUINT_PTR = - if #size LowLevel.cTypePointer = 0w4 - then cUint - else cUint64 - - val cLPARAM = cLONG_PTR - val cSIZE_T = cULONG_PTR (* Probably. *) - val cDWORD_PTR = cULONG_PTR (* Defined to be the same so I'm not sure why it's there .*) - - val cUINT_PTRw = absConversion{abs=Memory.voidStar2Sysword, rep=Memory.sysWord2VoidStar} cPointer - - (* These are called XXX32.DLL on both 32-bit and 64-bit. *) - fun kernel name = getSymbol(loadLibrary "kernel32.dll") name - and user sym = getSymbol(loadLibrary "user32.DLL") sym - and commdlg sym = getSymbol(loadLibrary "comdlg32.DLL") sym - and gdi sym = getSymbol(loadLibrary "gdi32.DLL") sym - and shell sym = getSymbol(loadLibrary "shell32.DLL") sym - and comctl sym = getSymbol(loadLibrary "comctl32.DLL") sym - - (* We need to use the Pascal calling convention on 32-bit Windows. *) - val winAbi = - case List.find (fn ("stdcall", _) => true | _ => false) LowLevel.abiList of - SOME(_, abi) => abi - | NONE => LowLevel.abiDefault - - (* As well as setting the abi we can also use the old argument order. *) - fun winCall0 sym argConv resConv = buildCall0withAbi(winAbi, sym, argConv, resConv) - and winCall1 sym argConv resConv = buildCall1withAbi(winAbi, sym, argConv, resConv) - and winCall2 sym argConv resConv = buildCall2withAbi(winAbi, sym, argConv, resConv) - and winCall3 sym argConv resConv = buildCall3withAbi(winAbi, sym, argConv, resConv) - and winCall4 sym argConv resConv = buildCall4withAbi(winAbi, sym, argConv, resConv) - and winCall5 sym argConv resConv = buildCall5withAbi(winAbi, sym, argConv, resConv) - and winCall6 sym argConv resConv = buildCall6withAbi(winAbi, sym, argConv, resConv) - and winCall7 sym argConv resConv = buildCall7withAbi(winAbi, sym, argConv, resConv) - and winCall8 sym argConv resConv = buildCall8withAbi(winAbi, sym, argConv, resConv) - and winCall9 sym argConv resConv = buildCall9withAbi(winAbi, sym, argConv, resConv) - and winCall10 sym argConv resConv = buildCall10withAbi(winAbi, sym, argConv, resConv) - and winCall11 sym argConv resConv = buildCall11withAbi(winAbi, sym, argConv, resConv) - and winCall12 sym argConv resConv = buildCall12withAbi(winAbi, sym, argConv, resConv) - and winCall13 sym argConv resConv = buildCall13withAbi(winAbi, sym, argConv, resConv) - and winCall14 sym argConv resConv = buildCall14withAbi(winAbi, sym, argConv, resConv) - - (* Previously we had a specific call to do this. The error state is - no longer set by the new FFI. *) -(* - fun GetLastError(): OS.syserror = - RunCall.run_call2 RuntimeCalls.POLY_SYS_os_specific (1100, ()) -*) - local - val getLastError = winCall0 (kernel "GetLastError") () cDWORD - in - fun GetLastError(): OS.syserror = - (* Windows error codes are negative values in OS.syserror. *) - RunCall.unsafeCast (~ (getLastError())) - end - - (* The string argument of the SysErr exception is supposed to match the result of OS.errMsg. *) - fun raiseSysErr () = let val err = GetLastError() in raise OS.SysErr(OS.errorMsg err, SOME err) end - - (* Many system calls return bool. If the result is false we raise an exception. *) - fun checkResult true = () | checkResult false = raiseSysErr () - - val cBool: bool conversion = - absConversion{abs = fn 0 => false | _ => true, rep = fn false => 0 | true => 1} cInt - - fun successState name: unit conversion = - absConversion { abs = checkResult, rep = fn _ => raise Fail ("successState:" ^ name) } cBool - - - type POINT = { x: int, y: int } - - local - fun breakPoint ({x,y}: POINT) = (x,y) - fun mkPoint (x,y): POINT = {x=x, y=y} - in - val cPoint = absConversion {abs=mkPoint, rep=breakPoint} (cStruct2 (cLong, cLong)) - end - - type RECT = { left: int, top: int, right: int, bottom: int } - - local - fun breakRect ({left,top,right,bottom}: RECT) = (left,top,right,bottom) - fun mkRect (left,top,right,bottom): RECT = - {left=left,top=top,right=right,bottom=bottom} - in - val cRect = absConversion {abs=mkRect, rep=breakRect} (cStruct4 (cLong,cLong,cLong,cLong)) - end - - type SIZE = { cx: int, cy: int } - local - fun breakSize ({cx,cy}: SIZE) = (cx,cy) - fun mkSize (cx,cy): SIZE = {cx=cx, cy=cy} - in - val cSize = absConversion {abs=mkSize, rep=breakSize} (cStruct2 (cLong,cLong)) - end - - (* Handles are generally opaque values. We want them to be eqtypes, though. *) - local - structure HandStruct :> - sig - eqtype 'a HANDLE - val hNull: 'a HANDLE - val isHNull: 'a HANDLE -> bool - val handleOfVoidStar: Memory.voidStar -> 'a HANDLE - and voidStarOfHandle: 'a HANDLE -> Memory.voidStar - end = - struct - type 'a HANDLE = Memory.voidStar - val hNull = Memory.null - fun isHNull h = h = hNull - - (* We sometimes need the next two functions internally. - They're needed externally unless we change the result type - of SendMessage to allow us to return a handle for certain - messages. *) - fun handleOfVoidStar h = h - and voidStarOfHandle h = h - end - in - open HandStruct - end - - (* We just need these as placeholders. We never create values of - these types. They are used simply as a way of creating different - handle types. *) - (* Don't use abstype - we want them to eqtypes *) - datatype GdiObj = GdiObj - and Instance = Instance - and Drop = Drop - and DeviceContext = DeviceContext - and Menu = Menu - and Window = Window - and Global = Global - and Src = Src - and Update = Update - - (* HINSTANCE is used as an instance of a module. *) - type HINSTANCE = Instance HANDLE - and HDROP = Drop HANDLE - and HGDIOBJ = GdiObj HANDLE - and HDC = DeviceContext HANDLE - and HMENU = Menu HANDLE - and HWND = Window HANDLE - and HGLOBAL = Global HANDLE - and HRSRC = Src HANDLE - and HUPDATE = Update HANDLE - - local - fun cHANDLE() = - absConversion {abs=handleOfVoidStar, rep=voidStarOfHandle} cPointer - fun hoptOfvs n = - if Memory.voidStar2Sysword n = 0w0 then NONE else SOME(handleOfVoidStar n) - - fun cHANDLEOPT() = - absConversion {abs=hoptOfvs, rep=fn v => voidStarOfHandle(getOpt(v, hNull)) } cPointer - in - val cHGDIOBJ: HGDIOBJ conversion = cHANDLE() - and cHDROP: HDROP conversion = cHANDLE() - and cHMENU: HMENU conversion = cHANDLE() - and cHINSTANCE: HINSTANCE conversion = cHANDLE() - and cHDC: HDC conversion = cHANDLE() - and cHWND: HWND conversion = cHANDLE() - - val cHMENUOPT: HMENU option conversion = cHANDLEOPT() - and cHGDIOBJOPT: HGDIOBJ option conversion = cHANDLEOPT() - and cHWNDOPT: HWND option conversion = cHANDLEOPT() - - val cHGLOBAL: HGLOBAL conversion = cHANDLE() - and cHRSRC: HRSRC conversion = cHANDLE() - and cHUPDATE: HUPDATE conversion = cHANDLE() - end - - (* Temporary declarations. *) - val hgdiObjNull:HGDIOBJ = hNull - and isHgdiObjNull: HGDIOBJ -> bool = isHNull - and hdcNull: HDC = hNull - and isHdcNull: HDC -> bool = isHNull - and hmenuNull: HMENU = hNull - and isHmenuNull: HMENU -> bool = isHNull - and hinstanceNull: HINSTANCE = hNull - and isHinstanceNull: HINSTANCE -> bool = isHNull - and hwndNull: HWND = hNull - - (* All these are various kinds of HGDIOBJ. It's too complicated to try - to use different types for them. *) - type HPALETTE = HGDIOBJ and HFONT = HGDIOBJ and HPEN = HGDIOBJ - and HBITMAP = HGDIOBJ and HRGN = HGDIOBJ and HBRUSH = HGDIOBJ - and HENHMETAFILE = HGDIOBJ and HMETAFILE = HGDIOBJ - - val cHPALETTE: HPALETTE conversion = cHGDIOBJ - and cHFONT: HFONT conversion = cHGDIOBJ - and cHPEN: HPEN conversion = cHGDIOBJ - and cHBITMAP: HBITMAP conversion = cHGDIOBJ - and cHRGN: HRGN conversion = cHGDIOBJ - and cHBRUSH: HBRUSH conversion = cHGDIOBJ - and cHENHMETAFILE: HENHMETAFILE conversion = cHGDIOBJ - and cHMETAFILE: HMETAFILE conversion = cHGDIOBJ - - (* I'm not so happy about treating these as HGDIOBJ but it makes the - types of messages such as BM_SETIMAGE simpler. *) - type HICON = HGDIOBJ and HCURSOR = HGDIOBJ - val cHICON = cHGDIOBJ and cHCURSOR = cHGDIOBJ - - (* The easiest way to deal with datatypes is often by way of a table. *) - fun tableLookup (table: (''a * ''b) list, default) = - let - fun toInt [] x = - (case default of NONE => raise Fail "tableLookup: not found" | SOME (_, d) => d x) - | toInt ((y, i) :: tl) x = if x = y then i else toInt tl x - - fun fromInt [] x = - (case default of - NONE => raise Fail ("tableLookup: not found") - | SOME (d, _) => d x) - | fromInt ((y, i) :: tl) x = if x = i then y else fromInt tl x - in - (toInt table, fromInt table) - end - - fun tableConversion (table: (''a * ''b) list, default) (conv: ''b conversion): ''a conversion = - let - val (toInt, fromInt) = tableLookup(table, default) - in - absConversion {abs = fromInt, rep = toInt} conv - end - - (* In other cases we have sets of options. We represent them by a list. - The order of the elements in the table is significant if we are to be - able to handle multiple bits. Patterns with more than one bit set - MUST be placed later than those with a subset of those bits. *) - fun tableSetLookup (table: (''a * Word32.word) list, default) = - let - open Word32 - (* Conversion to integer - just fold the values. *) - fun toInt' [] x = - (case default of NONE => raise Fail "tableLookup: not found" | SOME (_, d) => d x) - | toInt' ((y, i) :: tl) x = if x = y then i else toInt' tl x - - val toInt = List.foldl (fn (a, b) => orb(toInt' table a, b)) 0w0 - - (* It would speed up the searches if we ordered the list so that multiple - bit entries preceded those with fewer bits but it's much easier to lay - out the tables if we do it this way. *) - fun fromInt _ _ 0w0 = [] (* Zero is an empty list. *) - - | fromInt [] NONE x = (* Not found *) - (case default of - NONE => raise Fail ("tableLookup: not found" ^ Word32.toString x) - | SOME (d, _) => [d x]) - - | fromInt [] (SOME(res, bits)) x = (* Found something - remove it from the set. *) - (res :: fromInt table NONE (andb(x, notb bits))) - - | fromInt ((res, bits)::tl) sofar x = - if bits <> 0w0 andalso andb(x, bits) = bits - then (* Matches *) fromInt tl (SOME(res, bits)) x - else (* Doesn't match *) fromInt tl sofar x - in - (toInt, fromInt table NONE) - end - - fun tableSetConversion (table: (''a * Word32.word) list, default): ''a list conversion = - let - val (toInt, fromInt) = tableSetLookup(table, default) - in - absConversion {abs = fromInt, rep = toInt} cUintw - end - - - structure FindReplaceFlags:> - sig - include BIT_FLAGS - val FR_DIALOGTERM : flags - val FR_DOWN : flags - val FR_FINDNEXT : flags - val FR_HIDEMATCHCASE : flags - val FR_HIDEUPDOWN : flags - val FR_HIDEWHOLEWORD : flags - val FR_MATCHCASE : flags - val FR_NOMATCHCASE : flags - val FR_NOUPDOWN : flags - val FR_NOWHOLEWORD : flags - val FR_REPLACE : flags - val FR_REPLACEALL : flags - val FR_SHOWHELP : flags - val FR_WHOLEWORD : flags - val cFindReplaceFlags: flags conversion - end = - struct - open Word32 - type flags = word - val toWord = toLargeWord - and fromWord = fromLargeWord - val flags = List.foldl (fn (a, b) => orb(a,b)) 0w0 - fun allSet (fl1, fl2) = andb(fl1, fl2) = fl1 - fun anySet (fl1, fl2) = andb(fl1, fl2) <> 0w0 - fun clear (fl1, fl2) = andb(notb fl1, fl2) - - val FR_DOWN = 0wx00000001 - val FR_WHOLEWORD = 0wx00000002 - val FR_MATCHCASE = 0wx00000004 - val FR_FINDNEXT = 0wx00000008 - val FR_REPLACE = 0wx00000010 - val FR_REPLACEALL = 0wx00000020 - val FR_DIALOGTERM = 0wx00000040 - val FR_SHOWHELP = 0wx00000080 - val FR_NOUPDOWN = 0wx00000400 - val FR_NOMATCHCASE = 0wx00000800 - val FR_NOWHOLEWORD = 0wx00001000 - val FR_HIDEUPDOWN = 0wx00004000 - val FR_HIDEMATCHCASE = 0wx00008000 - val FR_HIDEWHOLEWORD = 0wx00010000 - - val all = flags[FR_DOWN, FR_WHOLEWORD, FR_MATCHCASE, FR_FINDNEXT, FR_REPLACE, - FR_REPLACEALL, FR_DIALOGTERM, FR_NOUPDOWN, FR_NOMATCHCASE, - FR_NOWHOLEWORD, FR_HIDEUPDOWN, FR_HIDEMATCHCASE, FR_HIDEWHOLEWORD] - - val intersect = List.foldl (fn (a, b) => andb(a,b)) all - - val cFindReplaceFlags = cDWORDw - end - - (* The class "string" may be a name or an atom. *) - datatype ClassType = NamedClass of string | ClassAtom of int - - local - open Memory - val {store=storeS, load=loadS, ctype} = breakConversion cString - - fun storeClass(m, ClassAtom i) = - if i >= 0 andalso i < 0xC000 - then (setAddress(m, 0w0, sysWord2VoidStar(SysWord.fromInt i)); fn () => ()) - else raise Fail "atom out of range" - | storeClass(m, NamedClass s) = storeS(m, s) - - fun loadClass m = - let - val v = getAddress(m, 0w0) - in - if voidStar2Sysword v < 0wxC000 - then ClassAtom(SysWord.toInt(voidStar2Sysword v)) - else NamedClass(loadS m) - end - - in - val cCLASS = makeConversion { load = loadClass, store = storeClass, ctype = ctype } - end - - (* Clipboard formats. I've added CF_NONE, CF_PRIVATE, CF_GDIOBJ and CF_REGISTERED. - This is here because it is used in both Clipboard and Message (WM_RENDERFORMAT) *) - datatype ClipboardFormat = - CF_NONE | CF_TEXT | CF_BITMAP | CF_METAFILEPICT | CF_SYLK | CF_DIF | CF_TIFF | - CF_OEMTEXT | CF_DIB | CF_PALETTE | CF_PENDATA | CF_RIFF | CF_WAVE | CF_UNICODETEXT | - CF_ENHMETAFILE | CF_OWNERDISPLAY | CF_DSPTEXT | CF_DSPBITMAP | CF_DSPMETAFILEPICT | - CF_DSPENHMETAFILE | CF_PRIVATE of int | CF_GDIOBJ of int | CF_REGISTERED of int | - CF_HDROP | CF_LOCALE - - local - val tab = [ - (CF_NONE, 0), - (CF_TEXT, 1), - (CF_BITMAP, 2), - (CF_METAFILEPICT, 3), - (CF_SYLK, 4), - (CF_DIF, 5), - (CF_TIFF, 6), - (CF_OEMTEXT, 7), - (CF_DIB, 8), - (CF_PALETTE, 9), - (CF_PENDATA, 10), - (CF_RIFF, 11), - (CF_WAVE, 12), - (CF_UNICODETEXT, 13), - (CF_ENHMETAFILE, 14), - (CF_HDROP, 15), - (CF_LOCALE, 16), - (CF_OWNERDISPLAY, 0x0080), - (CF_DSPTEXT, 0x0081), - (CF_DSPBITMAP, 0x0082), - (CF_DSPMETAFILEPICT, 0x0083), - (CF_DSPENHMETAFILE, 0x008E) - ] - fun toInt (CF_PRIVATE i) = - if i >= 0 andalso i < 0xff then 0x0200 + i else raise Size - | toInt (CF_GDIOBJ i) = - if i >= 0 andalso i < 0xff then 0x0300 + i else raise Size - | toInt (CF_REGISTERED i) = i - | toInt _ = raise Match - - fun fromInt i = - if i >= 0x0200 andalso i <= 0x02ff then CF_PRIVATE(i-0x0200) - else if i >= 0x0300 andalso i <= 0x03ff then CF_GDIOBJ(i-0x0300) - else if i >= 0xC000 andalso i < 0xFFFF then CF_REGISTERED i - else raise Match - in - val clipLookup = tableLookup (tab, SOME(fromInt, toInt)) - end - - (* Resources may be specified by strings or by ints. *) - datatype RESID = IdAsInt of int | IdAsString of string - - local - open Memory - val {store=storeS, load=loadS, ctype} = breakConversion cString - - fun storeResid(m, IdAsInt i) = - if i >= 0 andalso i < 65536 - then (setAddress(m, 0w0, sysWord2VoidStar(SysWord.fromInt i)); fn () => ()) - else raise Fail "resource id out of range" - | storeResid(m, IdAsString s) = storeS(m, s) - - fun loadResid m = - let - val v = getAddress(m, 0w0) - in - if voidStar2Sysword v < 0w65536 - then IdAsInt(SysWord.toInt(voidStar2Sysword v)) - else IdAsString(loadS m) - end - in - val cRESID = - makeConversion { load = loadResid, store = storeResid, ctype = ctype } - end - - (*datatype HelpContext = - HelpInfo_MenuItem of - | HelpInfo_Window of - - type HELPINFO = { - }*) - - - (* Useful conversions. *) - (* Various functions return zero if error. This conversion checks for that. *) - fun cPOSINT _ = - absConversion {abs = fn 0 => raiseSysErr() | n => n, rep = fn i => i} cInt - - (* Conversion between string option and C strings. NONE is converted to NULL. *) - val STRINGOPT = cOptionPtr cString - - (* Convert a C string to ML. *) - fun fromCstring buff = - let - open Memory - (* We can't use #load cString because the argument is the address of - the address of the string. *) - fun sLen i = if get8(buff, i) = 0w0 then i else sLen(i+0w1) - val length = sLen 0w0 - fun loadChar i = - Char.chr(Word8.toInt(get8(buff, Word.fromInt i))) - in - CharVector.tabulate(Word.toInt length, loadChar) - end - - (* Copy a string to a particular offset in a buffer and - add a null terminator. *) - fun copyStringToMem (buf, n, s) = - let - open Memory - infix 6 ++ - fun copyToBuf (i, v) = set8(buf, Word.fromInt(i+n), Byte.charToByte v) - in - CharVector.appi copyToBuf s; - set8(buf, Word.fromInt(n + size s), 0w0) - end - - fun toCstring s = - let - open Memory - val sLen = Word.fromInt(String.size s) - val sMem = malloc(sLen + 0w1) - val () = copyStringToMem(sMem, 0, s) - in - sMem - end - - (* When getting a string it is often the case that passing NULL returns the - length required. Then a second call will actually retrieve the string. *) - fun getStringWithNullIsLength(f: Memory.voidStar*int -> int): string = - let - open Memory - val realLength = f(null, 0) - val buff = malloc (Word.fromInt(realLength+1)) - val _ = f(buff, realLength) handle ex => (free buff; raise ex) - in - fromCstring buff before free buff - end - - (* In several cases when extracting a string it is not possible in advance - to know how big to make the buffer. This function loops until all the - string has been extracted. *) - (* This is at least needed for GetClassName *) - fun getStringCall(f: Memory.voidStar*int -> int): string = - let - open Memory - - fun doCall initialSize = - let - (* Allocate a buffer to receive the result. For safety we make it - one character longer than we actually say because it's not always - clear whether the length we pass is the size including the NULL. - Equally we are only certain we have read the whole string if - the return value is less than initialSize-1 because the return - value could be the number of real characters copied to the buffer. *) - val buff = malloc (Word.fromInt(initialSize+1)) - val resultSize = - f(buff, initialSize) handle ex => (free buff; raise ex) - in - if resultSize < initialSize-1 - then (* We've got it all. *) - fromCstring buff before free buff - else ( free buff; doCall(initialSize + initialSize div 2) ) - end - in - doCall (*1024*) 3 (* Use a small size initially for testing. *) - end - - (* We have a number of calls that extract a vector of results. They - are called with an initial size, set the vector to the results and - return a count of the number actually assigned. *) - fun getVectorResult(element: 'a conversion) = - let - val { load=loadElem, ctype={size=sizeElem, ...}, ...} = breakConversion element - fun run f initialCount = - let - open Memory - infix 6 ++ -- - val vec = malloc(Word.fromInt initialCount * sizeElem) - fun getElement i = loadElem(vec ++ Word.fromInt i * sizeElem) - val resultCount = - f (vec, initialCount) handle ex => (free vec; raise ex) - in - Vector.tabulate(resultCount, getElement) before free vec - end - in - run - end - - (* Some C functions take a vector of values to allow a variable number of - elements to be passed. We use a list for this in ML. *) - (* TODO: This discards the result of any store function so if we - store strings we'll leak store. *) - fun list2Vector (conv: 'a conversion) (l:'a list): Memory.voidStar * int = - let - val count = List.length l - val {store=storea, ctype={size=sizea, ...}, ...} = breakConversion conv - open Memory - infix 6 ++ - val vec = malloc(Word.fromInt count * sizea) - fun setItem(item, v) = (ignore(storea(v, item)); v ++ sizea) - val _ = List.foldl setItem vec l - in - (vec, count) - end - - val GlobalAlloc = winCall2 (kernel "GlobalAlloc") (cInt, cSIZE_T) cHGLOBAL - val GlobalLock = winCall1 (kernel "GlobalLock") (cHGLOBAL) cPointer - val GlobalFree = winCall1 (kernel "GlobalFree") (cHGLOBAL) cHGLOBAL - val GlobalSize = winCall1 (kernel "GlobalSize") (cHGLOBAL) cSIZE_T - val GlobalUnlock = winCall1 (kernel "GlobalUnlock") (cHGLOBAL) cBool - - (* Conversion for Word8Vector. We can't do this as a general conversion because - we can't find out how big the C vector is. *) - fun fromCWord8vec (buff, length) = - Word8Vector.tabulate(length, fn i => Memory.get8(buff, Word.fromInt i)) - - fun toCWord8vec(s: Word8Vector.vector): Memory.voidStar = - let - open Memory Word8Vector - val sLen = Word.fromInt(length s) - val sMem = malloc sLen - val () = appi(fn(i, b) => set8(sMem, Word.fromInt i, b)) s - in - sMem - end - -(* - (* Conversion for a fixed size byte array. *) - fun BYTEARRAY n = - let - val base = Cstruct (List.tabulate (n, fn _ => Cchar)) - fun from v = toWord8vec(address v, n) - fun to w = - if Word8Vector.length w <> n then raise Size else deref(fromWord8vec w) - in - mkConversion from to base - end *) - - (* Conversion for a fixed size char array. *) - fun cCHARARRAY n : string conversion = - let - (* Make it a struct of chars *) - val { size=sizeC, align=alignC, ... } = LowLevel.cTypeChar - val arraySize = sizeC * Word.fromInt n - val arrayType: LowLevel.cType = - { size = arraySize, align = alignC, - typeForm = LowLevel.CTypeStruct(List.tabulate (n, fn _ => LowLevel.cTypeChar)) } - - open Memory - - fun load(v: voidStar): string = - let - (* It should be null-terminated but just in case... *) - fun sLen i = if i = Word.fromInt n orelse get8(v, i) = 0w0 then i else sLen(i+0w1) - val length = sLen 0w0 - fun loadChar i = - Char.chr(Word8.toInt(get8(v, Word.fromInt i))) - in - CharVector.tabulate(Word.toInt length, loadChar) - end - - fun store(v: voidStar, s: string) = - let - (* The length must be less than the size to allow for the null *) - val sLen = size s - val _ = sLen < n orelse raise Fail "string too long" - in - CharVector.appi(fn(i, ch) => set8(v, Word.fromInt i, Word8.fromInt(Char.ord ch))) s; - set8(v, Word.fromInt sLen, 0w0); - fn () => () - end - in - makeConversion { load = load, store = store, ctype = arrayType } - end - - (* These should always be UNSIGNED values. *) - local - open Word32 - infix << >> orb andb - val w32ToW = Word.fromLargeWord o Word32.toLargeWord - and wTow32 = Word32.fromLargeWord o Word.toLargeWord - in - fun LOWORD(l) = w32ToW(l andb 0wxFFFF) - fun HIWORD(l) = w32ToW((l >> 0w16) andb 0wxFFFF) - - fun MAKELONG(a, b) = (wTow32 b << 0w16) orb (wTow32 a andb 0wxFFFF) - end - - local - open Word - infix << >> orb andb - val wToW8 = Word8.fromLargeWord o Word.toLargeWord - in - fun HIBYTE(w) = wToW8((w >> 0w8) andb 0wxFF) - fun LOBYTE(w) = wToW8(w andb 0wxFF) - end - - (* Convert between strings and vectors containing Unicode characters. - N.B. These are not null terminated. *) - local - val CP_ACP = 0 (* Default *) - val WideCharToMultiByte = winCall8 (kernel "WideCharToMultiByte") - (cUint, cDWORD, cByteArray, cInt, cPointer, cInt, cPointer, cPointer) cInt - val MultiByteToWideChar = - winCall6 (kernel "MultiByteToWideChar") (cUint, cDWORD, cString, cInt, cPointer, cInt) cInt - in - fun unicodeToString(w: Word8Vector.vector): string = - let - open Memory - val inputLength = Word8Vector.length w div 2 (* Number of unicode chars *) - val outputLength = - WideCharToMultiByte(CP_ACP, 0, w, inputLength, null, 0, null, null) - val outputBuf = malloc(Word.fromInt outputLength) - - val conv = WideCharToMultiByte(CP_ACP, 0, w, inputLength, outputBuf, outputLength, null, null) - - fun loadChar i = - Char.chr(Word8.toInt(get8(outputBuf, Word.fromInt i))) - in - (* We can't use fromCstring here because it's not necessarily null terminated. *) - CharVector.tabulate(conv, loadChar) before free outputBuf - end - - fun stringToUnicode(s: string): Word8Vector.vector = - let - open Memory - val inputLength = size s (* This does not include a terminating NULL *) - (* The lengths returned by MultiByteToWideChar are the number of Unicode chars *) - val outputLength = MultiByteToWideChar(CP_ACP, 0, s, inputLength, null, 0) - val outputBuf = malloc(Word.fromInt outputLength * 0w2) - val conv = MultiByteToWideChar(CP_ACP, 0, s, inputLength, outputBuf, outputLength) - fun loadByte i = get8(outputBuf, Word.fromInt i) - in - Word8Vector.tabulate(conv*2, loadByte) before free outputBuf - end - end - -end; diff --git a/mlsource/extra/Win/Bitmap.sml b/mlsource/extra/Win/Bitmap.sml deleted file mode 100644 index 4d3451f4..00000000 --- a/mlsource/extra/Win/Bitmap.sml +++ /dev/null @@ -1,434 +0,0 @@ -(* - Copyright (c) 2001-7, 2015, 2019 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Bitmap: - sig - type HBITMAP and HDC - type COLORREF = Color.COLORREF - type RECT = { top: int, left: int, bottom: int, right: int } - type SIZE = { cx: int, cy: int } - datatype BitmapCompression = BI_BITFIELDS | BI_RGB | BI_RLE4 | BI_RLE8 - datatype FloodFillMode = FLOODFILLBORDER | FLOODFILLSURFACE - - type BITMAP = - { width: int, height: int, widthBytes: int, planes: int, bitsPerPixel: int, - bits: Word8Vector.vector option } - - type StretchMode - val BLACKONWHITE : StretchMode - val COLORONCOLOR : StretchMode - val HALFTONE : StretchMode - val MAXSTRETCHBLTMODE : StretchMode - val WHITEONBLACK : StretchMode - - type RasterOpCode - val BLACKNESS : RasterOpCode - val DSTINVERT : RasterOpCode - val MERGECOPY : RasterOpCode - val MERGEPAINT : RasterOpCode - val NOTSRCCOPY : RasterOpCode - val NOTSRCERASE : RasterOpCode - val PATCOPY : RasterOpCode - val PATINVERT : RasterOpCode - val PATPAINT : RasterOpCode - val SRCAND : RasterOpCode - val SRCCOPY : RasterOpCode - val SRCERASE : RasterOpCode - val SRCINVERT : RasterOpCode - val SRCPAINT : RasterOpCode - val WHITENESS : RasterOpCode - - val BitBlt : HDC * int * int * int * int * HDC * int * int * RasterOpCode -> unit - val CreateBitmap : - {bits: Word8Vector.vector option, width: int, height: int, - planes: int, bitsPerPixel: int} -> HBITMAP - val CreateBitmapIndirect : BITMAP -> HBITMAP - val CreateCompatibleBitmap : HDC * int * int -> HBITMAP - val ExtFloodFill : HDC * int * int * COLORREF * FloodFillMode -> unit - val GetBitmapBits : HBITMAP * int -> Word8Vector.vector - val GetBitmapDimensionEx : HBITMAP -> SIZE - val GetPixel : HDC * int * int -> COLORREF - val GetStretchBltMode : HDC -> StretchMode - - type QuaternaryRop - val MAKEROP4 : {back: RasterOpCode, fore: RasterOpCode} -> QuaternaryRop - val MaskBlt : - HDC * int * int * int * int * HDC * int * int * - HBITMAP * int * int * QuaternaryRop -> unit - - (*val PlgBlt : HDC * RECT * HDC * RECT * HBITMAP * int * int -> unit*) - val SetBitmapBits : HBITMAP * Word8Vector.vector -> unit - val SetBitmapDimensionEx : HBITMAP * int * int * SIZE -> SIZE - val SetPixel : HDC * int * int * COLORREF -> COLORREF - val SetStretchBltMode : HDC * StretchMode -> unit - val StretchBlt : - HDC * int * int * int * int * HDC * int * int * int * int * RasterOpCode -> unit - - type BITMAPINFOHEADER = - { - width: int, height: int, planes: int, bitsPerPixel: int, - compression: BitmapCompression, sizeImage: int, xPelsPerM: int, - yPelsPerM: int, clrUsed: int, clrImportant: int - } - (* ML extension to extract the information from a DIB. *) - val getBitmapInfoHdr: Word8Vector.vector -> BITMAPINFOHEADER - val GetDIBits: HDC * HBITMAP * int * int * BITMAPINFOHEADER option -> Word8Vector.vector - val SetDIBits: HDC * HBITMAP * int * int * Word8Vector.vector -> unit - - end = -struct - local - open Foreign Base - - fun checkBitmap c = (checkResult(not(isHgdiObjNull c)); c) - in - type HDC = HDC and HBITMAP = HBITMAP - type COLORREF = Color.COLORREF - type SIZE = SIZE and RECT = RECT - - open GdiBase - - local - datatype StretchMode = - W of int - in - type StretchMode = StretchMode - val STRETCHMODE = absConversion {abs = W, rep = fn W n => n} cInt - - val BLACKONWHITE = W (1) - val WHITEONBLACK = W (2) - val COLORONCOLOR = W (3) - val HALFTONE = W (4) - val MAXSTRETCHBLTMODE = W (4) - end - - (*TYPE: FloodFillMode *) - datatype FloodFillMode = FLOODFILLBORDER | FLOODFILLSURFACE - local - val tab = [ - (FLOODFILLBORDER, 0), - (FLOODFILLSURFACE, 1) - ] - - in - val FLOODFILLMODE = tableConversion(tab, NONE) cUint - end - - val ExtFloodFill = - winCall5 (gdi "ExtFloodFill") - (cHDC,cInt,cInt,cCOLORREF,FLOODFILLMODE) (successState "ExtFloodFill") - - val GetPixel = winCall3 (gdi "GetPixel") (cHDC,cInt,cInt) cCOLORREF - val SetPixel = winCall4 (gdi "SetPixel") (cHDC,cInt,cInt, cCOLORREF) cCOLORREF - val BitBlt = winCall9 (gdi "BitBlt") (cHDC,cInt,cInt,cInt,cInt,cHDC,cInt,cInt,cRASTEROPCODE) - (successState "BitBlt") - - - val CreateCompatibleBitmap = - checkBitmap o - winCall3 (gdi "CreateCompatibleBitmap") (cHDC,cInt,cInt) cHBITMAP - - - val GetStretchBltMode = winCall1 (gdi "GetStretchBltMode") (cHDC) STRETCHMODE - - (* TODO: The raster op is supposed to be a combined operation for the foreground and - background. *) - val MaskBlt = winCall12(gdi "MaskBlt") (cHDC,cInt,cInt,cInt,cInt,cHDC,cInt,cInt,cHBITMAP,cInt, - cInt,cQUATERNARY) (successState "MaskBlt") - - val SetStretchBltMode = winCall2(gdi "SetStretchBltMode") (cHDC,STRETCHMODE) (successState "SetStretchBltMode") - - val StretchBlt = - winCall11(gdi "StretchBlt") - (cHDC,cInt,cInt,cInt,cInt,cHDC,cInt,cInt,cInt,cInt,cRASTEROPCODE) (successState "StretchBlt") - - (* This definitely has the wrong type. *) - (*val PlgBlt = winCall7 (gdi "PlgBlt")(cHDC,RECT,cHDC,RECT,HBITMAP,XCOORD,YCOORD) - (successState "PlgBlt")*) - - - local - val setBitmapDimensionEx = - winCall4 (gdi "SetBitmapDimensionEx") (cHBITMAP, cInt, cInt, cStar cSize) (successState "SetBitmapDimensionEx") - in - fun SetBitmapDimensionEx(hbm, width, height, s) = - let - val r = ref s - in - setBitmapDimensionEx(hbm, width, height, r); - !r - end - end - local - val getBitmapDimensionEx = - winCall2 (gdi "GetBitmapDimensionEx") (cHBITMAP, cStar cSize) (successState "SetBitmapDimensionEx") - in - fun GetBitmapDimensionEx hbm = - let - val r = ref {cx=0, cy=0} - in - getBitmapDimensionEx(hbm, r); - !r - end - end - - val CreateBitmapIndirect = - checkBitmap o - winCall1 (gdi "CreateBitmapIndirect") (cConstStar cBITMAP) cHBITMAP - - local - val cbm = checkBitmap o - winCall5 (gdi "CreateBitmap") (cInt, cInt, cInt, cInt, cPointer) cHBITMAP - in - fun CreateBitmap{width, height, planes, bitsPerPixel, bits} = - let - val vec = case bits of NONE => Memory.null | SOME v => toCWord8vec v - val res = - cbm(width, height, planes, bitsPerPixel, vec) - handle ex => (Memory.free vec; raise ex) - in - Memory.free vec; - checkBitmap res - end - end -(* - local - (* RGBQUAD values are four bytes of blue, green, red and a reserved byte. *) - val RGBQUAD = cStruct4(cUint8, cUint8, cUint8, cUint8) - fun from v = - let val (b, g, r, _) = v in {red = r, blue = b, green = g} end - fun to {red, green, blue} = (blue, green, red, 0) - in - val RGBQUAD = absConversion {rep=to, abs=from} RGBQUAD - end*) - - (*TYPE: BitmapCompression *) - datatype BitmapCompression = BI_RGB | BI_RLE8 | BI_RLE4 | BI_BITFIELDS - - local - val tab = [ - (BI_RGB, 0), - (BI_RLE8, 1), - (BI_RLE4, 2), - (BI_BITFIELDS, 3) - ] - in - val (fromComp, toComp) = tableLookup(tab, NONE) - val BITCOMPRESSION = absConversion {abs = toComp, rep = fromComp} cDWORD - end - - type BITMAPINFOHEADER = - { - width: int, height: int, planes: int, bitsPerPixel: int, - compression: BitmapCompression, sizeImage: int, xPelsPerM: int, - yPelsPerM: int, clrUsed: int, clrImportant: int - } - - (* Device-independent bitmaps are intended to be used for storing and - transferring bitmaps. I've written this code to simplify the process - of packing and unpacking them. In particular it takes care of the - calculating the header size which is generally a bit of a pain. DCJM. *) - fun getBitmapInfoHdr(w: Word8Vector.vector): BITMAPINFOHEADER = - let - val size = LargeWord.toInt(PackWord32Little.subVec(w, 0)) - (* Check that the size of the structure given by the - first word is less than the overall size. There are - various extended versions of the BITMAPINFOHEADER structure - but we only look at the fields in the basic one. *) - val _ = - if size > Word8Vector.length w - then raise Fail "Bitmap length field is wrong" - else () - val width = LargeWord.toIntX(PackWord32Little.subVecX(w, 1)) - val height = LargeWord.toIntX(PackWord32Little.subVecX(w, 2)) - val planes = LargeWord.toIntX(PackWord16Little.subVecX(w, 6)) - val bitsPerPixel = LargeWord.toIntX(PackWord16Little.subVecX(w, 7)) - val compression = toComp(LargeWord.toIntX(PackWord32Little.subVecX(w, 4))) - val sizeImage = LargeWord.toIntX(PackWord32Little.subVecX(w, 5)) - val xPelsPerM = LargeWord.toIntX(PackWord32Little.subVecX(w, 6)) - val yPelsPerM = LargeWord.toIntX(PackWord32Little.subVecX(w, 7)) - val clrUsed = LargeWord.toIntX(PackWord32Little.subVecX(w, 8)) - val clrImportant = LargeWord.toIntX(PackWord32Little.subVecX(w, 9)) - in - { width = width, height = height, bitsPerPixel = bitsPerPixel, - planes = planes, compression = compression, sizeImage = sizeImage, - xPelsPerM = xPelsPerM, yPelsPerM = yPelsPerM, clrUsed = clrUsed, - clrImportant = clrImportant } - end - - local - val DIB_RGB_COLORS = 0 - (*val DIB_PAL_COLORS = 1*) - - val BITMAPINFOHEADER = cStruct11(cDWORD, cLong, cLong, cWORD, cWORD, BITCOMPRESSION, - cDWORD, cLong, cLong, cDWORD, cDWORD) - val {load=fromR, store=toR, ctype={size=rtypeSize, ...}} = - breakConversion BITMAPINFOHEADER - - val getDIBits = winCall7 (gdi "GetDIBits") - (cHDC, cHBITMAP, cUint, cUint, cPointer, cPointer, cUint) cInt - - val setDIBits = winCall7 (gdi "SetDIBits") - (cHDC, cHBITMAP, cUint, cUint, cPointer, cPointer, cUint) cInt - - val sizeColourEntry = #size LowLevel.cTypeInt (* Should this RGBQUAD? *) - - in - (* This is all a bit messy. GetDIBits can be used in a number of ways - to get all or part of the information. Passing NULL for the "bits" - argument and setting bitsPerPixel to zero in the BITMAPINFO argument - simply fills in the BITMAPINFOHEADER. With bitsPerPixel non-zero it - builds a colour table on the end of the BITMAPINFO. With "bits" - non-NULL it builds the colour table and creates the bitmap. - - If NONE is given as the header it returns a vector containing - only the header, allowing getBitmapInfoHdr to be used to unpack it. - Otherwise it uses the information in the supplied header to - get the bitmap. It ignores the passed in sizeImage because that - may be wrong. *) - fun GetDIBits(hdc: HDC, hb: HBITMAP, startScan, scanLines, NONE) = - let - (* Allocate a vector for the result and set the length field - and bitsPerPixel. The others don't matter. *) - open Memory - val v = malloc rtypeSize - val _ = toR(v, (Word.toInt rtypeSize, 0, 0, 0, 0, BI_RGB, 0, 0, 0, 0, 0)) - val res = - getDIBits(hdc, hb, startScan, scanLines, Memory.null, v, DIB_RGB_COLORS) - handle ex => (free v; raise ex) - in - checkResult(res <> 0) handle ex => (free v; raise ex); - fromCWord8vec(v, Word.toInt rtypeSize) before free v - end - - | GetDIBits(hdc: HDC, hb: HBITMAP, startScan, scanLines, - SOME {width, height, planes, bitsPerPixel, compression, sizeImage, - xPelsPerM, yPelsPerM, clrUsed, clrImportant}) = - let - (* The passed in value for sizeImage may be wrong. Call - GetDIBits to find the correct value. *) - open Memory - infix 6 ++ - local - (* This call will build a colour map so we have to have enough - space for it. The biggest possible is with 8 bits. *) - val w = malloc (rtypeSize + 0w256 * sizeColourEntry) - val _ = toR(w, (Word.toInt rtypeSize, width, height, planes, bitsPerPixel, - compression, sizeImage, xPelsPerM, yPelsPerM, clrUsed, - clrImportant)) - val _ = - checkResult(getDIBits(hdc, hb, startScan, scanLines, null, w, DIB_RGB_COLORS) <> 0) - handle ex => (free w; raise ex) - in - val (_, _, _, _, _, _, sizeImage, _, _, _, _) = fromR w - val () = free w - end - - (* Calculate the size of the palette. *) - val numColours = - if clrUsed <> 0 - then clrUsed - else if bitsPerPixel < 16 - then Word.toInt(Word.<<(0w1, Word.fromInt bitsPerPixel)) - else if compression = BI_BITFIELDS - then 3 (* These are DWORD colour masks not RGBQUADS. *) - else 0 (* No colour table. *) - val bitOffset = rtypeSize + Word.fromInt numColours * sizeColourEntry - val size = bitOffset + Word.fromInt sizeImage - val w = malloc size - val _ = toR(w, (Word.toInt rtypeSize, width, height, planes, bitsPerPixel, - compression, sizeImage, xPelsPerM, yPelsPerM, clrUsed, - clrImportant)) - val _ = - checkResult(getDIBits(hdc, hb, startScan, scanLines, w ++ bitOffset, w, DIB_RGB_COLORS) <> 0) - handle ex => (free w; raise ex) - in - fromCWord8vec (w, Word.toInt size) before free w - end - - - fun SetDIBits(hdc, hb, startScan, scanLines, w) = - let - open Memory - infix 6 ++ - val v = toCWord8vec w - (*val v = toCbytes w*) - (* We need to work out the offset of the bits. For this we need - the size of the header structure (which may not be a - BITMAPINFOHEADER but some other version of it), the number of - colours and the compression. *) - val hdrSize = #1 (fromR v) - val { clrUsed, compression, bitsPerPixel, ...} = getBitmapInfoHdr w - val numColours = - if clrUsed <> 0 - then clrUsed - else if bitsPerPixel < 16 - then Word.toInt(Word.<<(0w1, Word.fromInt bitsPerPixel)) - else if compression = BI_BITFIELDS - then 3 (* These are DWORD colour masks not RGBQUADS. *) - else 0 (* No colour table. *) - val bitOffset = Word.fromInt hdrSize +Word.fromInt numColours * sizeColourEntry - val res = setDIBits(hdc, hb, startScan, scanLines, - v ++ bitOffset, v, DIB_RGB_COLORS) - in - checkResult(res <> 0) - end - end - - (* GetBitmapBits and SetBitmapBits are supposedly obsolete but they're useful - for copying device-dependent bitmaps. *) - fun GetBitmapBits(hbm, bytes): Word8Vector.vector = - let - val gbb = winCall3 (gdi "GetBitmapBits") (cHBITMAP, cDWORD, cPointer) cLong - open Memory - val buff = malloc (Word.fromInt bytes) - val () = - checkResult(gbb(hbm, bytes, buff) > 0) - handle ex => (free buff; raise ex) - in - fromCWord8vec (buff, bytes) before free buff - end - - fun SetBitmapBits(hbm, w) = - let - val sbb = winCall3 (gdi "SetBitmapBits") (cHBITMAP, cDWORD, cPointer) cLong - val buff = toCWord8vec w - open Memory - val () = - checkResult(sbb(hbm, Word8Vector.length w, buff) > 0) - handle ex => (free buff; raise ex) - in - free buff - end - - (* - Other Bitmap functions: - AlphaBlend - CreateDIBitmap - CreateDIBSection - This creates an area of memory to write to - won't work in ML. - GetDIBColorTable - GradientFill - SetDIBColorTable - SetDIBitsToDevice - SetPixelV - StretchDIBits - TransparentBlt - *) - - end -end; diff --git a/mlsource/extra/Win/Brush.sml b/mlsource/extra/Win/Brush.sml deleted file mode 100644 index 7d2b199d..00000000 --- a/mlsource/extra/Win/Brush.sml +++ /dev/null @@ -1,197 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Brush: - sig - type HBITMAP and HBRUSH and HDC - - datatype - HatchStyle = - HS_BDIAGONAL - | HS_CROSS - | HS_DIAGCROSS - | HS_FDIAGONAL - | HS_HORIZONTAL - | HS_VERTICAL - - datatype - BrushStyle = - BS_HATCHED of HatchStyle - | BS_HOLLOW - | BS_PATTERN of HBITMAP - | BS_SOLID - - type COLORREF = Color.COLORREF - - type LOGBRUSH = BrushStyle * COLORREF - type POINT = {x: int, y: int} - type RasterOpCode = Bitmap.RasterOpCode - - datatype ColorType = - COLOR_SCROLLBAR - | COLOR_BACKGROUND - | COLOR_ACTIVECAPTION - | COLOR_INACTIVECAPTION - | COLOR_MENU - | COLOR_WINDOW - | COLOR_WINDOWFRAME - | COLOR_MENUTEXT - | COLOR_WINDOWTEXT - | COLOR_CAPTIONTEXT - | COLOR_ACTIVEBORDER - | COLOR_INACTIVEBORDER - | COLOR_APPWORKSPACE - | COLOR_HIGHLIGHT - | COLOR_HIGHLIGHTTEXT - | COLOR_BTNFACE - | COLOR_BTNSHADOW - | COLOR_GRAYTEXT - | COLOR_BTNTEXT - | COLOR_INACTIVECAPTIONTEXT - | COLOR_BTNHIGHLIGHT - | COLOR_3DDKSHADOW - | COLOR_3DLIGHT - | COLOR_INFOTEXT - | COLOR_INFOBK - - val CreateBrushIndirect : LOGBRUSH -> HBRUSH - val CreateHatchBrush : HatchStyle * COLORREF -> HBRUSH - val CreatePatternBrush : HBITMAP -> HBRUSH - val CreateSolidBrush : COLORREF -> HBRUSH - val GetSysColorBrush : ColorType -> HBRUSH - val GetBrushOrgEx : HDC -> POINT - val PatBlt : HDC * int * int * int * int * RasterOpCode -> unit - val SetBrushOrgEx : HDC * POINT -> POINT - - end = -struct - local - open Foreign Base -(* - fun gdicall_IW name CR (C1,C2) (a1) = - let val (from1,to1,ctype1) = breakConversion C1 - val (from2,to2,ctype2) = breakConversion C2 - val (fromR,toR,ctypeR) = breakConversion CR - val va1 = to1 a1 - val va2 = address (alloc 1 ctype2) - val res = callgdi name [(ctype1,va1),(Cpointer ctype2,va2)] ctypeR - val _: unit = fromR res - in (from2 (deref va2)) - end - fun gdicall_IM name CR (C1,C2) (a1,a2) = - let val (from1,to1,ctype1) = breakConversion C1 - val (from2,to2,ctype2) = breakConversion C2 - val (fromR,toR,ctypeR) = breakConversion CR - val va1 = to1 a1 - val va2 = address (to2 a2) - val res = callgdi name [(ctype1,va1),(Cpointer ctype2,va2)] ctypeR - val _ : unit = fromR res - in from2 (deref va2) - end - - val XCOORD = INT : int Conversion - val YCOORD = INT: int Conversion - val WIDTH = INT: int Conversion - val HEIGHT = INT: int Conversion*) - - in - type HBRUSH = HBRUSH and COLORREF = Color.COLORREF and HBITMAP = HBITMAP - and HDC = HDC and POINT = POINT - - open GdiBase - - - (* BRUSHES *) - val CreateBrushIndirect = winCall1 (user "CreateBrushIndirect") (cConstStar cLOGBRUSH) cHBRUSH - and CreateHatchBrush = winCall2 (gdi "CreateHatchBrush") (cHATCHSTYLE, cCOLORREF) cHBRUSH - and CreateSolidBrush = winCall1 (gdi "CreateSolidBrush") (cCOLORREF) cHBRUSH - - local - val getBrushOrgEx = - winCall2 (gdi "GetBrushOrgEx") (cHDC, cStar cPoint) (successState "GetBrushOrgEx") - and setBrushOrgEx = - winCall4 (gdi "SetBrushOrgEx")(cHDC, cInt, cInt, cStar cPoint) (successState "SetBrushOrgEx") - in - fun GetBrushOrgEx hdc = let val v = ref{x=0, y=0} in getBrushOrgEx(hdc, v); !v end - and SetBrushOrgEx(hdc, {x, y}) = let val v = ref{x=0, y=0} in setBrushOrgEx(hdc, x, y, v); !v end - end - val CreatePatternBrush = winCall1 (gdi "CreatePatternBrush") (cHBITMAP) cHBRUSH - val PatBlt = winCall6(gdi "PatBlt") (cHDC,cInt,cInt,cInt,cInt,cRASTEROPCODE) - (successState "PatBlt") - datatype ColorType = - COLOR_SCROLLBAR - | COLOR_BACKGROUND - | COLOR_ACTIVECAPTION - | COLOR_INACTIVECAPTION - | COLOR_MENU - | COLOR_WINDOW - | COLOR_WINDOWFRAME - | COLOR_MENUTEXT - | COLOR_WINDOWTEXT - | COLOR_CAPTIONTEXT - | COLOR_ACTIVEBORDER - | COLOR_INACTIVEBORDER - | COLOR_APPWORKSPACE - | COLOR_HIGHLIGHT - | COLOR_HIGHLIGHTTEXT - | COLOR_BTNFACE - | COLOR_BTNSHADOW - | COLOR_GRAYTEXT - | COLOR_BTNTEXT - | COLOR_INACTIVECAPTIONTEXT - | COLOR_BTNHIGHLIGHT - | COLOR_3DDKSHADOW - | COLOR_3DLIGHT - | COLOR_INFOTEXT - | COLOR_INFOBK - - fun colourTypeToInt COLOR_SCROLLBAR = 0 - | colourTypeToInt COLOR_BACKGROUND = 1 - | colourTypeToInt COLOR_ACTIVECAPTION = 2 - | colourTypeToInt COLOR_INACTIVECAPTION = 3 - | colourTypeToInt COLOR_MENU = 4 - | colourTypeToInt COLOR_WINDOW = 5 - | colourTypeToInt COLOR_WINDOWFRAME = 6 - | colourTypeToInt COLOR_MENUTEXT = 7 - | colourTypeToInt COLOR_WINDOWTEXT = 8 - | colourTypeToInt COLOR_CAPTIONTEXT = 9 - | colourTypeToInt COLOR_ACTIVEBORDER = 10 - | colourTypeToInt COLOR_INACTIVEBORDER = 11 - | colourTypeToInt COLOR_APPWORKSPACE = 12 - | colourTypeToInt COLOR_HIGHLIGHT = 13 - | colourTypeToInt COLOR_HIGHLIGHTTEXT = 14 - | colourTypeToInt COLOR_BTNFACE = 15 - | colourTypeToInt COLOR_BTNSHADOW = 16 - | colourTypeToInt COLOR_GRAYTEXT = 17 - | colourTypeToInt COLOR_BTNTEXT = 18 - | colourTypeToInt COLOR_INACTIVECAPTIONTEXT = 19 - | colourTypeToInt COLOR_BTNHIGHLIGHT = 20 - | colourTypeToInt COLOR_3DDKSHADOW = 21 - | colourTypeToInt COLOR_3DLIGHT = 22 - | colourTypeToInt COLOR_INFOTEXT = 23 - | colourTypeToInt COLOR_INFOBK = 24 - - (* Create a brush from a system colour. *) - val GetSysColorBrush = winCall1 (user "GetSysColorBrush") (cInt) cHBRUSH o colourTypeToInt - - (* - Other Brush functions: - CreateDIBPatternBrushPt - *) - end -end; diff --git a/mlsource/extra/Win/Button.sml b/mlsource/extra/Win/Button.sml deleted file mode 100644 index a78da6da..00000000 --- a/mlsource/extra/Win/Button.sml +++ /dev/null @@ -1,224 +0,0 @@ -(* - Copyright (c) 2001 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* Buttons. *) -structure Button: -sig - structure Style: - sig - include BIT_FLAGS where type flags = Window.Style.flags - val WS_OVERLAPPED: flags and WS_POPUP: flags and WS_CHILD: flags and WS_MINIMIZE: flags - and WS_VISIBLE: flags and WS_DISABLED:flags and WS_CLIPSIBLINGS:flags - and WS_CLIPCHILDREN:flags and WS_MAXIMIZE:flags and WS_CAPTION:flags - and WS_BORDER:flags and WS_DLGFRAME:flags and WS_VSCROLL:flags and WS_HSCROLL:flags - and WS_SYSMENU:flags and WS_THICKFRAME:flags and WS_GROUP:flags and WS_TABSTOP:flags - and WS_MINIMIZEBOX:flags and WS_MAXIMIZEBOX:flags and WS_TILED:flags and WS_ICONIC:flags - and WS_SIZEBOX:flags and WS_OVERLAPPEDWINDOW:flags and WS_TILEDWINDOW:flags - and WS_POPUPWINDOW:flags and WS_CHILDWINDOW:flags - and BS_3STATE: flags and BS_AUTO3STATE: flags and BS_AUTOCHECKBOX: flags - and BS_AUTORADIOBUTTON: flags and BS_BITMAP: flags and BS_BOTTOM: flags - and BS_CENTER: flags and BS_CHECKBOX: flags and BS_DEFPUSHBUTTON: flags - and BS_FLAT: flags and BS_GROUPBOX: flags and BS_ICON: flags and BS_LEFT: flags - and BS_LEFTTEXT: flags and BS_MULTILINE: flags and BS_NOTIFY: flags - and BS_OWNERDRAW: flags and BS_PUSHBUTTON: flags and BS_PUSHLIKE: flags - and BS_RADIOBUTTON: flags and BS_RIGHT: flags and BS_RIGHTBUTTON: flags - and BS_TEXT: flags and BS_TOP: flags and BS_USERBUTTON: flags and BS_VCENTER: flags - end - - structure Notifications: - sig - val BN_CLICKED: int - val BN_PAINT: int - val BN_HILITE: int - val BN_UNHILITE: int - val BN_DISABLE: int - val BN_DOUBLECLICKED: int - val BN_PUSHED: int - val BN_UNPUSHED: int - val BN_DBLCLK: int - val BN_SETFOCUS: int - val BN_KILLFOCUS: int - end - - structure State: - sig - val BST_UNCHECKED: int - val BST_CHECKED: int - val BST_INDETERMINATE: int - val BST_PUSHED: int - val BST_FOCUS: int - end - -end -= -struct - structure Style = - struct - open Window.Style (* Include all the windows styles. *) - type flags = Window.Style.flags (* Causes the type to print as Dialog.Style.flags. *) - - val BS_PUSHBUTTON: flags = fromWord 0wx00000000 - val BS_DEFPUSHBUTTON: flags = fromWord 0wx00000001 - val BS_CHECKBOX: flags = fromWord 0wx00000002 - val BS_AUTOCHECKBOX: flags = fromWord 0wx00000003 - val BS_RADIOBUTTON: flags = fromWord 0wx00000004 - val BS_3STATE: flags = fromWord 0wx00000005 - val BS_AUTO3STATE: flags = fromWord 0wx00000006 - val BS_GROUPBOX: flags = fromWord 0wx00000007 - val BS_USERBUTTON: flags = fromWord 0wx00000008 - val BS_AUTORADIOBUTTON: flags = fromWord 0wx00000009 - val BS_OWNERDRAW: flags = fromWord 0wx0000000B - val BS_LEFTTEXT: flags = fromWord 0wx00000020 - val BS_TEXT: flags = fromWord 0wx00000000 - val BS_ICON: flags = fromWord 0wx00000040 - val BS_BITMAP: flags = fromWord 0wx00000080 - val BS_LEFT: flags = fromWord 0wx00000100 - val BS_RIGHT: flags = fromWord 0wx00000200 - val BS_CENTER: flags = fromWord 0wx00000300 - val BS_TOP: flags = fromWord 0wx00000400 - val BS_BOTTOM: flags = fromWord 0wx00000800 - val BS_VCENTER: flags = fromWord 0wx00000C00 - val BS_PUSHLIKE: flags = fromWord 0wx00001000 - val BS_MULTILINE: flags = fromWord 0wx00002000 - val BS_NOTIFY: flags = fromWord 0wx00004000 - val BS_FLAT: flags = fromWord 0wx00008000 - val BS_RIGHTBUTTON: flags = BS_LEFTTEXT - - val all = flags[Window.Style.all, BS_PUSHBUTTON, BS_DEFPUSHBUTTON, BS_CHECKBOX, - BS_AUTOCHECKBOX, BS_RADIOBUTTON, BS_3STATE, BS_AUTO3STATE, BS_GROUPBOX, - BS_USERBUTTON, BS_AUTORADIOBUTTON, BS_OWNERDRAW, BS_LEFTTEXT, BS_TEXT, - BS_ICON, BS_BITMAP, BS_LEFT, BS_RIGHT, BS_CENTER, BS_TOP, BS_BOTTOM, - BS_VCENTER, BS_PUSHLIKE, BS_MULTILINE, BS_NOTIFY, BS_FLAT] - - val intersect = - List.foldl (fn (a, b) => fromWord(SysWord.andb(toWord a, toWord b))) all - end - - structure Notifications = - struct - val BN_CLICKED = 0 - val BN_PAINT = 1 - val BN_HILITE = 2 - val BN_UNHILITE = 3 - val BN_DISABLE = 4 - val BN_DOUBLECLICKED = 5 - val BN_PUSHED = BN_HILITE - val BN_UNPUSHED = BN_UNHILITE - val BN_DBLCLK = BN_DOUBLECLICKED - val BN_SETFOCUS = 6 - val BN_KILLFOCUS = 7 - end - - (* These are returned by SendMessage(button, BM_GETCHECK) so need to be integers. *) - structure State = - struct - val BST_UNCHECKED = 0x0000 - val BST_CHECKED = 0x0001 - val BST_INDETERMINATE = 0x0002 - val BST_PUSHED = 0x0004 - val BST_FOCUS = 0x0008 - end - -end; - -(* -let - open Button.Style - - fun getType w = - let - val typeField = fromWord(SysWord.andb(toWord w, 0wx0f)) - in - if typeField = BS_PUSHBUTTON then "BS_PUSHBUTTON" - else if typeField = BS_DEFPUSHBUTTON then "BS_DEFPUSHBUTTON" - else if typeField = BS_CHECKBOX then "BS_CHECKBOX" - else if typeField = BS_AUTOCHECKBOX then "BS_AUTOCHECKBOX" - else if typeField = BS_RADIOBUTTON then "BS_RADIOBUTTON" - else if typeField = BS_3STATE then "BS_3STATE" - else if typeField = BS_AUTO3STATE then "BS_AUTO3STATE" - else if typeField = BS_GROUPBOX then "BS_GROUPBOX" - else if typeField = BS_USERBUTTON then "BS_USERBUTTON" - else if typeField = BS_AUTORADIOBUTTON then "BS_AUTORADIOBUTTON" - else if typeField = BS_OWNERDRAW then "BS_OWNERDRAW" - else "??" - end - - val flagTable = - [(BS_LEFTTEXT, "BS_LEFTTEXT"), - (BS_ICON, "BS_ICON"), - (BS_BITMAP, "BS_BITMAP"), - (BS_CENTER, "BS_CENTER"), (* Must come before the next two. *) - (BS_LEFT, "BS_LEFT"), - (BS_RIGHT, "BS_RIGHT"), - (BS_VCENTER, "BS_VCENTER"), (* Must come before the next two. *) - (BS_TOP, "BS_TOP"), - (BS_BOTTOM, "BS_BOTTOM"), - (BS_PUSHLIKE, "BS_PUSHLIKE"), - (BS_MULTILINE, "BS_MULTILINE"), - (BS_NOTIFY, "BS_NOTIFY"), - (BS_FLAT, "BS_FLAT"), - (WS_POPUP, "WS_POPUP"), - (WS_CHILD, "WS_CHILD"), - (WS_MINIMIZE, "WS_MINIMIZE"), - (WS_VISIBLE, "WS_VISIBLE"), - (WS_DISABLED, "WS_DISABLED"), - (WS_CLIPSIBLINGS, "WS_CLIPSIBLINGS"), - (WS_CLIPCHILDREN, "WS_CLIPCHILDREN"), - (WS_MAXIMIZE, "WS_MAXIMIZE"), - (WS_CAPTION, "WS_CAPTION"), - (WS_BORDER, "WS_BORDER"), - (WS_DLGFRAME, "WS_DLGFRAME"), - (WS_VSCROLL, "WS_VSCROLL"), - (WS_HSCROLL, "WS_HSCROLL"), - (WS_SYSMENU, "WS_SYSMENU"), - (WS_THICKFRAME, "WS_THICKFRAME"), - (WS_GROUP, "WS_GROUP"), - (WS_TABSTOP, "WS_TABSTOP"), - (WS_MINIMIZEBOX, "WS_MINIMIZEBOX"), - (WS_MAXIMIZEBOX, "WS_MAXIMIZEBOX")] - - fun accumulateFlags f [] = [] - | accumulateFlags f ((w, s)::t) = - if allSet(w, f) then s :: accumulateFlags(clear(w, f)) t - else accumulateFlags f t - - fun printFlags(put, beg, brk, nd) depth _ x = - (* This is just the code to print a list. *) - let - - val stringFlags = getType x :: accumulateFlags x flagTable - fun plist [] depth = () - | plist _ 0 = put "..." - | plist [h] depth = put h - | plist (h::t) depth = - ( put (h^","); - brk (1, 0); - plist t (depth - 1) - ) - in - beg (3, false); - put "["; - if depth <= 0 then put "..." else plist stringFlags depth; - put "]"; - nd () - end -in - PolyML.install_pp printFlags -end; -*) \ No newline at end of file diff --git a/mlsource/extra/Win/Caret.sml b/mlsource/extra/Win/Caret.sml deleted file mode 100644 index b25678de..00000000 --- a/mlsource/extra/Win/Caret.sml +++ /dev/null @@ -1,90 +0,0 @@ -(* - Copyright (c) 2001, 2015, 2019 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* Caret functions. *) -structure Caret : - sig - type HWND and HBITMAP - type POINT = { x: int, y: int } - datatype - caretShape = - CaretBitmap of HBITMAP - | CaretBlack of {width: int, height: int} - | CaretGrey of {width: int, height: int} - val CreateCaret : HWND * caretShape -> unit - val DestroyCaret : unit -> unit - val GetCaretBlinkTime : unit -> Time.time - val GetCaretPos : unit -> POINT - val HideCaret : HWND -> unit - val SetCaretBlinkTime : Time.time -> unit - val SetCaretPos : POINT -> unit - val ShowCaret : HWND -> unit - end - = -struct - local - open Foreign - open Base - open GdiBase - in - type HWND = HWND and HBITMAP = HBITMAP and POINT = POINT - datatype caretShape = - CaretBlack of {height: int, width: int} - | CaretGrey of {height: int, width: int} - | CaretBitmap of HBITMAP - - local - val createCaret = winCall4 (user "CreateCaret") (cHWND, cHBITMAP, cInt, cInt) - (successState "CreateCaret") - val intAsHgdi = handleOfVoidStar o Memory.sysWord2VoidStar o SysWord.fromInt - in - (* The x and y value are only used if the bitmap is not 0 or 1. *) - fun CreateCaret(hw, CaretBlack{height, width}) = - createCaret(hw, hNull, width, height) - | CreateCaret(hw, CaretGrey{height, width}) = - createCaret(hw, intAsHgdi 1, width, height) - | CreateCaret(hw, CaretBitmap hb) = - createCaret(hw, hb, 0, 0) - end - - val DestroyCaret = winCall0 (user "DestroyCaret") () (successState "DestroyCaret") - - val GetCaretBlinkTime = Time.fromMilliseconds o LargeInt.fromInt o (winCall0 (user "GetCaretBlinkTime") () cUint) - - val HideCaret = winCall1 (user "HideCaret") (cHWND) (successState "HideCaret") - - val SetCaretBlinkTime = - (winCall1 (user "SetCaretBlinkTime") cUint (successState "SetCaretBlinkTime")) o - LargeInt.toInt o Time.toMilliseconds - - (* The result of ShowCaret may be false either if there was an error or - if HideCaret was called more than once. *) - val ShowCaret = winCall1 (user "ShowCaret") (cHWND) (successState "ShowCaret") - - local - val getCaretPos = - winCall1 (user "GetCaretPos") (cStar cPoint) (successState "GetCaretPos") - val setCaretPos = - winCall2 (user "SetCaretPos") (cInt, cInt) (successState "SetCaretPos") - in - fun GetCaretPos() = let val v = ref {x=0, y=0 } in getCaretPos v; !v end - and SetCaretPos({x, y}: POINT) = setCaretPos(x, y) - end - end -end; diff --git a/mlsource/extra/Win/Class.sml b/mlsource/extra/Win/Class.sml deleted file mode 100644 index dae10121..00000000 --- a/mlsource/extra/Win/Class.sml +++ /dev/null @@ -1,256 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) -structure Class: -sig - type HWND (* = Win.HWND *) and Message (* = Message.Message *) - and HINSTANCE (* = Globals.HINSTANCE *) - and HBRUSH (* = Brush.HBRUSH *) - and HICON (* = Icon.HICON *) - and HCURSOR (* = Cursor.HCURSOR *) - and HGDIOBJ - - datatype LRESULT = - LRESINT of int | LRESHANDLE of HGDIOBJ - - datatype 'a ATOM = - Registered of - {proc: HWND * Message * 'a -> LRESULT * 'a, className: string} - | SystemClass of string - - val Button : unit ATOM - val ComboBox : unit ATOM - val ComboLBox : unit ATOM - val DDEMLEvent : unit ATOM - val Edit : unit ATOM - val ListBox : unit ATOM - val MDIClient : unit ATOM - val ScrollBar : unit ATOM - val Static : unit ATOM - - structure Style : - sig - include BIT_FLAGS - - val CS_BYTEALIGNCLIENT : flags - val CS_BYTEALIGNWINDOW : flags - val CS_CLASSDC : flags - val CS_DBLCLKS : flags - val CS_GLOBALCLASS : flags - val CS_HREDRAW : flags - val CS_KEYCVTWINDOW : flags - val CS_NOCLOSE : flags - val CS_NOKEYCVT : flags - val CS_OWNDC : flags - val CS_PARENTDC : flags - val CS_SAVEBITS : flags - val CS_VREDRAW : flags - end - - type 'a WNDCLASSEX = - {style: Style.flags, - wndProc: HWND * Message * 'a -> LRESULT * 'a, - hInstance: HINSTANCE, - hIcon: HICON option, - hCursor: HCURSOR option, - hbrBackGround: HBRUSH option, - menuName: Resource.RESID option, - className: string, - hIconSm: HICON option} - - val RegisterClassEx : 'a WNDCLASSEX -> 'a ATOM - - val UnregisterClass : string * HINSTANCE -> unit - val GetClassInfoEx: HINSTANCE * string -> 'a WNDCLASSEX - end - = -struct - local - open Foreign - open Base - open Resource - in - type Message = Message.Message - type HWND = HWND and HINSTANCE = HINSTANCE and HICON = HICON - and HBRUSH = HBRUSH and HCURSOR = HCURSOR and HGDIOBJ = HGDIOBJ - datatype LRESULT = datatype Message.LRESULT - - structure Style = - struct - open Word32 - type flags = Word32.word - val toWord = SysWord.fromLargeWord o toLargeWord - and fromWord = fromLargeWord o SysWord.toLargeWord - val flags = List.foldl (fn (a, b) => orb(a,b)) 0w0 - fun allSet (fl1, fl2) = andb(fl1, fl2) = fl1 - fun anySet (fl1, fl2) = andb(fl1, fl2) <> 0w0 - fun clear (fl1, fl2) = andb(notb fl1, fl2) - - val CS_VREDRAW: flags = 0wx0001 - val CS_HREDRAW: flags = 0wx0002 - val CS_KEYCVTWINDOW: flags = 0wx0004 - val CS_DBLCLKS: flags = 0wx0008 - val CS_OWNDC: flags = 0wx0020 - val CS_CLASSDC: flags = 0wx0040 - val CS_PARENTDC: flags = 0wx0080 - val CS_NOKEYCVT: flags = 0wx0100 - val CS_NOCLOSE: flags = 0wx0200 - val CS_SAVEBITS: flags = 0wx0800 - val CS_BYTEALIGNCLIENT: flags = 0wx1000 - val CS_BYTEALIGNWINDOW: flags = 0wx2000 - val CS_GLOBALCLASS: flags = 0wx4000 - - val all = flags[CS_VREDRAW, CS_HREDRAW, CS_KEYCVTWINDOW, CS_DBLCLKS, CS_OWNDC, - CS_CLASSDC, CS_NOKEYCVT, CS_NOCLOSE, CS_SAVEBITS, - CS_BYTEALIGNCLIENT, CS_BYTEALIGNWINDOW, CS_GLOBALCLASS] - - val intersect = List.foldl (fn (a, b) => andb(a,b)) all - end - - (* Classes are either registered by the user, in which case they have - ML callback functions, or they are built-in, such as Edit. *) - datatype 'a ATOM = - Registered of { proc: HWND * Message * 'a -> LRESULT * 'a, className: string } - | SystemClass of string - - val Button: unit ATOM = SystemClass "Button" - and ComboBox: unit ATOM = SystemClass "ComboBox" - and ComboLBox: unit ATOM = SystemClass "ComboLBox" - and DDEMLEvent: unit ATOM = SystemClass "DDEMLEvent" - and Edit: unit ATOM = SystemClass "Edit" - and ListBox: unit ATOM = SystemClass "ListBox" - and MDIClient: unit ATOM = SystemClass "MDIClient" (* Maybe treat this specially. *) - and ScrollBar: unit ATOM = SystemClass "ScrollBar" - and Static: unit ATOM = SystemClass "Static" - - type 'a WNDCLASSEX = - {style: Style.flags, - wndProc: HWND * Message * 'a -> LRESULT * 'a, - hInstance: HINSTANCE, - hIcon: HICON option, - hCursor: HCURSOR option, - hbrBackGround: HBRUSH option, - menuName: RESID option, - className: string, - hIconSm: HICON option} - - local - val cWNDCLASSEX = cStruct12(cUint,cUintw, cFunction,cInt,cInt,cHINSTANCE,cHGDIOBJOPT, - cHGDIOBJOPT,cHGDIOBJOPT,cRESID,cString,cHGDIOBJOPT) - val { ctype = {size=sizeWndclassEx, ...}, ...} = breakConversion cWNDCLASSEX - val registerClassEx = winCall1 (user "RegisterClassExA") (cConstStar cWNDCLASSEX) cUint - in - fun RegisterClassEx({style: Style.flags, - wndProc: HWND * Message * 'a -> LRESULT * 'a, - hInstance: HINSTANCE, - hIcon: HICON option, - hCursor: HCURSOR option, - hbrBackGround: HBRUSH option, - menuName: RESID option, - className: string, - hIconSm: HICON option}: 'a WNDCLASSEX): 'a ATOM = - let - (* The window procedure we pass to the C call is our dispatch function - in the RTS. *) - val windowProc = Message.mainWinProc - val cWndClass = - (Word.toInt sizeWndclassEx, - style, - windowProc, - 0, (* Class extra *) - 0, (* Window extra *) - hInstance, - hIcon, - hCursor, - hbrBackGround, - getOpt(menuName, IdAsInt 0), - className, - hIconSm) - - val res = registerClassEx cWndClass - (* The result is supposed to be an atom but it doesn't always work to - pass this directly to CreateWindow. *) - in - checkResult(res <> 0); - Registered{proc = wndProc, className = className} - end - end - - local - (* We can't use the same definition of WNDCLASSEX as above because - we can't return a callback function as a result, at least at the - moment. - Also we use CallWindowProc because it does Unicode to ANSI conversion. *) - val cWNDCLASSEX = cStruct12(cUint,cUint, cPointer,cInt,cInt,cHINSTANCE,cHGDIOBJOPT, - cHGDIOBJOPT,cHGDIOBJOPT,cRESID,cString,cHGDIOBJOPT) - val { ctype = {size=sizeWndclassEx, ...}, ...} = breakConversion cWNDCLASSEX - val CallWindowProc = - winCall5 (user "CallWindowProcA") (cPointer, cHWND, cUint, cUINT_PTRw, cUINT_PTRw) cUINT_PTRw - in - fun GetClassInfoEx(hInst, class): 'a WNDCLASSEX = - let - val v = - ref(Word.toInt sizeWndclassEx, 0, Memory.null, 0, 0, hNull, - NONE, NONE, NONE, IdAsInt 0, "", NONE) - val () = winCall3(user "GetClassInfoExA") (cHINSTANCE, cString, cStar cWNDCLASSEX) - (successState "GetClassInfoEx") (hInst, class, v) - val (_, style, wproc, _, _, hInstance, hIcon, hCursor, hbrBackGround, - menuName, className, hIconSm) = !v - val mName = - case menuName of - IdAsInt 0 => NONE - | IdAsString "" => NONE - | m => SOME m - fun wndProc(hwnd, msg, state) = - let - val (msgId: int, wParam, lParam, freeMsg) = Message.compileMessage msg - val res = CallWindowProc(wproc, hwnd, msgId, wParam, lParam) - in - (Message.messageReturnFromParams(msg, wParam, lParam, res), state) - before freeMsg() - end - in - {style = Style.fromWord(LargeWord.fromInt style), wndProc = wndProc, hInstance = hInstance, - hIcon = hIcon, hCursor = hCursor, hbrBackGround = hbrBackGround, - menuName = mName, className = className, hIconSm = hIconSm }: 'a WNDCLASSEX - end - - (* The underlying call can take either a string or an atom. I really don't - know which is better here. *) - (* TODO: We should extract the window proc and call freeCallback on it. *) - val UnregisterClass = - winCall2 (user "UnregisterClassA") (cString, cHINSTANCE) (successState "UnregisterClass") - end -(* -The following functions are used with window classes. -GetClassInfoEx -GetClassLong -GetWindowLong - in Window -SetClassLong -SetWindowLong - -Obsolete Functions - -GetClassInfo -GetClassWord -GetWindowWord -RegisterClass -SetClassWord -SetWindowWord -*) - end -end; diff --git a/mlsource/extra/Win/Clipboard.sml b/mlsource/extra/Win/Clipboard.sml deleted file mode 100644 index 16b60e1d..00000000 --- a/mlsource/extra/Win/Clipboard.sml +++ /dev/null @@ -1,289 +0,0 @@ -(* - Copyright (c) 2001, 2015, 2019 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Clipboard : - sig - (* Clipboard formats. I've added CF_NONE, CF_PRIVATE, CF_GDIOBJ and CF_REGISTERED *) - datatype ClipboardFormat = - CF_NONE | CF_TEXT | CF_BITMAP | CF_METAFILEPICT | CF_SYLK | CF_DIF | CF_TIFF | - CF_OEMTEXT | CF_DIB | CF_PALETTE | CF_PENDATA | CF_RIFF | CF_WAVE | CF_UNICODETEXT | - CF_ENHMETAFILE | CF_OWNERDISPLAY | CF_DSPTEXT | CF_DSPBITMAP | CF_DSPMETAFILEPICT | - CF_DSPENHMETAFILE | CF_PRIVATE of int | CF_GDIOBJ of int | CF_REGISTERED of int | - CF_HDROP | CF_LOCALE - - type HBITMAP and HPALETTE and HWND and HDROP - - datatype CLIPHANDLE = - CH_NONE | - CH_TEXT of string | - CH_BITMAP of HBITMAP | - CH_METAFILEPICT of Metafile.METAFILEPICT | - CH_SYLK of Word8Vector.vector | - CH_DIF of Word8Vector.vector | - CH_TIFF of Word8Vector.vector | - CH_OEMTEXT of string | - CH_DIB of Word8Vector.vector | - CH_PALETTE of HPALETTE | - CH_PENDATA of Word8Vector.vector | - CH_RIFF of Word8Vector.vector | - CH_WAVE of Word8Vector.vector | - CH_UNICODETEXT of Word8Vector.vector | - CH_ENHMETAFILE of Metafile.HENHMETAFILE | - CH_OWNERDISPLAY of Word8Vector.vector | - CH_DSPTEXT of Word8Vector.vector | - CH_DSPBITMAP of Word8Vector.vector | - CH_DSPMETAFILEPICT of Word8Vector.vector | - CH_DSPENHMETAFILE of Word8Vector.vector | - CH_PRIVATE of int * Word8Vector.vector | - CH_GDIOBJ of int * Word8Vector.vector | - CH_REGISTERED of int * Word8Vector.vector | - CH_HDROP of HDROP | - CH_LOCALE of Word8Vector.vector - - val ChangeClipboardChain : HWND * HWND -> bool - val CloseClipboard : unit -> unit - val CountClipboardFormats : unit -> int - val EmptyClipboard : unit -> unit - val EnumClipboardFormats : ClipboardFormat -> ClipboardFormat - val GetClipboardData : ClipboardFormat -> CLIPHANDLE - val GetClipboardFormatName : ClipboardFormat -> string - val GetClipboardOwner : unit -> HWND - val GetClipboardViewer : unit -> HWND - val GetOpenClipboardWindow : unit -> HWND - val GetPriorityClipboardFormat : ClipboardFormat list -> ClipboardFormat option - val IsClipboardFormatAvailable : ClipboardFormat -> bool - val OpenClipboard : HWND option -> unit - val RegisterClipboardFormat : string -> ClipboardFormat - val SetClipboardData : CLIPHANDLE -> unit - val SetClipboardViewer : HWND -> HWND - end - = -struct - local - open Foreign - open Base - val GMEM_SHARE = 0wx2000 - and GMEM_MOVEABLE = 0wx0002 - val GMEM_OPTS = Word.toInt(Word.orb(GMEM_SHARE, GMEM_MOVEABLE)) - - val {load=fromMFP, store=toMFP, ctype={size=sizeMfp, ...}, ...} = breakConversion GdiBase.cMETAFILEPICT - in - type HBITMAP = HBITMAP and HPALETTE = HPALETTE and HWND = HWND and HDROP = HDROP - - datatype ClipboardFormat = datatype ClipboardFormat - - (* The data is transferred to and from the clipboard in various formats. - I've added this datatype to deal with them. *) - datatype CLIPHANDLE = - CH_NONE | - CH_TEXT of string | - CH_BITMAP of HBITMAP | - CH_METAFILEPICT of Metafile.METAFILEPICT | - CH_SYLK of Word8Vector.vector | - CH_DIF of Word8Vector.vector | - CH_TIFF of Word8Vector.vector | - CH_OEMTEXT of string | - CH_DIB of Word8Vector.vector | - CH_PALETTE of HPALETTE | - CH_PENDATA of Word8Vector.vector | - CH_RIFF of Word8Vector.vector | - CH_WAVE of Word8Vector.vector | - CH_UNICODETEXT of Word8Vector.vector | - CH_ENHMETAFILE of Metafile.HENHMETAFILE | - CH_OWNERDISPLAY of Word8Vector.vector | - CH_DSPTEXT of Word8Vector.vector | - CH_DSPBITMAP of Word8Vector.vector | - CH_DSPMETAFILEPICT of Word8Vector.vector | - CH_DSPENHMETAFILE of Word8Vector.vector | - CH_PRIVATE of int * Word8Vector.vector | - CH_GDIOBJ of int * Word8Vector.vector | - CH_REGISTERED of int * Word8Vector.vector | - CH_HDROP of HDROP | - CH_LOCALE of Word8Vector.vector - - local - val (toInt, fromInt) = clipLookup - in - val cCLIPFORMAT = absConversion {abs = fromInt, rep = toInt} cUint - end - - val ChangeClipboardChain = winCall2 (user "ChangeClipboardChain") (cHWND, cHWND) cBool - and CloseClipboard = winCall0 (user "CloseClipboard") () (successState "CloseClipboard") - and CountClipboardFormats = winCall0 (user "CountClipboardFormats") () cInt - and EmptyClipboard = winCall0 (user "EmptyClipboard") () (successState "EmptyClipboard") - and EnumClipboardFormats = winCall1 (user "EnumClipboardFormats") (cCLIPFORMAT) cCLIPFORMAT - and GetClipboardOwner = winCall0 (user "GetClipboardOwner") () cHWND - and GetClipboardViewer = winCall0 (user "GetClipboardViewer") () cHWND - and GetOpenClipboardWindow = winCall0 (user "GetOpenClipboardWindow") () cHWND - and IsClipboardFormatAvailable = - winCall1 (user "IsClipboardFormatAvailable") (cCLIPFORMAT) cBool - and OpenClipboard = winCall1 (user "OpenClipboard") (cHWNDOPT) (successState "OpenClipboard") - and RegisterClipboardFormat = - CF_REGISTERED o winCall1 (user "RegisterClipboardFormat") (cString) cUint - and SetClipboardViewer = winCall1 (user "SetClipboardViewer") (cHWND) cHWND - - local - (* The argument and result are actually HANDLE but we haven't got quite the - right form of subclassing to allow all the various handle types to be combined. *) - val setClipboardData = winCall2(user "SetClipboardData") (cCLIPFORMAT, cHGLOBAL) cHGLOBAL - - (* Most clipboard data is passed in memory allocated using GlobalAlloc. *) - fun globString (s: string) = - let - val hGlob = GlobalAlloc(GMEM_OPTS, size s + 1) - val mem = GlobalLock hGlob - in - copyStringToMem(mem, 0, s); - GlobalUnlock hGlob; - hGlob - end - and globMem (w: Word8Vector.vector) = - let - val length = Word8Vector.length w - val hGlob = GlobalAlloc(GMEM_OPTS, length) - val buf = GlobalLock hGlob - in - Word8Vector.appi (fn (i, v) => Memory.set8(buf, Word.fromInt i, v)) w; - GlobalUnlock hGlob; - hGlob - end - fun toHglobal (h: 'a HANDLE): HGLOBAL = handleOfVoidStar(voidStarOfHandle h) - in - (* SetClipboardData copies the data to the clipboard. It is possible to pass - NULL as the handle and instead process the WM_RENDERFORMAT message. We - don't support that. *) - fun SetClipboardData(clip: CLIPHANDLE): unit = - let - - (* Convert the various data formats and get the format type to pass. *) - val (cf, data) = - case clip of - CH_NONE => raise Fail "SetClipboardData: No data" - | CH_TEXT t => (CF_TEXT, globString t) - | CH_BITMAP b => (CF_BITMAP, toHglobal b) - | CH_METAFILEPICT p => - let - val hGlob = GlobalAlloc(GMEM_OPTS, Word.toInt sizeMfp) - in - ignore(toMFP(GlobalLock hGlob, p)); - GlobalUnlock hGlob; - (CF_METAFILEPICT, hGlob) - end - | CH_SYLK m => (CF_SYLK, globMem m) - | CH_DIF m => (CF_DIF, globMem m) - | CH_TIFF m => (CF_TIFF, globMem m) - | CH_OEMTEXT t => (CF_OEMTEXT, globString t) - | CH_DIB m => (CF_DIB, globMem m) - | CH_PALETTE p => (CF_PALETTE, toHglobal p) - | CH_PENDATA m => (CF_PENDATA, globMem m) - | CH_RIFF m => (CF_RIFF, globMem m) - | CH_WAVE m => (CF_WAVE, globMem m) - | CH_UNICODETEXT m => (CF_UNICODETEXT, globMem m) - | CH_ENHMETAFILE mf => (CF_ENHMETAFILE, toHglobal mf) - | CH_OWNERDISPLAY m => (CF_OWNERDISPLAY, globMem m) - | CH_DSPTEXT m => (CF_DSPTEXT, globMem m) - | CH_DSPBITMAP m => (CF_DSPBITMAP, globMem m) - | CH_DSPMETAFILEPICT m => (CF_DSPMETAFILEPICT, globMem m) - | CH_DSPENHMETAFILE m => (CF_DSPENHMETAFILE, globMem m) - | CH_PRIVATE(i, m) => (CF_PRIVATE i, globMem m) - | CH_GDIOBJ(i, m) => (CF_GDIOBJ i, globMem m) - | CH_REGISTERED(i, m) => (CF_REGISTERED i, globMem m) - | CH_HDROP d => (CF_HDROP, toHglobal d) - | CH_LOCALE m => (CF_LOCALE, globMem m) - val res = setClipboardData (cf, data) - in - if res = hNull - then raiseSysErr () - else () - end - end - - local - val getClipboardData = winCall1 (user "GetClipboardData") (cCLIPFORMAT) cHGLOBAL - fun getMem hg = fromCWord8vec(GlobalLock hg, GlobalSize hg) before ignore(GlobalUnlock hg) - and getText hg = fromCstring(GlobalLock hg) before ignore(GlobalUnlock hg) - fun fromHglobal (h: HGLOBAL): 'a HANDLE = handleOfVoidStar(voidStarOfHandle h) - in - fun GetClipboardData(f: ClipboardFormat): CLIPHANDLE = - let - (* The result of GetClipboardData is a handle, usually but not always an - HGLOBAL pointing to a piece of memory. *) - val res = getClipboardData f - val _ = checkResult (res <> hNull) - - in - case f of - CF_NONE => CH_NONE - | CF_TEXT => CH_TEXT(getText res) - | CF_BITMAP => CH_BITMAP(fromHglobal res) - | CF_METAFILEPICT => - CH_METAFILEPICT(fromMFP(GlobalLock res)) before ignore(GlobalUnlock res) - | CF_SYLK => CH_SYLK(getMem res) - | CF_DIF => CH_DIF(getMem res) - | CF_TIFF => CH_TIFF(getMem res) - | CF_OEMTEXT => CH_OEMTEXT(getText res) - | CF_DIB => CH_DIB(getMem res) - | CF_PALETTE => CH_PALETTE(fromHglobal res) - | CF_PENDATA => CH_PENDATA(getMem res) - | CF_RIFF => CH_RIFF(getMem res) - | CF_WAVE => CH_WAVE(getMem res) - | CF_UNICODETEXT => CH_UNICODETEXT(getMem res) - | CF_ENHMETAFILE => CH_ENHMETAFILE(fromHglobal res) - | CF_OWNERDISPLAY => CH_OWNERDISPLAY(getMem res) - | CF_DSPTEXT => CH_DSPTEXT(getMem res) - | CF_DSPBITMAP => CH_DSPBITMAP(getMem res) - | CF_DSPMETAFILEPICT => CH_DSPMETAFILEPICT(getMem res) - | CF_DSPENHMETAFILE => CH_DSPENHMETAFILE(getMem res) - | CF_PRIVATE i => CH_PRIVATE(i, getMem res) - | CF_GDIOBJ i => CH_GDIOBJ(i, getMem res) - | CF_REGISTERED i => CH_REGISTERED(i, getMem res) - | CF_HDROP => CH_HDROP(fromHglobal res) - | CF_LOCALE => CH_LOCALE(getMem res) - end - end - - local - val getformat = winCall3 (user "GetClipboardFormatNameA") (cCLIPFORMAT, cPointer, cInt) cInt - in - (* Loop until we have read the whole string. The result may legitimately be - a null string. *) - fun GetClipboardFormatName(f: ClipboardFormat): string = - getStringCall(fn (buff, n) => getformat(f, buff, n)) - end - - local - val getPriorityClipboardFormat = winCall2(user "GetPriorityClipboardFormat") (cPointer, cInt) cInt - in - fun GetPriorityClipboardFormat(l: ClipboardFormat list): ClipboardFormat option = - let - val (vec, count) = list2Vector cCLIPFORMAT l - val res = getPriorityClipboardFormat(vec, count) handle ex => (Memory.free vec; raise ex) - val () = Memory.free vec - in - (* It returns 0 if the clipboard is empty, ~1 if it doesn't contain any - of the requested formats and >0 if it contains one of the formats. - We map ~1 to NONE. *) - if res < 0 then NONE else SOME(#2 clipLookup res) - end - end - end -end; -(* -Other clipboard functions: - GetClipboardSequenceNumber - Windows 98 and NT 5.0 only -*) diff --git a/mlsource/extra/Win/Clipping.sml b/mlsource/extra/Win/Clipping.sml deleted file mode 100644 index f6a18faf..00000000 --- a/mlsource/extra/Win/Clipping.sml +++ /dev/null @@ -1,85 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Clipping : - sig - type HDC and HRGN - type RECT = { top: int, left: int, bottom: int, right: int } - type POINT = { x: int, y: int } - type RegionOperation = Region.RegionOperation - type ResultRegion = Region.ResultRegion - - val ExcludeClipRect : HDC * RECT -> ResultRegion - val ExtSelectClipRgn : HDC * HRGN * RegionOperation -> ResultRegion - val GetClipBox : HDC -> ResultRegion * RECT - val GetClipRgn : HDC * HRGN -> unit - val GetMetaRgn : HDC * HRGN -> unit - val IntersectClipRect : HDC * RECT -> ResultRegion - val OffsetClipRgn : HDC * int * int -> ResultRegion - val PtVisible : HDC * POINT -> bool - val RectVisible : HDC * RECT -> bool - val SelectClipPath : HDC * RegionOperation -> unit - val SelectClipRgn : HDC * HRGN -> unit - val SetMetaRgn : HDC -> unit - end = -struct - local - open Foreign Base GdiBase - in - type RegionOperation = RegionOperation and ResultRegion = ResultRegion - type RECT = RECT and HDC = HDC and HRGN = HRGN and POINT = POINT - - val ExtSelectClipRgn = winCall3(gdi "ExtSelectClipRgn") (cHDC,cHRGN,REGIONOPERATION) RESULTREGION - val GetClipRgn = winCall2(gdi "GetClipRgn") (cHDC,cHRGN) (successState "GetClipRgn") - val GetMetaRgn = winCall2(gdi "GetMetaRgn") (cHDC,cHRGN) (successState "GetMetaRgn") - val OffsetClipRgn = winCall3(gdi "OffsetClipRgn") (cHDC,cInt,cInt) RESULTREGION - val RectVisible = winCall2(gdi "RectVisible") (cHDC,cConstStar cRect) cBool - val SelectClipPath = winCall2(gdi "SelectClipPath") (cHDC,REGIONOPERATION) (successState "SelectClipPath") - val SelectClipRgn = winCall2(gdi "SelectClipRgn") (cHDC,cHRGN) (successState "SelectClipRgn") - val SetMetaRgn = winCall1(gdi "SetMetaRgn") (cHDC) (successState "SetMetaRgn") - - local - val ptVisible = winCall3(gdi "PtVisible") (cHDC,cInt,cInt) cBool - in - fun PtVisible(hd, {x, y}) = ptVisible(hd, x, y) - end - - local - val excludeClipRect = winCall5 (gdi "ExcludeClipRect") (cHDC,cInt,cInt,cInt,cInt) RESULTREGION - in - fun ExcludeClipRect (h,{left,top,right,bottom}) = excludeClipRect(h,left,top,right,bottom) - end - - local - val intersectClipRect = - winCall5 (gdi "IntersectClipRect") (cHDC,cInt,cInt,cInt,cInt) RESULTREGION - in - fun IntersectClipRect (h,{left,top,right,bottom}: RECT) = - intersectClipRect(h,left,top,right,bottom) - end - - local - val getClipBox = winCall2 (gdi "GetClipBox") (cHDC, cStar cRect) RESULTREGION - val zeroRect = { top=0, bottom=0, left=0, right=0} - in - fun GetClipBox hdc = - let val v = ref zeroRect val res = getClipBox(hdc, v) in (res, !v) end - end - - end -end; diff --git a/mlsource/extra/Win/Color.sml b/mlsource/extra/Win/Color.sml deleted file mode 100644 index 447c59a0..00000000 --- a/mlsource/extra/Win/Color.sml +++ /dev/null @@ -1,264 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Color (* Use American spelling for consistency. *): - sig - type HPALETTE and HDC - - datatype - PaletteEntryFlag = PC_EXPLICIT | PC_NOCOLLAPSE | PC_NULL | PC_RESERVED - type PALETTEENTRY = {red: int, green: int, blue: int, flags: PaletteEntryFlag} - - type COLORREF - val toRGB : - COLORREF -> {red: Int.int, blue: Int.int, green: Int.int} - val RGB : {red: int, blue: int, green: int} -> COLORREF - val PALETTERGB : {red: int, blue: int, green: int} -> COLORREF - - type SystemPaletteUse - val SYSPAL_ERROR : SystemPaletteUse - val SYSPAL_NOSTATIC : SystemPaletteUse - val SYSPAL_STATIC : SystemPaletteUse - - val AnimatePalette : HPALETTE * int * PALETTEENTRY list -> bool - val CreateHalftonePalette : HDC -> HPALETTE - val CreatePalette : PALETTEENTRY list -> HPALETTE - val GetNearestColor : HDC * COLORREF -> COLORREF - val GetNearestPaletteIndex : HPALETTE * COLORREF -> int - val GetPaletteEntries : HPALETTE * int * int -> PALETTEENTRY list - val GetSystemPaletteEntries : HDC * int * int -> PALETTEENTRY list - val GetSystemPaletteUse : HDC -> SystemPaletteUse - val RealizePalette : HDC -> int - val ResizePalette : HPALETTE * int -> unit - val SelectPalette : HDC * HPALETTE * bool -> HPALETTE - val SetPaletteEntries : HPALETTE * int * PALETTEENTRY list -> unit - val SetSystemPaletteUse : HDC * SystemPaletteUse -> SystemPaletteUse - val UnrealizeObject : HPALETTE -> unit - val UpdateColors : HDC -> unit - end = -struct - local - open Foreign Base - in - type HDC = HDC and HPALETTE = HPALETTE - open GdiBase - - - local - datatype SystemPaletteUse = - W of int - in - type SystemPaletteUse = SystemPaletteUse - val SYSTEMPALETTEUSE = absConversion {abs = W, rep = fn W n => n} cUint - - val SYSPAL_ERROR = W (0) - val SYSPAL_STATIC = W (1) - val SYSPAL_NOSTATIC = W (2) - end - - datatype PaletteEntryFlag = PC_NULL | PC_RESERVED | PC_EXPLICIT | PC_NOCOLLAPSE - type PALETTEENTRY = {red: int, green: int, blue: int, flags: PaletteEntryFlag} - - local - val cPaletteEnt = cStruct4(cUint8, cUint8, cUint8, cUint8) - val { load=loadPE, store=storePE, ctype={size=peSize, ...} } = breakConversion cPaletteEnt - - fun toPE({red, green, blue, flags}: PALETTEENTRY) = - let - val f = - case flags of PC_NULL => 0 | PC_RESERVED => 1 - | PC_EXPLICIT => 2 | PC_NOCOLLAPSE => 4 - in - (red, green, blue, f) - end - fun fromPE (red, green, blue, f): PALETTEENTRY = - let - val flags = - case f of - 0 => PC_NULL - | 1 => PC_RESERVED - | 2 => PC_EXPLICIT - | 4 => PC_NOCOLLAPSE - | _ => raise Match - in - {red=red, green=green, blue=blue, flags=flags} - end - - open Memory - infix 6 ++ - val logPal = cStruct2(cWORD, cWORD) - val {store=storeLP, ctype={size=lpSize, ...}, ...} = breakConversion logPal - in - (* Unfortunately we can't make a simple conversion here. When we load - the entries we need to know how many we're loading. *) - fun allocPEVec n = malloc(Word.fromInt n * peSize) - val freePEVec = free - - local - (* Copy the elements into the array. *) - fun doStore (pe: PALETTEENTRY, vec) = - ( - ignore(storePE(vec, toPE pe)); (* Ignore result - nothing to free *) - vec ++ peSize - ) - in - fun palListToC pl = - let - val count = List.length pl - val vec = allocPEVec count - val _ = List.foldl doStore vec pl - in - (vec, count) - end - - fun logPaletteToC pl = - let - (* A logical palette has two additional words at the start. *) - val count = List.length pl - val vec = malloc(Word.fromInt count * peSize + lpSize) - val _ = storeLP(vec, (0x300, count)) - val _ = List.foldl doStore (vec ++ lpSize) pl - in - vec - end - end - - fun palListFromC(vec, count) = - let - fun loadPalE n = fromPE(loadPE(vec ++ Word.fromInt n * peSize)) - in - List.tabulate(count, loadPalE) - end - end - - val GetSystemPaletteUse = winCall1(gdi "GetSystemPaletteUse") (cHDC) SYSTEMPALETTEUSE - val RealizePalette = winCall1(gdi "RealizePalette") (cHDC) cUint - val ResizePalette = winCall2(gdi "ResizePalette") (cHPALETTE,cUint) (successState "ResizePalette") - val SelectPalette = winCall3(gdi "SelectPalette") (cHDC,cHPALETTE,cBool) cHPALETTE - val SetSystemPaletteUse = winCall2(gdi "SetSystemPaletteUse") (cHDC,SYSTEMPALETTEUSE) SYSTEMPALETTEUSE - val UpdateColors = winCall1(gdi "UpdateColors") (cHDC) (successState "UpdateColors") - val CreateHalftonePalette = winCall1(gdi "CreateHalftonePalette") (cHDC) cHPALETTE - val GetNearestColor = winCall2 (gdi "GetNearestColor") (cHDC,cCOLORREF) cCOLORREF - val GetNearestPaletteIndex = winCall2 (gdi "GetNearestPaletteIndex") (cHPALETTE,cCOLORREF) cUint - val UnrealizeObject = winCall1(gdi "UnrealizeObject") (cHPALETTE) (successState "UnrealizeObject") - - local - val animatePalette = - winCall4 (gdi "AnimatePalette") (cHPALETTE, cUint, cUint, cPointer) (cBool) - in - fun AnimatePalette (h,start,pl) = - let - val (vec, count) = palListToC pl - val res = - animatePalette(h, start, count, vec) - handle ex => (freePEVec vec; raise ex) - val () = freePEVec vec - in - res - end - end - - local - val createPalette = winCall1 (gdi "CreatePalette") (cPointer) (cHPALETTE) - in - fun CreatePalette pl = - let - val vec = logPaletteToC pl - val res = - createPalette vec handle ex => (freePEVec vec; raise ex) - val () = freePEVec vec - val () = checkResult(not(isHNull res)) - in - res - end - end - - local - val getPaletteEntries = - winCall4 (gdi "GetPaletteEntries") (cHPALETTE, cUint, cUint, cPointer) cUint - in - fun GetPaletteEntries (h, start, no) = - let - val vec = allocPEVec no - val res = getPaletteEntries (h, start, no, vec) - (* The result is zero if error *) - val result = palListFromC(vec, res) - val () = freePEVec vec - val () = checkResult(res <> 0) - in - result - end - end - - local - val getSystemPaletteEntries = - winCall4 (gdi "GetSystemPaletteEntries") (cHDC, cUint, cUint, cPointer) cUint - in - fun GetSystemPaletteEntries (h, start, no) = - let - val vec = allocPEVec no - val res = getSystemPaletteEntries (h, start, no, vec) - (* The result is zero if error *) - val result = palListFromC(vec, res) - val () = freePEVec vec - val () = checkResult(res <> 0) - in - result - end - end - - local - val setPaletteEntries = - winCall4 (gdi "SetPaletteEntries") (cHPALETTE, cUint, cUint, cPointer) cUint - in - fun SetPaletteEntries (h, start,pl) = - let - val (vec, count) = palListToC pl - val res = - setPaletteEntries(h, start, count, vec) - handle ex => (freePEVec vec; raise ex) - val () = freePEVec vec - in - checkResult(res <> 0) - end - end - (* - Other Colour functions: - GetColorAdjustment - GetSystemPaletteUse - SetColorAdjustment - *) - - end -end; - -(* Install a pretty printer for COLORREF. *) -local - open Color - fun printColorRef _ _ x = - let - val {red, green, blue} = toRGB x - in - PolyML.PrettyString - (concat["RGB{red=", Int.toString red, - ",green=", Int.toString green, - ",blue=", Int.toString blue, "}"]) - end -in - val _ = PolyML.addPrettyPrinter printColorRef -end; diff --git a/mlsource/extra/Win/ComboBase.sml b/mlsource/extra/Win/ComboBase.sml deleted file mode 100644 index 25109bae..00000000 --- a/mlsource/extra/Win/ComboBase.sml +++ /dev/null @@ -1,43 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure ComboBase = -struct - local - open Foreign Base - in - datatype CBDirAttr = - DDL_READWRITE | DDL_READONLY | DDL_HIDDEN | DDL_SYSTEM | DDL_DIRECTORY | - DDL_ARCHIVE | DDL_POSTMSGS | DDL_DRIVES | DDL_EXCLUSIVE - local - val tab = [ - (DDL_READWRITE, 0wx0000), - (DDL_READONLY, 0wx0001), - (DDL_HIDDEN, 0wx0002), - (DDL_SYSTEM, 0wx0004), - (DDL_DIRECTORY, 0wx0010), - (DDL_ARCHIVE, 0wx0020), - (DDL_POSTMSGS, 0wx2000), - (DDL_DRIVES, 0wx4000), - (DDL_EXCLUSIVE, 0wx8000) - ] - in - val CBDIRATTRS = tableSetLookup(tab, NONE) - end - end -end; diff --git a/mlsource/extra/Win/Combobox.sml b/mlsource/extra/Win/Combobox.sml deleted file mode 100644 index 4768ebb4..00000000 --- a/mlsource/extra/Win/Combobox.sml +++ /dev/null @@ -1,176 +0,0 @@ -(* - Copyright (c) 2001 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* Comboboxes. *) -structure Combobox: -sig - structure Style: - sig - include BIT_FLAGS where type flags = Window.Style.flags - val WS_OVERLAPPED: flags and WS_POPUP: flags and WS_CHILD: flags and WS_MINIMIZE: flags - and WS_VISIBLE: flags and WS_DISABLED:flags and WS_CLIPSIBLINGS:flags - and WS_CLIPCHILDREN:flags and WS_MAXIMIZE:flags and WS_CAPTION:flags - and WS_BORDER:flags and WS_DLGFRAME:flags and WS_VSCROLL:flags and WS_HSCROLL:flags - and WS_SYSMENU:flags and WS_THICKFRAME:flags and WS_GROUP:flags and WS_TABSTOP:flags - and WS_MINIMIZEBOX:flags and WS_MAXIMIZEBOX:flags and WS_TILED:flags and WS_ICONIC:flags - and WS_SIZEBOX:flags and WS_OVERLAPPEDWINDOW:flags and WS_TILEDWINDOW:flags - and WS_POPUPWINDOW: flags and WS_CHILDWINDOW: flags - and CBS_SIMPLE: flags and CBS_DROPDOWN: flags and CBS_DROPDOWNLIST: flags - and CBS_OWNERDRAWFIXED: flags and CBS_OWNERDRAWVARIABLE: flags and CBS_AUTOHSCROLL: flags - and CBS_OEMCONVERT: flags and CBS_SORT: flags and CBS_HASSTRINGS: flags - and CBS_NOINTEGRALHEIGHT: flags and CBS_DISABLENOSCROLL: flags - and CBS_UPPERCASE: flags and CBS_LOWERCASE: flags - end - - structure Notifications: - sig - val CBN_SELCHANGE: int - val CBN_DBLCLK: int - val CBN_SETFOCUS: int - val CBN_KILLFOCUS: int - val CBN_EDITCHANGE: int - val CBN_EDITUPDATE: int - val CBN_DROPDOWN: int - val CBN_CLOSEUP: int - val CBN_SELENDOK: int - val CBN_SELENDCANCEL: int - end - - datatype CBDirAttr = - DDL_READWRITE | DDL_READONLY | DDL_HIDDEN | DDL_SYSTEM | DDL_DIRECTORY | - DDL_ARCHIVE | DDL_POSTMSGS | DDL_DRIVES | DDL_EXCLUSIVE -end -= -struct - open ComboBase - - structure Style = - struct - open Window.Style (* Include all the windows styles. *) - - val CBS_SIMPLE = fromWord 0wx0001 - val CBS_DROPDOWN = fromWord 0wx0002 - val CBS_DROPDOWNLIST = fromWord 0wx0003 - val CBS_OWNERDRAWFIXED = fromWord 0wx0010 - val CBS_OWNERDRAWVARIABLE = fromWord 0wx0020 - val CBS_AUTOHSCROLL = fromWord 0wx0040 - val CBS_OEMCONVERT = fromWord 0wx0080 - val CBS_SORT = fromWord 0wx0100 - val CBS_HASSTRINGS = fromWord 0wx0200 - val CBS_NOINTEGRALHEIGHT = fromWord 0wx0400 - val CBS_DISABLENOSCROLL = fromWord 0wx0800 - val CBS_UPPERCASE = fromWord 0wx2000 - val CBS_LOWERCASE = fromWord 0wx4000 - - val all = flags[Window.Style.all, CBS_SIMPLE, CBS_DROPDOWN, CBS_DROPDOWNLIST, - CBS_OWNERDRAWFIXED, CBS_OWNERDRAWVARIABLE, CBS_AUTOHSCROLL, - CBS_OEMCONVERT, CBS_SORT, CBS_HASSTRINGS, CBS_NOINTEGRALHEIGHT, - CBS_DISABLENOSCROLL, CBS_UPPERCASE, CBS_LOWERCASE] - - val intersect = - List.foldl (fn (a, b) => fromWord(SysWord.andb(toWord a, toWord b))) all - end - - structure Notifications = - struct - val CBN_SELCHANGE = 1 - val CBN_DBLCLK = 2 - val CBN_SETFOCUS = 3 - val CBN_KILLFOCUS = 4 - val CBN_EDITCHANGE = 5 - val CBN_EDITUPDATE = 6 - val CBN_DROPDOWN = 7 - val CBN_CLOSEUP = 8 - val CBN_SELENDOK = 9 - val CBN_SELENDCANCEL = 10 - end -(* -DlgDirListComboBox -DlgDirSelectEx -DlgDirSelectComboBoxEx -*) -end; - -(* -let - open Combobox.Style - - val flagTable = - [(CBS_DROPDOWNLIST, "CBS_DROPDOWNLIST"), (* Must come before the next two. *) - (CBS_SIMPLE, "CBS_SIMPLE"), - (CBS_DROPDOWN, "CBS_DROPDOWN"), - (CBS_OWNERDRAWFIXED, "CBS_OWNERDRAWFIXED"), - (CBS_OWNERDRAWVARIABLE, "CBS_OWNERDRAWVARIABLE"), - (CBS_AUTOHSCROLL, "CBS_AUTOHSCROLL"), - (CBS_OEMCONVERT, "CBS_OEMCONVERT"), - (CBS_SORT, "CBS_SORT"), - (CBS_HASSTRINGS, "CBS_HASSTRINGS"), - (CBS_NOINTEGRALHEIGHT, "CBS_NOINTEGRALHEIGHT"), - (CBS_DISABLENOSCROLL, "CBS_DISABLENOSCROLL"), - (CBS_UPPERCASE, "CBS_UPPERCASE"), - (CBS_LOWERCASE, "CBS_LOWERCASE"), - (WS_POPUP, "WS_POPUP"), - (WS_CHILD, "WS_CHILD"), - (WS_MINIMIZE, "WS_MINIMIZE"), - (WS_VISIBLE, "WS_VISIBLE"), - (WS_DISABLED, "WS_DISABLED"), - (WS_CLIPSIBLINGS, "WS_CLIPSIBLINGS"), - (WS_CLIPCHILDREN, "WS_CLIPCHILDREN"), - (WS_MAXIMIZE, "WS_MAXIMIZE"), - (WS_CAPTION, "WS_CAPTION"), - (WS_BORDER, "WS_BORDER"), - (WS_DLGFRAME, "WS_DLGFRAME"), - (WS_VSCROLL, "WS_VSCROLL"), - (WS_HSCROLL, "WS_HSCROLL"), - (WS_SYSMENU, "WS_SYSMENU"), - (WS_THICKFRAME, "WS_THICKFRAME"), - (WS_GROUP, "WS_GROUP"), - (WS_TABSTOP, "WS_TABSTOP"), - (WS_MINIMIZEBOX, "WS_MINIMIZEBOX"), - (WS_MAXIMIZEBOX, "WS_MAXIMIZEBOX")] - - fun accumulateFlags f [] = [] - | accumulateFlags f ((w, s)::t) = - if allSet(w, f) then s :: accumulateFlags(clear(w, f)) t - else accumulateFlags f t - - fun printFlags(put, beg, brk, nd) depth _ x = - (* This is just the code to print a list. *) - let - - val stringFlags = accumulateFlags x flagTable - fun plist [] depth = () - | plist _ 0 = put "..." - | plist [h] depth = put h - | plist (h::t) depth = - ( put (h^","); - brk (1, 0); - plist t (depth - 1) - ) - in - beg (3, false); - put "["; - if depth <= 0 then put "..." else plist stringFlags depth; - put "]"; - nd () - end -in - PolyML.install_pp printFlags -end; -*) diff --git a/mlsource/extra/Win/CommonControls.sml b/mlsource/extra/Win/CommonControls.sml deleted file mode 100644 index 6d8b7a39..00000000 --- a/mlsource/extra/Win/CommonControls.sml +++ /dev/null @@ -1,336 +0,0 @@ -(* - Copyright (c) 2007, 2015, 2019 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* Common controls. *) -structure CommonControls: -sig - type HWND and HINSTANCE and HBITMAP - val InitCommonControls: unit->unit - - structure ToolbarStyle: - sig - include BIT_FLAGS where type flags = Window.Style.flags - val WS_OVERLAPPED: flags and WS_POPUP: flags and WS_CHILD: flags and WS_MINIMIZE: flags - and WS_VISIBLE: flags and WS_DISABLED:flags and WS_CLIPSIBLINGS:flags - and WS_CLIPCHILDREN:flags and WS_MAXIMIZE:flags and WS_CAPTION:flags - and WS_BORDER:flags and WS_DLGFRAME:flags and WS_VSCROLL:flags and WS_HSCROLL:flags - and WS_SYSMENU:flags and WS_THICKFRAME:flags and WS_GROUP:flags and WS_TABSTOP:flags - and WS_MINIMIZEBOX:flags and WS_MAXIMIZEBOX:flags and WS_TILED:flags and WS_ICONIC:flags - and WS_SIZEBOX:flags and WS_OVERLAPPEDWINDOW:flags and WS_TILEDWINDOW:flags - and WS_POPUPWINDOW:flags and WS_CHILDWINDOW:flags - and TBSTYLE_BUTTON:flags and TBSTYLE_SEP:flags and TBSTYLE_CHECK:flags - and TBSTYLE_GROUP:flags and TBSTYLE_CHECKGROUP:flags and TBSTYLE_DROPDOWN:flags - and TBSTYLE_AUTOSIZE:flags and TBSTYLE_NOPREFIX:flags and TBSTYLE_TOOLTIPS:flags - and TBSTYLE_WRAPABLE:flags and TBSTYLE_ALTDRAG:flags and TBSTYLE_FLAT:flags - and TBSTYLE_LIST:flags and TBSTYLE_CUSTOMERASE:flags and TBSTYLE_REGISTERDROP:flags - and TBSTYLE_TRANSPARENT:flags and BTNS_BUTTON:flags and BTNS_SEP:flags - and BTNS_CHECK:flags and BTNS_GROUP:flags and BTNS_CHECKGROUP:flags - and BTNS_DROPDOWN:flags and BTNS_AUTOSIZE:flags and BTNS_NOPREFIX:flags - and BTNS_SHOWTEXT:flags and BTNS_WHOLEDROPDOWN:flags - end - - structure ToolbarState: - sig - include BIT_FLAGS - val TBSTATE_CHECKED: flags and TBSTATE_PRESSED: flags and TBSTATE_ENABLED: flags - and TBSTATE_HIDDEN: flags and TBSTATE_INDETERMINATE: flags and TBSTATE_WRAP: flags - and TBSTATE_ELLIPSES: flags and TBSTATE_MARKED : flags - end - - datatype ToolbarResource = - ToolbarHandle of HBITMAP | ToolbarResource of HINSTANCE*Resource.RESID - - datatype ParentType = datatype Window.ParentType - - type TBBUTTON = { iBitmap: int, idCommand: int, fsState: ToolbarState.flags, - fsStyle: ToolbarStyle.flags, dwData: int, isString: int}; - val CreateToolbarEx: { relation: ParentType, style: ToolbarStyle.flags, nBitmaps: int, - bitmaps: ToolbarResource, buttons: TBBUTTON list, - xButton: int, yButton: int, xBitmap: int, yBitmap: int} -> HWND - val CreateStatusWindow: { relation: ParentType, style: Window.Style.flags, text: string } -> HWND - - val SB_SIMPLEID: int - - structure StatusBarType: - sig - include BIT_FLAGS - val SBT_NOBORDERS: flags and SBT_OWNERDRAW: flags - and SBT_POPOUT: flags and SBT_RTLREADING : flags and SBT_TOOLTIPS: flags - end - - (* Creating messages here is just too complicated. It's easier to do this with - functions to send the message and deal with the result. *) - val StatusBarSetText: {hWnd: HWND, iPart: int, uType: StatusBarType.flags, text: string}->int - val StatusBarGetText: HWND*int -> string * StatusBarType.flags - val StatusBarSetParts: HWND * int list -> bool -end = -struct - datatype ParentType = datatype Window.ParentType - - local - open Foreign - open Globals - open Base - - in - type HWND = HWND and HINSTANCE = HINSTANCE and HBITMAP = HBITMAP - - val InitCommonControls = winCall0(comctl "InitCommonControls") () cVoid - - (* Toolbar style is a mess. The TBBUTTON structure allows only a single - byte for the style but some of the values exceed that. Apparently - it's necessary to use CreateWindowEx for those. *) - structure ToolbarStyle = - struct - open Window.Style (* Include all the windows styles. *) - val TBSTYLE_BUTTON = fromWord 0wx0 - val TBSTYLE_SEP = fromWord 0wx1 - val TBSTYLE_CHECK = fromWord 0wx2 - val TBSTYLE_GROUP = fromWord 0wx4 - val TBSTYLE_CHECKGROUP = flags[TBSTYLE_GROUP,TBSTYLE_CHECK] - val TBSTYLE_DROPDOWN = fromWord 0wx8 - val TBSTYLE_AUTOSIZE = fromWord 0wx10 - val TBSTYLE_NOPREFIX = fromWord 0wx20 - val TBSTYLE_TOOLTIPS = fromWord 0wx100 - val TBSTYLE_WRAPABLE = fromWord 0wx200 - - val TBSTYLE_ALTDRAG = fromWord 0wx400 - - val TBSTYLE_FLAT = fromWord 0wx800 - val TBSTYLE_LIST = fromWord 0wx1000 - val TBSTYLE_CUSTOMERASE = fromWord 0wx2000 - val TBSTYLE_REGISTERDROP = fromWord 0wx4000 - val TBSTYLE_TRANSPARENT = fromWord 0wx8000 - (* -- These are used with TB_SETEXTENDEDSTYLE/TB_GETEXTENDEDSTYLE - val TBSTYLE_EX_DRAWDDARROWS = fromWord 0wx00000001 - val TBSTYLE_EX_MIXEDBUTTONS = fromWord 0w8 - val TBSTYLE_EX_HIDECLIPPEDBUTTONS = fromWord 0w16 - val TBSTYLE_EX_DOUBLEBUFFER = fromWord 0wx80*) - val BTNS_BUTTON = TBSTYLE_BUTTON - val BTNS_SEP = TBSTYLE_SEP - val BTNS_CHECK = TBSTYLE_CHECK - val BTNS_GROUP = TBSTYLE_GROUP - val BTNS_CHECKGROUP = TBSTYLE_CHECKGROUP - val BTNS_DROPDOWN = TBSTYLE_DROPDOWN - val BTNS_AUTOSIZE = TBSTYLE_AUTOSIZE - val BTNS_NOPREFIX = TBSTYLE_NOPREFIX - val BTNS_SHOWTEXT = fromWord 0wx0040 - val BTNS_WHOLEDROPDOWN = fromWord 0wx0080 - - val all = flags[Window.Style.all, TBSTYLE_BUTTON, TBSTYLE_SEP, TBSTYLE_CHECK, - TBSTYLE_GROUP, TBSTYLE_DROPDOWN, TBSTYLE_AUTOSIZE, TBSTYLE_NOPREFIX, - TBSTYLE_TOOLTIPS, TBSTYLE_WRAPABLE, TBSTYLE_ALTDRAG, TBSTYLE_FLAT, - TBSTYLE_LIST, TBSTYLE_CUSTOMERASE, TBSTYLE_TRANSPARENT, - BTNS_SHOWTEXT, BTNS_WHOLEDROPDOWN] - - val intersect = - List.foldl (fn (a, b) => fromWord(SysWord.andb(toWord a, toWord b))) all - end - - structure ToolbarState:> - sig - include BIT_FLAGS - val TBSTATE_CHECKED: flags and TBSTATE_PRESSED: flags and TBSTATE_ENABLED: flags - and TBSTATE_HIDDEN: flags and TBSTATE_INDETERMINATE: flags and TBSTATE_WRAP: flags - and TBSTATE_ELLIPSES: flags and TBSTATE_MARKED : flags - val cToolBarState: flags conversion (* Only used internally *) - end = - struct - open Word8 - type flags = Word8.word - val toWord = toLargeWord - and fromWord = fromLargeWord - val flags = List.foldl (fn (a, b) => orb(a,b)) 0w0 - fun allSet (fl1, fl2) = andb(fl1, fl2) = fl1 - fun anySet (fl1, fl2) = andb(fl1, fl2) <> 0w0 - fun clear (fl1, fl2) = andb(notb fl1, fl2) - - val TBSTATE_CHECKED = 0w1 - val TBSTATE_PRESSED = 0w2 - val TBSTATE_ENABLED = 0w4 - val TBSTATE_HIDDEN = 0w8 - val TBSTATE_INDETERMINATE = 0wx10 - val TBSTATE_WRAP = 0wx20 - val TBSTATE_ELLIPSES = 0wx40 - val TBSTATE_MARKED = 0wx80 - val all = flags[TBSTATE_CHECKED, TBSTATE_PRESSED, TBSTATE_ENABLED, TBSTATE_HIDDEN, - TBSTATE_INDETERMINATE, TBSTATE_WRAP, TBSTATE_ELLIPSES, TBSTATE_MARKED] - - val intersect = List.foldl (fn (a, b) => andb(a, b)) all - - val cToolBarState = cUint8w (*Must be a byte*) - end - - - datatype ToolbarResource = - ToolbarHandle of HBITMAP | ToolbarResource of HINSTANCE*Resource.RESID - - type TBBUTTON = { iBitmap: int, idCommand: int, fsState: ToolbarState.flags, - fsStyle: ToolbarStyle.flags, dwData: int, isString: int} - local - val TBBUTTON = - cStruct6(cInt, cInt, ToolbarState.cToolBarState(*byte*), cUint8w, cDWORD_PTR, cINT_PTR) - val {ctype={size=sizeTBB, ...}, ...} = breakConversion TBBUTTON - - val createToolbarEx = winCall13 (comctl "CreateToolbarEx") - (cHWND,cDWORDw,cUint,cInt,cHINSTANCE, cPointer ,cPointer,cInt,cInt,cInt,cInt,cInt,cUint) cHWND - val list2vec = list2Vector TBBUTTON - - in - fun CreateToolbarEx { relation: ParentType, style: ToolbarStyle.flags, nBitmaps: int, - bitmaps: ToolbarResource, buttons: TBBUTTON list, - xButton: int, yButton: int, xBitmap: int, yBitmap: int}: HWND = - let - (* This must be a child and WS_CHILD is included by default *) - val (parent, childId, styleWord) = - case relation of - ChildWindow{parent, id} => (parent, id, WinBase.Style.toWord style) - | _ => raise Fail "CreateToolbarEx: relation must be ChildWindow" - - fun mapToStruct({iBitmap, idCommand, fsState, fsStyle, dwData, isString}:TBBUTTON) = - (iBitmap, idCommand, fsState, Word8.fromLargeWord(ToolbarStyle.toWord fsStyle), dwData, isString) - - val (buttonVec, nButtons) = list2vec (map mapToStruct buttons) - (* The wBMID argument may be either a resource identifier or a bitmap handle. *) - val (hBMInst, wBMID, freeStr) = - case bitmaps of - ToolbarHandle hbm => (hinstanceNull, voidStarOfHandle hbm, Memory.null) - | ToolbarResource(hi, IdAsInt wb) => (hi, Memory.sysWord2VoidStar(SysWord.fromInt wb), Memory.null) - | ToolbarResource(hi, IdAsString str) => let val s = toCstring str in (hi, s, s) end - - val res = - createToolbarEx(parent, Word32.fromLargeWord styleWord, childId, nBitmaps, - hBMInst, wBMID, buttonVec, nButtons, xButton, yButton, xBitmap, yBitmap, - Word.toInt sizeTBB) - handle ex => (Memory.free freeStr; Memory.free buttonVec; raise ex) - val () = Memory.free freeStr and () = Memory.free buttonVec - in - checkResult(not(isHNull res)); - res - end - end - - local - val createStatusWindow = winCall4 (comctl "CreateStatusWindowA") (cLong,cString,cHWND,cUint) cHWND - in - fun CreateStatusWindow{ relation: ParentType, style: Window.Style.flags, text: string } = - let - val (parent, childId, styleWord) = - case relation of - ChildWindow{parent, id} => - let open WinBase.Style in (parent, id, toWord(flags[WS_CHILD, style])) end - | _ => raise Fail "CreateStatusWindow: relation must be ChildWindow" - val res = createStatusWindow(LargeWord.toInt styleWord, text, parent, childId) - in - checkResult(not(isHNull res)); - res - end - end - - val SB_SIMPLEID = 0x00ff - - structure StatusBarType: - sig - include BIT_FLAGS - val SBT_NOBORDERS: flags and SBT_OWNERDRAW: flags - and SBT_POPOUT: flags and SBT_RTLREADING : flags and SBT_TOOLTIPS: flags - end = - struct - type flags = SysWord.word - fun toWord f = f - fun fromWord f = f - val flags = List.foldl (fn (a, b) => SysWord.orb(a,b)) 0w0 - fun allSet (fl1, fl2) = SysWord.andb(fl1, fl2) = fl1 - fun anySet (fl1, fl2) = SysWord.andb(fl1, fl2) <> 0w0 - fun clear (fl1, fl2) = SysWord.andb(SysWord.notb fl1, fl2) - - val SBT_NOBORDERS = 0w256 - val SBT_OWNERDRAW = 0wx1000 - val SBT_POPOUT = 0w512 - val SBT_RTLREADING = 0w1024 - val SBT_TOOLTIPS = 0wx0800 - val all = flags[SBT_NOBORDERS, SBT_OWNERDRAW, SBT_POPOUT, SBT_RTLREADING, SBT_TOOLTIPS] - - val intersect = - List.foldl (fn (a, b) => fromWord(SysWord.andb(toWord a, toWord b))) all - end; - - val sendMsg = winCall4(user "SendMessageA") (cHWND, cUint, cUINT_PTR, cPointer) cUint - - fun StatusBarSetText{hWnd, iPart, uType, text}:int = - let - val s = toCstring text - val res = sendMsg(hWnd, 0x401, LargeWord.toInt(LargeWord.orb(LargeWord.fromInt iPart, StatusBarType.toWord uType)), s) - handle ex => (Memory.free s; raise ex) - val () = Memory.free s - in - res - end - - fun StatusBarGetText(hWnd, iPart): string * StatusBarType.flags = - let - val result1 = Word32.fromInt(sendMsg(hWnd, 0x403, iPart, Memory.null)) - val length = LOWORD result1 - val flags = StatusBarType.fromWord(Word.toLargeWord(HIWORD result1)) - in - if StatusBarType.anySet(flags, StatusBarType.SBT_OWNERDRAW) - then ("", flags) - else - let - open Memory - val buff = malloc (length+0w1) - val reply = - sendMsg(hWnd, 0x402, iPart, buff) - handle ex => (free buff; raise ex) - in - (if reply = 0 then "" else fromCstring buff, flags) before free buff - end - end - - fun StatusBarSetParts(hWnd, parts: int list): bool = - let - val (vec, nParts) = list2Vector cInt parts - open Memory - val res = sendMsg(hWnd, 0x404, nParts, vec) - handle ex => (free vec; raise ex) - val () = free vec - in - res <> 0 - end - - (* - - | compileMessage (SB_GETTEXT { iPart: int, text: string ref, length: int }) = - (* Another case, like LB_GETTEXT. where we don't know the length so we - add an extra argument to the ML message. *) - (0x402, toCint iPart, address(alloc (length+1) Cchar)*) - - -(* | compileMessage (SB_SETTEXT { iPart: int, uType: StatusBarType, text: string}) = - (0x401, toCint 0, toCstring text) - | compileMessage (SB_GETTEXT _) = (0x402, toCint 0, toCInt 0) - | compileMessage (SB_GETTEXTLENGTH _) = (0x403, toCint 0, toCInt 0) - | compileMessage (SB_SETPARTS _) = (0x404, toCint 0, toCInt 0) - | compileMessage (SB_GETPARTS _) = (0x406, toCint 0, toCInt 0) - | compileMessage (SB_GETBORDERS _) = (0x407, toCint 0, toCInt 0) - | compileMessage (SB_SETMINHEIGHT _) = (0x408, toCint 0, toCInt 0) - | compileMessage (SB_SIMPLE _) = (0x409, toCint 0, toCInt 0) - | compileMessage (SB_GETRECT _) = (0x40A, toCint 0, toCInt 0)*) - - end -end; diff --git a/mlsource/extra/Win/CommonDialog.sml b/mlsource/extra/Win/CommonDialog.sml deleted file mode 100644 index e0f4993f..00000000 --- a/mlsource/extra/Win/CommonDialog.sml +++ /dev/null @@ -1,1533 +0,0 @@ -(* - Copyright (c) 2001, 2015, 2019 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) -(* Common dialogues. *) -structure CommonDialog : - sig - type HWND and HDC and COLORREF = Color.COLORREF and HINSTANCE - type POINT = { x: int, y: int } - type RECT = { left: int, top: int, right: int, bottom: int } - - (* Error codes *) - datatype CDERR = - DIALOGFAILURE - | GENERALCODES - | STRUCTSIZE - | INITIALIZATION - | NOTEMPLATE - | NOHINSTANCE - | LOADSTRFAILURE - | FINDRESFAILURE - | LOADRESFAILURE - | LOCKRESFAILURE - | MEMALLOCFAILURE - | MEMLOCKFAILURE - | NOHOOK - | REGISTERMSGFAIL - - | PRINTERCODES - | SETUPFAILURE - | PARSEFAILURE - | RETDEFFAILURE - | LOADDRVFAILURE - | GETDEVMODEFAIL - | INITFAILURE - | NODEVICES - | NODEFAULTPRN - | DNDMMISMATCH - | CREATEICFAILURE - | PRINTERNOTFOUND - | DEFAULTDIFFERENT - - | CHOOSEFONTCODES - | NOFONTS - | MAXLESSTHANMIN - - | FILENAMECODES - | SUBCLASSFAILURE - | INVALIDFILENAME - | BUFFERTOOSMALL - - | FINDREPLACECODES - | BUFFERLENGTHZERO - - | CHOOSECOLORCODES - - val CommDlgExtendedError : unit -> CDERR - - (* ChooseColor *) -(* - structure ChooseColorFlags : - sig - include BIT_FLAGS - val CC_ANYCOLOR : flags - val CC_FULLOPEN : flags - val CC_PREVENTFULLOPEN : flags - val CC_RGBINIT : flags - val CC_SHOWHELP : flags - val CC_SOLIDCOLOR : flags - end - - type CHOOSECOLOR = - { - owner: HWND option, - result: COLORREF, - customColors: COLORREF list, - flags: ChooseColorFlags.flags - } - - val ChooseColor : CHOOSECOLOR -> CHOOSECOLOR option - - - (* ChooseFont *) - - structure ChooseFontFlags : - sig - include BIT_FLAGS - val CF_ANSIONLY : flags - val CF_APPLY : flags - val CF_BOTH : flags - val CF_EFFECTS : flags - val CF_FIXEDPITCHONLY : flags - val CF_FORCEFONTEXIST : flags - val CF_NOFACESEL : flags - val CF_NOOEMFONTS : flags - val CF_NOSCRIPTSEL : flags - val CF_NOSIMULATIONS : flags - val CF_NOSIZESEL : flags - val CF_NOSTYLESEL : flags - val CF_NOVECTORFONTS : flags - val CF_NOVERTFONTS : flags - val CF_PRINTERFONTS : flags - val CF_SCALABLEONLY : flags - val CF_SCREENFONTS : flags - val CF_SCRIPTSONLY : flags - val CF_SELECTSCRIPT : flags - val CF_SHOWHELP : flags - val CF_TTONLY : flags - val CF_WYSIWYG : flags - end - - structure ChooseFontTypes : - sig - include BIT_FLAGS - val BOLD_FONTTYPE : flags - val ITALIC_FONTTYPE : flags - val PRINTER_FONTTYPE : flags - val REGULAR_FONTTYPE : flags - val SCREEN_FONTTYPE : flags - val SIMULATED_FONTTYPE : flags - end - - type CHOOSEFONT = - { - owner: HWND option, - context: HDC option, - logFont: Font.LOGFONT option, - pointSize: int, - flags: ChooseFontFlags.flags, - colors: COLORREF, - style: string option, - fontType: ChooseFontTypes.flags, - size: {min: int, max: int} option - } - - val ChooseFont : CHOOSEFONT -> CHOOSEFONT option - *) - - (* FindText and ReplaceText *) - structure FindReplaceFlags : - sig - include BIT_FLAGS - val FR_DIALOGTERM : flags - val FR_DOWN : flags - val FR_FINDNEXT : flags - val FR_HIDEMATCHCASE : flags - val FR_HIDEUPDOWN : flags - val FR_HIDEWHOLEWORD : flags - val FR_MATCHCASE : flags - val FR_NOMATCHCASE : flags - val FR_NOUPDOWN : flags - val FR_NOWHOLEWORD : flags - val FR_REPLACE : flags - val FR_REPLACEALL : flags - val FR_SHOWHELP : flags - val FR_WHOLEWORD : flags - end - - datatype - TemplateType = - TemplateDefault - | TemplateHandle of Dialog.DLGTEMPLATE - | TemplateResource of HINSTANCE * Resource.RESID - - type FINDREPLACE = - { - owner : HWND, - template: TemplateType, - flags: FindReplaceFlags.flags, - findWhat: string, - replaceWith: string, - bufferSize: int - } - - val FindText : FINDREPLACE -> HWND - val ReplaceText : FINDREPLACE -> HWND - - - (* GetOpenFileName and GetSaveFileName *) - - structure OpenFileFlags : - sig - include BIT_FLAGS - val OFN_ALLOWMULTISELECT : flags - val OFN_CREATEPROMPT : flags - val OFN_EXPLORER : flags - val OFN_EXTENSIONDIFFERENT : flags - val OFN_FILEMUSTEXIST : flags - val OFN_HIDEREADONLY : flags - val OFN_LONGNAMES : flags - val OFN_NOCHANGEDIR : flags - val OFN_NODEREFERENCELINKS : flags - val OFN_NOLONGNAMES : flags - val OFN_NONETWORKBUTTON : flags - val OFN_NOREADONLYRETURN : flags - val OFN_NOTESTFILECREATE : flags - val OFN_NOVALIDATE : flags - val OFN_OVERWRITEPROMPT : flags - val OFN_PATHMUSTEXIST : flags - val OFN_READONLY : flags - val OFN_SHAREAWARE : flags - val OFN_SHOWHELP : flags - end - - type OPENFILENAME = - { - owner: HWND option, - template: TemplateType, - filter: (string * string) list, - customFilter: (string * string) option, - filterIndex: int, - file: string, (* Initial value of file and returned result. *) - maxFile: int, (* Max size of expected file name. *) - fileTitle : string, - initialDir: string option, - title: string option, (* Optional title - default is Save or Open. *) - flags: OpenFileFlags.flags, - defExt: string option - } - - val GetFileTitle : string -> string - val GetOpenFileName : OPENFILENAME -> OPENFILENAME option - val GetSaveFileName : OPENFILENAME -> OPENFILENAME option - - (* PageSetupDlg *) - structure PageSetupFlags : - sig - include BIT_FLAGS - val PSD_DEFAULTMINMARGINS : flags - val PSD_DISABLEMARGINS : flags - val PSD_DISABLEORIENTATION : flags - val PSD_DISABLEPAGEPAINTING : flags - val PSD_DISABLEPAPER : flags - val PSD_DISABLEPRINTER : flags - val PSD_INHUNDREDTHSOFMILLIMETERS : flags - val PSD_INTHOUSANDTHSOFINCHES : flags - val PSD_MARGINS : flags - val PSD_MINMARGINS : flags - val PSD_NONETWORKBUTTON : flags - val PSD_NOWARNING : flags - val PSD_RETURNDEFAULT : flags - val PSD_SHOWHELP : flags - end - - type PAGESETUPDLG = - { - owner: HWND option, - devMode: DeviceContext.DEVMODE option, - devNames: DeviceContext.DEVNAMES option, - flags: PageSetupFlags.flags, - paperSize: POINT, - minMargin: RECT, - margin: RECT - (* For the moment we ignore the other options. *) - } - - val PageSetupDlg : PAGESETUPDLG -> PAGESETUPDLG option - - (* PrintDlg *) - structure PrintDlgFlags : - sig - include BIT_FLAGS - val PD_ALLPAGES : flags - val PD_COLLATE : flags - val PD_DISABLEPRINTTOFILE : flags - val PD_HIDEPRINTTOFILE : flags - val PD_NONETWORKBUTTON : flags - val PD_NOPAGENUMS : flags - val PD_NOSELECTION : flags - val PD_NOWARNING : flags - val PD_PAGENUMS : flags - val PD_PRINTSETUP : flags - val PD_PRINTTOFILE : flags - val PD_RETURNDC : flags - val PD_RETURNDEFAULT : flags - val PD_RETURNIC : flags - val PD_SELECTION : flags - val PD_SHOWHELP : flags - val PD_USEDEVMODECOPIES : flags - val PD_USEDEVMODECOPIESANDCOLLATE : flags - end - - type PRINTDLG = - { - owner: HWND option, - devMode: DeviceContext.DEVMODE option, - devNames: DeviceContext.DEVNAMES option, - context: HDC option, - flags: PrintDlgFlags.flags, - fromPage: int, - toPage: int, - minPage: int, - maxPage: int, - copies: int - (* For the moment we ignore the other options. *) - } - - val PrintDlg : PRINTDLG -> PRINTDLG option - end - = -struct - local - open Foreign - open Globals - open Base - open DeviceContext Color Font GdiBase - - val stringToBuf = copyStringToMem - - fun allocAndInitialise(space: int, str: string) = - let - open Memory - val space = Int.max(space, size str) + 1 - val buf = malloc(Word.fromInt space) - in - stringToBuf(buf, 0, str); - buf - end - - in - type HWND = HWND and HDC = HDC and COLORREF = COLORREF and HINSTANCE = HINSTANCE - type RECT = RECT and POINT = POINT - - datatype CDERR = - DIALOGFAILURE (* 0xffff *) - | GENERALCODES (* 0x0000 *) - | STRUCTSIZE (* 0x0001 *) - | INITIALIZATION (* 0x0002 *) - | NOTEMPLATE (* 0x0003 *) - | NOHINSTANCE (* 0x0004 *) - | LOADSTRFAILURE (* 0x0005 *) - | FINDRESFAILURE (* 0x0006 *) - | LOADRESFAILURE (* 0x0007 *) - | LOCKRESFAILURE (* 0x0008 *) - | MEMALLOCFAILURE (* 0x0009 *) - | MEMLOCKFAILURE (* 0x000A *) - | NOHOOK (* 0x000B *) - | REGISTERMSGFAIL (* 0x000C *) - - | PRINTERCODES (* 0x1000 *) - | SETUPFAILURE (* 0x1001 *) - | PARSEFAILURE (* 0x1002 *) - | RETDEFFAILURE (* 0x1003 *) - | LOADDRVFAILURE (* 0x1004 *) - | GETDEVMODEFAIL (* 0x1005 *) - | INITFAILURE (* 0x1006 *) - | NODEVICES (* 0x1007 *) - | NODEFAULTPRN (* 0x1008 *) - | DNDMMISMATCH (* 0x1009 *) - | CREATEICFAILURE (* 0x100A *) - | PRINTERNOTFOUND (* 0x100B *) - | DEFAULTDIFFERENT (* 0x100C *) - - | CHOOSEFONTCODES (* 0x2000 *) - | NOFONTS (* 0x2001 *) - | MAXLESSTHANMIN (* 0x2002 *) - - | FILENAMECODES (* 0x3000 *) - | SUBCLASSFAILURE (* 0x3001 *) - | INVALIDFILENAME (* 0x3002 *) - | BUFFERTOOSMALL (* 0x3003 *) - - | FINDREPLACECODES (* 0x4000 *) - | BUFFERLENGTHZERO (* 0x4001 *) - - | CHOOSECOLORCODES (* 0x5000 *) - - - local - val commDlgExtendedError = winCall0 (commdlg "CommDlgExtendedError") () cDWORD - in - fun CommDlgExtendedError () = - case commDlgExtendedError () of - 0x0000 => GENERALCODES - | 0x0001 => STRUCTSIZE - - | 0x0002 => INITIALIZATION - | 0x0003 => NOTEMPLATE - | 0x0004 => NOHINSTANCE - | 0x0005 => LOADSTRFAILURE - | 0x0006 => FINDRESFAILURE - | 0x0007 => LOADRESFAILURE - | 0x0008 => LOCKRESFAILURE - | 0x0009 => MEMALLOCFAILURE - | 0x000A => MEMLOCKFAILURE - | 0x000B => NOHOOK - | 0x000C => REGISTERMSGFAIL - - | 0x1000 => PRINTERCODES - | 0x1001 => SETUPFAILURE - | 0x1002 => PARSEFAILURE - | 0x1003 => RETDEFFAILURE - | 0x1004 => LOADDRVFAILURE - | 0x1005 => GETDEVMODEFAIL - | 0x1006 => INITFAILURE - | 0x1007 => NODEVICES - | 0x1008 => NODEFAULTPRN - | 0x1009 => DNDMMISMATCH - | 0x100A => CREATEICFAILURE - | 0x100B => PRINTERNOTFOUND - | 0x100C => DEFAULTDIFFERENT - - | 0x2000 => CHOOSEFONTCODES - | 0x2001 => NOFONTS - | 0x2002 => MAXLESSTHANMIN - - | 0x3000 => FILENAMECODES - | 0x3001 => SUBCLASSFAILURE - | 0x3002 => INVALIDFILENAME - | 0x3003 => BUFFERTOOSMALL - - | 0x4000 => FINDREPLACECODES - | 0x4001 => BUFFERLENGTHZERO - | _ => DIALOGFAILURE - end; - - (* As always there are a number of ways of matching the C types to - ML. Since functions such as GetOpenFileName update their - parameters, probably the easiest way to deal with them is - as functions which return an updated parameter set. *) - datatype TemplateType = - TemplateHandle of Dialog.DLGTEMPLATE - | TemplateResource of HINSTANCE * Resource.RESID - | TemplateDefault - - structure OpenFileFlags:> - sig - include BIT_FLAGS - val OFN_ALLOWMULTISELECT : flags - val OFN_CREATEPROMPT : flags - val OFN_EXPLORER : flags - val OFN_EXTENSIONDIFFERENT : flags - val OFN_FILEMUSTEXIST : flags - val OFN_HIDEREADONLY : flags - val OFN_LONGNAMES : flags - val OFN_NOCHANGEDIR : flags - val OFN_NODEREFERENCELINKS : flags - val OFN_NOLONGNAMES : flags - val OFN_NONETWORKBUTTON : flags - val OFN_NOREADONLYRETURN : flags - val OFN_NOTESTFILECREATE : flags - val OFN_NOVALIDATE : flags - val OFN_OVERWRITEPROMPT : flags - val OFN_PATHMUSTEXIST : flags - val OFN_READONLY : flags - val OFN_SHAREAWARE : flags - val OFN_SHOWHELP : flags - - val cConvert: flags conversion - end - = - struct - open Word32 - type flags = word - val toWord = toLargeWord - and fromWord = fromLargeWord - val flags = List.foldl (fn (a, b) => orb(a,b)) 0w0 - fun allSet (fl1, fl2) = andb(fl1, fl2) = fl1 - fun anySet (fl1, fl2) = andb(fl1, fl2) <> 0w0 - fun clear (fl1, fl2) = andb(notb fl1, fl2) - - val OFN_READONLY = 0wx00000001 - val OFN_OVERWRITEPROMPT = 0wx00000002 - val OFN_HIDEREADONLY = 0wx00000004 - val OFN_NOCHANGEDIR = 0wx00000008 - val OFN_SHOWHELP = 0wx00000010 - val OFN_NOVALIDATE = 0wx00000100 - val OFN_ALLOWMULTISELECT = 0wx00000200 - val OFN_EXTENSIONDIFFERENT = 0wx00000400 - val OFN_PATHMUSTEXIST = 0wx00000800 - val OFN_FILEMUSTEXIST = 0wx00001000 - val OFN_CREATEPROMPT = 0wx00002000 - val OFN_SHAREAWARE = 0wx00004000 - val OFN_NOREADONLYRETURN = 0wx00008000 - val OFN_NOTESTFILECREATE = 0wx00010000 - val OFN_NONETWORKBUTTON = 0wx00020000 - val OFN_NOLONGNAMES = 0wx00040000 (* force no long names for 4.x modules*) - val OFN_EXPLORER = 0wx00080000 (* new look commdlg*) - val OFN_NODEREFERENCELINKS = 0wx00100000 - val OFN_LONGNAMES = 0wx00200000 (* force long names for 3.x modules*) - - val all = flags[OFN_READONLY, OFN_OVERWRITEPROMPT, OFN_HIDEREADONLY, - OFN_NOCHANGEDIR, OFN_SHOWHELP, - OFN_NOVALIDATE, OFN_ALLOWMULTISELECT, OFN_EXTENSIONDIFFERENT, - OFN_PATHMUSTEXIST, OFN_FILEMUSTEXIST, OFN_CREATEPROMPT, - OFN_SHAREAWARE, OFN_NOREADONLYRETURN, OFN_NOTESTFILECREATE, - OFN_NONETWORKBUTTON, OFN_NOLONGNAMES, OFN_EXPLORER, - OFN_NODEREFERENCELINKS, OFN_LONGNAMES] - - val intersect = List.foldl (fn (a, b) => andb(a,b)) all - - val cConvert = cDWORDw - end - - (* These flags are local only. *) - (*val OFN_ENABLEHOOK = OpenFileFlags.fromWord 0wx00000020 *) - val OFN_ENABLETEMPLATE = OpenFileFlags.fromWord 0wx00000040 - val OFN_ENABLETEMPLATEHANDLE = OpenFileFlags.fromWord 0wx00000080 - - type OPENFILENAME = - { - owner: HWND option, - template: TemplateType, - filter: (string * string) list, - customFilter: (string * string) option, - filterIndex: int, - file: string, (* Initial value of file and returned result. *) - maxFile: int, (* Max size of expected file name. *) - fileTitle : string, - initialDir: string option, - title: string option, (* Optional title - default is Save or Open. *) - flags: OpenFileFlags.flags, - defExt: string option - } - - local - val OPENFILENAME = - cStruct20(cDWORD, cHWNDOPT, cPointer (*HINSTANCE*), cPointer (* LPCTSTR*), cPointer (*LPTSTR*), - cDWORD, cDWORD, cPointer (*LPTSTR*), cDWORD, cPointer (*LPTSTR*), cDWORD, STRINGOPT, STRINGOPT, - OpenFileFlags.cConvert, cWORD, cWORD, STRINGOPT, cLPARAM, cPointer (* LPOFNHOOKPROC *), - cPointer (* LPCTSTR*) (* cPointer, DWORD, DWORD*)) - val {load=loadOFN, store=fromOFN, ctype={size=sizeOfnStruct, ...}, ...} = breakConversion OPENFILENAME - - fun getOpenSave doCall (arg: OPENFILENAME): OPENFILENAME option = - let - val { - owner: HWND option, - template: TemplateType, - filter: (string * string) list, - customFilter: (string * string) option, - filterIndex: int, - file: string, - maxFile: int, - fileTitle : string, - initialDir: string option, - title: string option, - flags: OpenFileFlags.flags, - defExt: string option, ...} = arg - open Memory - infix 6 ++ - val (f1, inst, templ, toFree) = - case template of - TemplateHandle dlgTemp => - let - val dlg = toCWord8vec(Dialog.compileTemplate dlgTemp) - in - (OFN_ENABLETEMPLATEHANDLE, dlg, null, dlg) - end - | TemplateResource(hInst, IdAsInt wb) => - ( - OFN_ENABLETEMPLATE, - voidStarOfHandle hInst, - Memory.sysWord2VoidStar(SysWord.fromInt wb), - null - ) - | TemplateResource(hInst, IdAsString str) => - let - val s = toCstring str - in - (OFN_ENABLETEMPLATE, voidStarOfHandle hInst, s, s) - end - | TemplateDefault => (OpenFileFlags.fromWord 0w0, null, null, null) - - val lpstrFilter = - case filter of - nil => Memory.null - | _ => - let - (* The filter strings are pairs of strings with a final - terminating null. That implies that the strings cannot be empty. - Should we check that? - Get the store needed for the strings, including the null - terminations and the final null. *) - val filterSize = - List.foldl (fn((s1,s2),n) => size s1 + size s2 + n + 2) 1 filter - open Memory - infix 6 ++ - val buf = malloc (Word.fromInt filterSize) - - fun copyToBuf((s1,s2), n) = - let - val ss1 = size s1 and ss2 = size s2 - in - stringToBuf(buf, n, s1); - stringToBuf(buf, n+ss1+1, s2); - n+ss1+ss2+2 (* Result is the next offset. *) - end - - val lastAddr = List.foldl copyToBuf 0 filter - val _ = set8(buf, Word.fromInt lastAddr, 0w0) - in - buf - end - - val (lpstrCustomFilter, nMaxCustFilter) = - case customFilter of - NONE => (null, 0) - | SOME (dispString, pattern) => - let - (* Make sure we have enough space. 100 is probably big enough. *) - val space = Int.max(size dispString + size pattern + 2, 100) - val buf = Memory.malloc(Word.fromInt space) - in - stringToBuf(buf, 0, dispString); - stringToBuf(buf, size dispString + 1, pattern); - (buf, space) - end - - val lpstrFile = (* Full name of file including path. *) - allocAndInitialise(maxFile, file) - val lpstrFileTitle = (* Name excluding the path. *) - allocAndInitialise(maxFile, fileTitle) - - val ofn = malloc sizeOfnStruct - val args = (Word.toInt sizeOfnStruct, (* lStructSize *) - owner, (* hwndOwner *) - inst, (* hInstance *) - lpstrFilter, - lpstrCustomFilter, - nMaxCustFilter, - filterIndex, - lpstrFile, - maxFile+1, (* nMaxFile *) - lpstrFileTitle, - maxFile+1, (* nMaxFileTitle *) - initialDir, - title, - OpenFileFlags.flags[f1, flags], (* Flags *) - 0, (* nFileOffset *) - 0, (* nFileExtension *) - defExt, - 0, (* lCustData *) - null, (* lpfnHook *) - templ) (* lpTemplateName *) - val freeOfn = fromOFN(ofn, args) (* Copy into the memory *) - fun freeAll() = - ( - freeOfn(); - List.app free [ofn, toFree, lpstrFilter, lpstrCustomFilter, lpstrFile, lpstrFileTitle] - ) - val result = - doCall ofn handle ex => (freeAll(); raise ex) - in - (if result - then - let - (* Most of the fields are unchanged so we're better off extracting - them from the original. If we've passed in a template we have - to get it from the original because we can only convert a - memory object to a Word8Vector.vector if we know its length. *) - - val (_, _, _, _, lpstrCustomFilter, _, nFilterIndex, lpstrFile, - _, lpstrFileTitle, _, _, _, flagBits, _, _, _, _, _, _) = loadOFN ofn - - val customFilter = - if lpstrCustomFilter = null - then NONE - else - let - (* The dialogue box copies the selected filter into the section of - this string after the first string. *) - val s1 = fromCstring lpstrCustomFilter - val s2 = fromCstring (lpstrCustomFilter ++ Word.fromInt(size s1 +1)) - in - SOME(s1, s2) - end - in - SOME - { - owner = owner, - template = template, - filter = filter, - customFilter = customFilter, - filterIndex = nFilterIndex, - file = fromCstring lpstrFile, - maxFile = maxFile, - fileTitle = fromCstring lpstrFileTitle, - initialDir = initialDir, - title = title, - (* Mask off the template flags. *) - flags = let open OpenFileFlags in clear(fromWord 0wxE0, flagBits) end, - defExt = defExt - } - end - else NONE) before freeAll() - end - - in - val GetOpenFileName = - getOpenSave (winCall1 (commdlg "GetOpenFileNameA") cPointer cBool) - and GetSaveFileName = - getOpenSave (winCall1 (commdlg "GetSaveFileNameA") cPointer cBool) - end (* local *) - - local - val getFileTitle = winCall3(commdlg "GetFileTitleA") (cString, cPointer, cWORD) cShort - in - fun GetFileTitle(file: string): string = - let - fun gft (m, n) = getFileTitle(file, m, n) - in - getStringWithNullIsLength gft - end - end - - (* This is a bit messy. It creates a modeless dialogue box - and sends messages to the parent window. The only problem is that - the message identifier is not a constant. It has to be obtained - by a call to RegisterWindowMessage. *) - (* We also have to ensure that the memory containing the FINDREPLACE - structure is not freed until the dialogue window is destroyed. *) - - structure FindReplaceFlags = FindReplaceFlags - - (* These flags are local only. *) - (*val FR_ENABLEHOOK = FindReplaceFlags.fromWord 0wx00000100*) - val FR_ENABLETEMPLATE = FindReplaceFlags.fromWord 0wx00000200 - val FR_ENABLETEMPLATEHANDLE = FindReplaceFlags.fromWord 0wx00002000 - - (* The address of this structure is passed in messages. That all looks - extremely messy. *) - type FINDREPLACE = - { - owner : HWND, (* NOT an option. *) - template: TemplateType, - flags: FindReplaceFlags.flags, - findWhat: string, - replaceWith: string, - bufferSize: int - } - - local - val FINDREPLACE = - cStruct11(cDWORD, cHWND, cPointer (*HINSTANCE*), FindReplaceFlags.cFindReplaceFlags, - cPointer, cPointer, cWORD, cWORD, cLPARAM, cPointer (* LPFRHOOKPROC *), cPointer) - val {store=fromOFR, ctype={size=sizeFR, ...}, ...} = breakConversion FINDREPLACE - - val findText = winCall1 (commdlg "FindTextA") cPointer cHWND - and replaceText = winCall1 (commdlg "ReplaceTextA") cPointer cHWND - - fun findReplace doCall (arg: FINDREPLACE): HWND = - let - val { - owner : HWND, (* NOT an option. *) - template: TemplateType, - flags: FindReplaceFlags.flags, - findWhat: string, - replaceWith: string, - bufferSize: int - } = arg - open Memory - val (f1, inst, templ, toFree) = - case template of - TemplateHandle dlgTemp => - let - val dlg = toCWord8vec(Dialog.compileTemplate dlgTemp) - in - (FR_ENABLETEMPLATEHANDLE, dlg, null, dlg) - end - | TemplateResource(hInst, IdAsInt wb) => - ( - FR_ENABLETEMPLATE, - voidStarOfHandle hInst, - Memory.sysWord2VoidStar(SysWord.fromInt wb), - null - ) - | TemplateResource(hInst, IdAsString str) => - let - val s = toCstring str - in - (FR_ENABLETEMPLATE, voidStarOfHandle hInst, s, s) - end - | TemplateDefault => (FindReplaceFlags.fromWord 0w0, null, null, null) - val lpstrFindWhat = allocAndInitialise(bufferSize, findWhat) - val lpstrReplaceWith = allocAndInitialise(bufferSize, replaceWith) - val m = malloc sizeFR - val args = - (Word.toInt sizeFR, (* lStructSize *) - owner, (* hwndOwner *) - inst, (* hInstance *) - FindReplaceFlags.flags[f1, flags], (* Flags *) - lpstrFindWhat, - lpstrReplaceWith, - bufferSize, - bufferSize, - 0, (* lCustData *) - null, (* lpfnHook *) - templ) (* lpTemplateName *) - val freeOfr = fromOFR(m, args) - fun freeAll() = - ( - freeOfr(); - List.app free [m, toFree, lpstrFindWhat, lpstrReplaceWith] - ) - val result = doCall m handle ex => (freeAll(); raise ex) - val () = - checkResult(not(isHNull result)) handle ex => (freeAll(); raise ex) - in - (* The memory cannot be released until the dialogue is dismissed. Also, - since this is a modeless dialogue we have to add it to the modeless - dialogue list so that keyboard functions work. *) - (* TODO: There may be better ways of ensuring the memory is freed. *) - (Message.addModelessDialogue(result, SOME freeAll); result) - end - in - val FindText = findReplace findText - and ReplaceText = findReplace replaceText - end - - structure PageSetupFlags :> - sig - include BIT_FLAGS - val PSD_DEFAULTMINMARGINS : flags - val PSD_DISABLEMARGINS : flags - val PSD_DISABLEORIENTATION : flags - val PSD_DISABLEPAGEPAINTING : flags - val PSD_DISABLEPAPER : flags - val PSD_DISABLEPRINTER : flags - val PSD_INHUNDREDTHSOFMILLIMETERS : flags - val PSD_INTHOUSANDTHSOFINCHES : flags - val PSD_MARGINS : flags - val PSD_MINMARGINS : flags - val PSD_NONETWORKBUTTON : flags - val PSD_NOWARNING : flags - val PSD_RETURNDEFAULT : flags - val PSD_SHOWHELP : flags - val cConvert: flags conversion - end - = - struct - open Word32 - type flags = word - val toWord = toLargeWord - and fromWord = fromLargeWord - val flags = List.foldl (fn (a, b) => orb(a,b)) 0w0 - fun allSet (fl1, fl2) = andb(fl1, fl2) = fl1 - fun anySet (fl1, fl2) = andb(fl1, fl2) <> 0w0 - fun clear (fl1, fl2) = andb(notb fl1, fl2) - - val PSD_DEFAULTMINMARGINS = 0wx00000000 (* default (printer's) *) - (*val PSD_INWININIINTLMEASURE = 0wx00000000 *)(* 1st of 4 possible *) - - val PSD_MINMARGINS = 0wx00000001 (* use caller's *) - val PSD_MARGINS = 0wx00000002 (* use caller's *) - val PSD_INTHOUSANDTHSOFINCHES = 0wx00000004 (* 2nd of 4 possible *) - val PSD_INHUNDREDTHSOFMILLIMETERS = 0wx00000008 (* 3rd of 4 possible *) - val PSD_DISABLEMARGINS = 0wx00000010 - val PSD_DISABLEPRINTER = 0wx00000020 - val PSD_NOWARNING = 0wx00000080 - val PSD_DISABLEORIENTATION = 0wx00000100 - val PSD_RETURNDEFAULT = 0wx00000400 - val PSD_DISABLEPAPER = 0wx00000200 - val PSD_SHOWHELP = 0wx00000800 - (* - val PSD_ENABLEPAGESETUPHOOK = 0wx00002000 - val PSD_ENABLEPAGESETUPTEMPLATE = 0wx00008000 - val PSD_ENABLEPAGESETUPTEMPLATEHANDLE = 0wx00020000 - val PSD_ENABLEPAGEPAINTHOOK = 0wx00040000 *) - - val PSD_DISABLEPAGEPAINTING = 0wx00080000 - val PSD_NONETWORKBUTTON = 0wx00200000 - - val all = flags[PSD_DEFAULTMINMARGINS, PSD_MINMARGINS, PSD_MARGINS, - PSD_INTHOUSANDTHSOFINCHES, PSD_INHUNDREDTHSOFMILLIMETERS, - PSD_DISABLEMARGINS, PSD_DISABLEPRINTER, PSD_NOWARNING, - PSD_DISABLEORIENTATION, PSD_RETURNDEFAULT, PSD_DISABLEPAPER, - PSD_SHOWHELP, PSD_DISABLEPAGEPAINTING, PSD_NONETWORKBUTTON] - - val intersect = List.foldl (fn (a, b) => andb(a,b)) all - - val cConvert = cDWORDw - end - - structure PrintDlgFlags :> - sig - include BIT_FLAGS - val PD_ALLPAGES : flags - val PD_COLLATE : flags - val PD_DISABLEPRINTTOFILE : flags - val PD_HIDEPRINTTOFILE : flags - val PD_NONETWORKBUTTON : flags - val PD_NOPAGENUMS : flags - val PD_NOSELECTION : flags - val PD_NOWARNING : flags - val PD_PAGENUMS : flags - val PD_PRINTSETUP : flags - val PD_PRINTTOFILE : flags - val PD_RETURNDC : flags - val PD_RETURNDEFAULT : flags - val PD_RETURNIC : flags - val PD_SELECTION : flags - val PD_SHOWHELP : flags - val PD_USEDEVMODECOPIES : flags - val PD_USEDEVMODECOPIESANDCOLLATE : flags - val cConvert: flags conversion - end - = - struct - open Word32 - type flags = word - val toWord = toLargeWord - and fromWord = fromLargeWord - val flags = List.foldl (fn (a, b) => orb(a,b)) 0w0 - fun allSet (fl1, fl2) = andb(fl1, fl2) = fl1 - fun anySet (fl1, fl2) = andb(fl1, fl2) <> 0w0 - fun clear (fl1, fl2) = andb(notb fl1, fl2) - - val PD_ALLPAGES = 0wx00000000 - val PD_SELECTION = 0wx00000001 - val PD_PAGENUMS = 0wx00000002 - val PD_NOSELECTION = 0wx00000004 - val PD_NOPAGENUMS = 0wx00000008 - val PD_COLLATE = 0wx00000010 - val PD_PRINTTOFILE = 0wx00000020 - val PD_PRINTSETUP = 0wx00000040 - val PD_NOWARNING = 0wx00000080 - val PD_RETURNDC = 0wx00000100 - val PD_RETURNIC = 0wx00000200 - val PD_RETURNDEFAULT = 0wx00000400 - val PD_SHOWHELP = 0wx00000800 - (*val PD_ENABLEPRINTHOOK = 0wx00001000 - val PD_ENABLESETUPHOOK = 0wx00002000 - val PD_ENABLEPRINTTEMPLATE = 0wx00004000 - val PD_ENABLESETUPTEMPLATE = 0wx00008000 - val PD_ENABLEPRINTTEMPLATEHANDLE = 0wx00010000 - val PD_ENABLESETUPTEMPLATEHANDLE = 0wx00020000 *) - val PD_USEDEVMODECOPIES = 0wx00040000 - val PD_USEDEVMODECOPIESANDCOLLATE = 0wx00040000 - val PD_DISABLEPRINTTOFILE = 0wx00080000 - val PD_HIDEPRINTTOFILE = 0wx00100000 - val PD_NONETWORKBUTTON = 0wx00200000 - - - val all = flags[PD_ALLPAGES, PD_SELECTION, PD_PAGENUMS, PD_NOSELECTION, PD_NOPAGENUMS, - PD_COLLATE, PD_PRINTTOFILE, PD_PRINTSETUP, PD_NOWARNING, PD_RETURNDC, - PD_RETURNIC, PD_RETURNDEFAULT, PD_SHOWHELP, PD_USEDEVMODECOPIES, - PD_USEDEVMODECOPIESANDCOLLATE, PD_DISABLEPRINTTOFILE, - PD_HIDEPRINTTOFILE, PD_NONETWORKBUTTON] - - val intersect = List.foldl (fn (a, b) => andb(a,b)) all - - val cConvert = cDWORDw - end - - type PAGESETUPDLG = - { - owner: HWND option, - devMode: DEVMODE option, - devNames: DEVNAMES option, - flags: PageSetupFlags.flags, - paperSize: POINT, - minMargin: RECT, - margin: RECT - (* For the moment we ignore the other options. *) - } - - type PRINTDLG = - { - owner: HWND option, - devMode: DEVMODE option, - devNames: DEVNAMES option, - context: HDC option, - flags: PrintDlgFlags.flags, - fromPage: int, - toPage: int, - minPage: int, - maxPage: int, - copies: int - (* For the moment we ignore the other options. *) - } - - local - (* A DEVNAMES structure is a structure containing offsets followed by - the actual strings. *) - val DEVNAMES = cStruct4(cWORD, cWORD, cWORD, cWORD) - val {load=toDN, store=fromDN, ctype={size=sizeDevN, ...}, ...} = breakConversion DEVNAMES - val DN_DEFAULTPRN = 0x0001 - - (* Allocate global memory for the devnames if necessary *) - fun toDevNames NONE = hNull - | toDevNames (SOME{driver, device, output, default}) = - let - (* We need memory for the DEVNAMES structure plus the strings plus - their terminating nulls. *) - val devnameSize = Word.toInt sizeDevN - val sizeDriver = size driver - and sizeDevice = size device - and sizeOutput = size output - val space = devnameSize + sizeDriver + sizeDevice + sizeOutput + 3 - val mHandle = GlobalAlloc(0, space) - val buff = GlobalLock mHandle - (* Copy in the strings and calculate the next offset. *) - open Memory - infix 6 ++ - fun copyString b str = - ( - stringToBuf(b, 0, str); - b ++ Word.fromInt(size str+1) - ); - val off1 = copyString (buff ++ sizeDevN) driver; - val off2 = copyString off1 device - val _ = copyString off2 output - in - ignore(fromDN(buff, (devnameSize, devnameSize+sizeDriver+1, - devnameSize+sizeDriver+sizeDevice+2, - if default then DN_DEFAULTPRN else 0))); - GlobalUnlock mHandle; - mHandle - end - - (* Convert a DevNames structure. *) - fun fromDevNames v = - if isHNull v then NONE - else - let - val buff = GlobalLock v - val (off0, off1, off2, def) = toDN buff - open Memory - infix 6 ++ - val driver = fromCstring(buff ++ Word.fromInt off0) - val device = fromCstring(buff ++ Word.fromInt off1) - val output = fromCstring(buff ++ Word.fromInt off2) - val default = Word.andb(Word.fromInt def, Word.fromInt DN_DEFAULTPRN) <> 0w0 - in - GlobalUnlock v; - SOME {driver=driver, device=device, output=output, default=default} - end - - val PAGESETUPDLG = - cStruct14(cDWORD, cHWNDOPT, cHGLOBAL, cHGLOBAL, PageSetupFlags.cConvert, cPoint, - cRect, cRect, cHINSTANCE, cLPARAM, cPointer, cPointer, cPointer, cPointer) - val {load=toPSD, store=fromPSD, ctype={size=sizePageSD, ...}, ...} = breakConversion PAGESETUPDLG - - (* This is a bit of a mess. It seems that it uses structure packing on 32-bits - which means that the fields after the five shorts are not aligned onto - 4-byte boundaries. We currently don't use them so we just define this as - the structure as far as we use it and set the length explicitly. - This problem doesn't arise with PrintDlgEx so that might be preferable. *) - val PRINTDLG = cStruct11(cDWORD, cHWNDOPT, cHGLOBAL, cHGLOBAL, cHDC, PrintDlgFlags.cConvert, cWORD, - cWORD, cWORD, cWORD, cWORD) - val {load=toPRD, store=fromPRD, ...} = breakConversion PRINTDLG - val printDlgSize = - if #size LowLevel.cTypePointer = 0w4 then 0w66 else 0w120 - - val pageSetupDlg = winCall1 (commdlg "PageSetupDlgA") cPointer cBool - and printDlg = winCall1 (commdlg "PrintDlgA") cPointer cBool - in - fun PageSetupDlg (arg: PAGESETUPDLG): PAGESETUPDLG option = - let - val { - owner: HWND option, - devMode: DEVMODE option, - devNames: {driver: string, device: string, output: string, default: bool} option, - flags: PageSetupFlags.flags, - paperSize: POINT, - minMargin: RECT, - margin: RECT} = arg - val devnames = toDevNames devNames - val devmode = - case devMode of - NONE => hNull - | SOME dv => - let - (* This has to be in global memory *) - open DeviceBase - val hGlob = GlobalAlloc(0, Word.toInt(devModeSize dv)) - val mem = GlobalLock hGlob - val () = setCDevMode(mem, dv) - in - GlobalUnlock hGlob; - hGlob - end - open Memory - val mem = malloc sizePageSD - val str = (Word.toInt sizePageSD, owner, devmode, devnames, flags, - paperSize, minMargin, margin, hinstanceNull, 0, null, null, null, null) - val freePsd = fromPSD(mem, str) (* Set the PAGESETUPDLG struct *) - - fun freeAll() = - let - (* We can only free the handles after we've reloaded them. *) - val (_, _, hgDevMode, hgDevNames, _, _, _, _, _, _, _, _, _, _) = toPSD mem - in - if isHNull hgDevNames then () else ignore(GlobalFree hgDevNames); - if isHNull hgDevMode then () else ignore(GlobalFree hgDevMode); - free mem; freePsd() - end - - val result = pageSetupDlg mem handle ex => (freeAll(); raise ex) - val (_, owner, hgDevMode, hgDevNames, flags, paperSize, minMargin, margin, - _, _, _, _, _, _) = toPSD mem - val devMode = - if isHNull hgDevMode - then NONE - else - let - val r = SOME(DeviceBase.getCDevMode(GlobalLock hgDevMode)) - in - GlobalUnlock hgDevMode; - r - end; - val devNames = fromDevNames hgDevNames - val newArg = - { owner = owner, devMode = devMode, devNames = devNames, - flags = flags, - paperSize = paperSize, minMargin = minMargin, margin = margin } - val () = freeAll() - in - if result - then SOME newArg - else NONE - end - - and PrintDlg (arg: PRINTDLG): PRINTDLG option = - let - val { - owner: HWND option, - devMode: DEVMODE option, - devNames: {driver: string, device: string, output: string, default: bool} option, - context: HDC option, - flags: PrintDlgFlags.flags, - fromPage: int, - toPage: int, - minPage: int, - maxPage: int, - copies: int} = arg - val devnames = toDevNames devNames - val devmode = - case devMode of - NONE => hNull - | SOME dv => - let - (* This has to be in global memory *) - open DeviceBase - val hGlob = GlobalAlloc(0, Word.toInt(devModeSize dv)) - val mem = GlobalLock hGlob - val () = setCDevMode(mem, dv) - in - GlobalUnlock hGlob; - hGlob - end - open Memory - val mem = malloc printDlgSize - (* Since we're not going to set all of it we need to zero it. *) - local - fun zero n = if n = printDlgSize then () else (set8(mem, n, 0w0); zero(n+0w1)) - in - val () = zero 0w0 - end - val freePRD = - fromPRD(mem, (Word.toInt printDlgSize, owner, devmode, devnames, getOpt(context, hdcNull), - flags, fromPage, toPage, minPage, maxPage, copies)) - - fun freeAll() = - let - (* We can only free the handles after we've reloaded them. *) - val (_, _, hgDevMode, hgDevNames, _, _, _, _, _, _, _) = toPRD mem - in - if isHNull hgDevNames then () else ignore(GlobalFree hgDevNames); - if isHNull hgDevMode then () else ignore(GlobalFree hgDevMode); - free mem; freePRD() - end - - val result = printDlg mem handle ex => (freeAll(); raise ex) - (* Convert the result. We have to do this even if the result is - false to make sure we call GlobalFree on any global handles. *) - val (_, owner, hgDevMode, hgDevNames, hdc, flags, fromPage, toPage, minPage, - maxPage, copies) = toPRD mem - val devMode = - if isHNull hgDevMode - then NONE - else - let - val r = SOME(DeviceBase.getCDevMode(GlobalLock hgDevMode)) - in - GlobalUnlock hgDevMode; - r - end; - val devNames = fromDevNames hgDevNames - val newArg = - { owner = owner, devMode = devMode, devNames = devNames, - context = if isHdcNull hdc then NONE else SOME hdc, - flags = flags, fromPage = fromPage, toPage = toPage, - minPage = minPage, maxPage = maxPage, copies = copies } - val () = freeAll() - in - if result - then SOME newArg - else NONE - end - end -(* - structure ChooseFontFlags :> - sig - include BIT_FLAGS - val CF_ANSIONLY : flags - val CF_APPLY : flags - val CF_BOTH : flags - val CF_EFFECTS : flags - val CF_FIXEDPITCHONLY : flags - val CF_FORCEFONTEXIST : flags - val CF_NOFACESEL : flags - val CF_NOOEMFONTS : flags - val CF_NOSCRIPTSEL : flags - val CF_NOSIMULATIONS : flags - val CF_NOSIZESEL : flags - val CF_NOSTYLESEL : flags - val CF_NOVECTORFONTS : flags - val CF_NOVERTFONTS : flags - val CF_PRINTERFONTS : flags - val CF_SCALABLEONLY : flags - val CF_SCREENFONTS : flags - val CF_SCRIPTSONLY : flags - val CF_SELECTSCRIPT : flags - val CF_SHOWHELP : flags - val CF_TTONLY : flags - val CF_WYSIWYG : flags - end - = - struct - type flags = SysWord.word - fun toWord f = f - fun fromWord f = f - val flags = List.foldl (fn (a, b) => SysWord.orb(a,b)) 0w0 - fun allSet (fl1, fl2) = SysWord.andb(fl1, fl2) = fl1 - fun anySet (fl1, fl2) = SysWord.andb(fl1, fl2) <> 0w0 - fun clear (fl1, fl2) = SysWord.andb(SysWord.notb fl1, fl2) - - val CF_SCREENFONTS = 0wx00000001 - val CF_PRINTERFONTS = 0wx00000002 - val CF_BOTH = 0wx00000003: flags - val CF_SHOWHELP = 0wx00000004 - (* - val CF_ENABLEHOOK = 0wx00000008 - val CF_ENABLETEMPLATE = 0wx00000010 - val CF_ENABLETEMPLATEHANDLE = 0wx00000020 - *) - (*val CF_INITTOLOGFONTSTRUCT = 0wx00000040*) - (*val CF_USESTYLE = 0wx00000080*) - val CF_EFFECTS = 0wx00000100 - val CF_APPLY = 0wx00000200 - val CF_ANSIONLY = 0wx00000400 - val CF_SCRIPTSONLY = CF_ANSIONLY - val CF_NOVECTORFONTS = 0wx00000800 - val CF_NOOEMFONTS = CF_NOVECTORFONTS - val CF_NOSIMULATIONS = 0wx00001000 - (*val CF_LIMITSIZE = 0wx00002000*) - val CF_FIXEDPITCHONLY = 0wx00004000 - val CF_WYSIWYG = 0wx00008000 - val CF_FORCEFONTEXIST = 0wx00010000 - val CF_SCALABLEONLY = 0wx00020000 - val CF_TTONLY = 0wx00040000 - val CF_NOFACESEL = 0wx00080000 - val CF_NOSTYLESEL = 0wx00100000 - val CF_NOSIZESEL = 0wx00200000 - val CF_SELECTSCRIPT = 0wx00400000 - val CF_NOSCRIPTSEL = 0wx00800000 - val CF_NOVERTFONTS = 0wx01000000 - - val all = flags[CF_SCREENFONTS, CF_PRINTERFONTS, CF_SHOWHELP, - CF_EFFECTS, CF_APPLY, CF_ANSIONLY, CF_NOVECTORFONTS, - CF_NOSIMULATIONS, CF_FIXEDPITCHONLY, CF_WYSIWYG, CF_FORCEFONTEXIST, - CF_SCALABLEONLY, CF_TTONLY, CF_NOFACESEL, CF_NOSTYLESEL, CF_NOSIZESEL, - CF_SELECTSCRIPT, CF_NOSCRIPTSEL, CF_NOVERTFONTS] - - val intersect = List.foldl (fn (a, b) => SysWord.andb(a,b)) all - end - - structure ChooseFontTypes :> - sig - include BIT_FLAGS - val BOLD_FONTTYPE : flags - val ITALIC_FONTTYPE : flags - val PRINTER_FONTTYPE : flags - val REGULAR_FONTTYPE : flags - val SCREEN_FONTTYPE : flags - val SIMULATED_FONTTYPE : flags - end - = - struct - type flags = SysWord.word - fun toWord f = f - fun fromWord f = f - val flags = List.foldl (fn (a, b) => SysWord.orb(a,b)) 0w0 - fun allSet (fl1, fl2) = SysWord.andb(fl1, fl2) = fl1 - fun anySet (fl1, fl2) = SysWord.andb(fl1, fl2) <> 0w0 - fun clear (fl1, fl2) = SysWord.andb(SysWord.notb fl1, fl2) - - val SIMULATED_FONTTYPE = 0wx8000 - val PRINTER_FONTTYPE = 0wx4000 - val SCREEN_FONTTYPE = 0wx2000 - val BOLD_FONTTYPE = 0wx0100 - val ITALIC_FONTTYPE = 0wx0200 - val REGULAR_FONTTYPE = 0wx0400 - - val all = flags[SIMULATED_FONTTYPE, PRINTER_FONTTYPE, SCREEN_FONTTYPE, - BOLD_FONTTYPE, ITALIC_FONTTYPE, REGULAR_FONTTYPE] - - val intersect = List.foldl (fn (a, b) => SysWord.andb(a,b)) all - end - - type CHOOSEFONT = { - owner: HWND option, - context: HDC option, - logFont: LOGFONT option, - pointSize: int, - flags: ChooseFontFlags.flags, - colors: COLORREF, - style: string option, - fontType: ChooseFontTypes.flags, - size: {min: int, max: int} option - } - - local - val CHOOSEFONT = cStruct16(UINT, HWNDOPT, HDC, POINTER, INT, WORD, COLORREF, - INT, INT, INT, INT, POINTER, SHORT, SHORT, INT, INT) - val (toCF, fromCF, cfStruct) = breakConversion CHOOSEFONT - val (toLF, fromLF, lfStruct) = breakConversion FontBase.LOGFONT - val CF_LIMITSIZE = 0wx00002000 - val CF_INITTOLOGFONTSTRUCT = 0wx00000040 - val CF_USESTYLE = 0wx00000080 - - fun toCChooseFont({ - owner: HWND option, - context: HDC option, - logFont: LOGFONT option, - pointSize: int, - flags: ChooseFontFlags.flags, - colors: COLORREF, - style: string option, - fontType: ChooseFontTypes.flags, - size: {min: int, max: int} option - }) = - let - (* Use the supplied logFont otherwise allocate store for a new one. *) - val logf = - case logFont of - SOME logf => address(fromLF logf) - | NONE => address(alloc 1 lfStruct) - (* Copy any style to the buffer - I don't know why this is 64. *) - val lpszStyle = allocAndInitialise(64, getOpt(style, "")) - val (min, max) = case size of SOME {min, max} => (min, max) | NONE => (0,0) - val f1 = case size of SOME _ => CF_LIMITSIZE | _ => 0w0 - val f2 = case logFont of SOME _ => CF_INITTOLOGFONTSTRUCT | _ => 0w0 - val f3 = case style of SOME _ => CF_USESTYLE | _ => 0w0 - val flags = List.foldl LargeWord.orb 0w0 [ChooseFontFlags.toWord flags, f1, f2, f3] - in - address( - fromCF(sizeof cfStruct, owner, getOpt(context, hdcNull), logf, pointSize, - flags, colors, 0, 0, 0, 0, lpszStyle, - LargeWord.toInt (ChooseFontTypes.toWord fontType), 0, min, max)) - end - - fun fromCChooseFont v : CHOOSEFONT = - let - val (_, owner, hdc, logf, pointSize, flags, colors, _, _, _, _, style, - types, _, min, max) = toCF(deref v) - val minMax = - if LargeWord.andb(flags, CF_LIMITSIZE) = 0w0 - then NONE - else SOME{min=min, max=max} - val style = - if LargeWord.andb(flags, CF_USESTYLE) = 0w0 - then NONE - else SOME(fromCstring style) - in - { owner = owner, context = if isHdcNull hdc then NONE else SOME hdc, - logFont = SOME(toLF(deref logf)), pointSize = pointSize, - (* Remove CF_LIMITSIZE and/or CF_INITTOLOGFONTSTRUCT *) - flags = ChooseFontFlags.intersect[ChooseFontFlags.fromWord flags], - colors = colors, style = style, - fontType = - ChooseFontTypes.fromWord(LargeWord.andb(LargeWord.fromInt types, 0wxffff)), - size = minMax} - end - in - fun ChooseFont (arg: CHOOSEFONT): CHOOSEFONT option = - let - val converted = toCChooseFont arg - val result = - winCall1 (commdlg "ChooseFontA") POINTER BOOL converted - in - if result - then SOME(fromCChooseFont converted) - else NONE - end - - end - - structure ChooseColorFlags :> - sig - include BIT_FLAGS - val CC_ANYCOLOR : flags - val CC_FULLOPEN : flags - val CC_PREVENTFULLOPEN : flags - val CC_RGBINIT : flags - val CC_SHOWHELP : flags - val CC_SOLIDCOLOR : flags - end - = - struct - type flags = SysWord.word - fun toWord f = f - fun fromWord f = f - val flags = List.foldl (fn (a, b) => SysWord.orb(a,b)) 0w0 - fun allSet (fl1, fl2) = SysWord.andb(fl1, fl2) = fl1 - fun anySet (fl1, fl2) = SysWord.andb(fl1, fl2) <> 0w0 - fun clear (fl1, fl2) = SysWord.andb(SysWord.notb fl1, fl2) - - val CC_RGBINIT = 0wx00000001 - val CC_FULLOPEN = 0wx00000002 - val CC_PREVENTFULLOPEN = 0wx00000004 - val CC_SHOWHELP = 0wx00000008 - (*val CC_ENABLEHOOK = 0wx00000010 - val CC_ENABLETEMPLATE = 0wx00000020 - val CC_ENABLETEMPLATEHANDLE = 0wx00000040*) - val CC_SOLIDCOLOR = 0wx00000080 - val CC_ANYCOLOR = 0wx00000100 - - val all = flags[CC_RGBINIT, CC_FULLOPEN, CC_PREVENTFULLOPEN, - CC_SHOWHELP, CC_SOLIDCOLOR, CC_ANYCOLOR] - - val intersect = List.foldl (fn (a, b) => SysWord.andb(a,b)) all - end - - type CHOOSECOLOR = - { - owner: HWND option, - result: COLORREF, - customColors: COLORREF list, - flags: ChooseColorFlags.flags - } - - local - val CHOOSECOLOR = cStruct9(UINT, HWNDOPT, INT, COLORREF, POINTER, WORD, - INT, INT, INT) - (* The custom colours are held in an array of 16 elements. *) - val CUSTOM = cStruct16(COLORREF, COLORREF, COLORREF, COLORREF, - COLORREF, COLORREF, COLORREF, COLORREF, - COLORREF, COLORREF, COLORREF, COLORREF, - COLORREF, COLORREF, COLORREF, COLORREF) - val (toCC, fromCC, ccStruct) = breakConversion CHOOSECOLOR - val (toM, fromM, mStruct) = breakConversion CUSTOM - val (toCR, fromCR, cref) = breakConversion COLORREF - - fun toCChooseColor { - owner: HWND option, - result: COLORREF, - customColors: COLORREF list, - flags: ChooseColorFlags.flags - } = - let - val custom = alloc 1 mStruct - val black = fromCR(RGB{red=0, green=0, blue=0}) - fun fillCustom(_, 16) = () - | fillCustom([], i) = - (assign cref (offset i cref custom) black; fillCustom([], i+1)) - | fillCustom(hd::tl, i) = - (assign cref (offset i cref custom) (fromCR hd); fillCustom(tl, i+1)) - in - fillCustom(customColors, 0); - address( - fromCC(sizeof ccStruct, owner, 0, result, address custom, - ChooseColorFlags.toWord flags, 0, 0, 0)) - end - - fun fromCChooseColor v : CHOOSECOLOR = - let - val (_, owner, _, result, custom, flags, _, _, _) = toCC(deref v) - val custom = - List.tabulate(16, fn i => toCR(offset i cref(deref custom))) - in - { owner = owner, flags = ChooseColorFlags.fromWord flags, - customColors = custom, result = result} - end - in - fun ChooseColor (arg: CHOOSECOLOR): CHOOSECOLOR option = - let - val converted = toCChooseColor arg - val result = - winCall1 (commdlg "ChooseColorA") POINTER BOOL converted - in - if result - then SOME(fromCChooseColor converted) - else NONE - end - end -*) -(* -typedef struct tagCHOOSECOLORA { - DWORD lStructSize; - HWND hwndOwner; - HWND hInstance; - COLORREF rgbResult; - COLORREF* lpCustColors; - DWORD Flags; - LPARAM lCustData; - LPCCHOOKPROC lpfnHook; - LPCSTR lpTemplateName; -} CHOOSECOLORA, *LPCHOOSECOLORA; - -*) -(* -ChooseColor -PrintDlgEx - NT 5.0 and later only - -The following application-defined hook procedures are used with common dialog boxes. - -CCHookProc -CFHookProc -FRHookProc -OFNHookProc -OFNHookProcOldStyle -PagePaintHook -PageSetupHook -PrintHookProc -SetupHookProc -*) - end -end; diff --git a/mlsource/extra/Win/Cursor.sml b/mlsource/extra/Win/Cursor.sml deleted file mode 100644 index d7b67d19..00000000 --- a/mlsource/extra/Win/Cursor.sml +++ /dev/null @@ -1,180 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Cursor: - sig - type HCURSOR and HINSTANCE - type POINT = { x : int, y: int } - type RECT = { left: int, top: int, right: int, bottom: int } - val hcursorNull : HCURSOR - val isHcursorNull : HCURSOR -> bool - - datatype - CursorId = - OCR_APPSTARTING - | OCR_CROSS - | OCR_IBEAM - | OCR_NO - | OCR_NORMAL - | OCR_SIZEALL - | OCR_SIZENESW - | OCR_SIZENS - | OCR_SIZENWSE - | OCR_SIZEWE - | OCR_UP - | OCR_WAIT - - val ClipCursor : RECT -> unit - val CopyCursor : HCURSOR -> HCURSOR - val DestroyCursor : HCURSOR -> unit - val GetClipCursor : unit -> RECT - val GetCursor : unit -> HCURSOR - val GetCursorPos : unit -> POINT - val LoadCursor : HINSTANCE * Resource.RESID -> HCURSOR - val LoadCursorFromFile : string -> HCURSOR - val LoadSystemCursor : CursorId -> HCURSOR - val LoadSystemCursorFromFile : CursorId -> HCURSOR - val SetCursor : HCURSOR -> HCURSOR - val SetCursorPos : int * int -> unit - val SetSystemCursor : HCURSOR * CursorId -> unit - val ShowCursor : bool -> int - end - = -struct - local - open Foreign - open Base - open Resource - in - type HCURSOR = HCURSOR and HINSTANCE = HINSTANCE - type RECT = RECT and POINT = POINT - val hcursorNull = hgdiObjNull - and isHcursorNull = isHgdiObjNull - - datatype CursorId = - OCR_APPSTARTING (* Standard arrow and small hourglass *) - | OCR_NORMAL (* Standard arrow *) - | OCR_CROSS (* Crosshair *) - | OCR_IBEAM (* I-beam *) - | OCR_NO (* Slashed circle *) - | OCR_SIZEALL (* Four-pointed arrow pointing north, south, east, and west *) - | OCR_SIZENESW (* Double-pointed arrow pointing northeast and southwest *) - | OCR_SIZENS (* Double-pointed arrow pointing north and south *) - | OCR_SIZENWSE (* Double-pointed arrow pointing northwest and southeast *) - | OCR_SIZEWE (* Double-pointed arrow pointing west and east *) - | OCR_UP (* Vertical arrow *) - | OCR_WAIT (* Hourglass *) - - local - fun idToInt OCR_APPSTARTING = 32650 - | idToInt OCR_NORMAL = 32512 - | idToInt OCR_CROSS = 32515 - | idToInt OCR_IBEAM = 32513 - | idToInt OCR_NO = 32648 - | idToInt OCR_SIZEALL = 32646 - | idToInt OCR_SIZENESW = 32643 - | idToInt OCR_SIZENS = 32645 - | idToInt OCR_SIZENWSE = 32642 - | idToInt OCR_SIZEWE = 32644 - | idToInt OCR_UP = 32516 - | idToInt OCR_WAIT = 32514 - - fun intToId _ = raise Fail "intToId" - in - val CURSORID = absConversion {abs=intToId, rep=idToInt} cDWORD - end - - val SetSystemCursor = - winCall2 (user "SetSystemCursor") (cHCURSOR, CURSORID) (successState "SetSystemCursor") - - fun checkCursor c = (checkResult(not(isHcursorNull c)); c) - - val LoadCursorFromFile = - checkCursor o - winCall1 (user "LoadCursorFromFileA") (cString) cHCURSOR - - (* ML extension - simpler than having a separate function. *) - (* I found a note suggesting that it was better to use the Unicode version - because not all implementations handle this properly. *) - val LoadSystemCursorFromFile = - checkCursor o - winCall1 (user "LoadCursorFromFileW") (CURSORID) cHCURSOR - - val ClipCursor = - winCall1 (user "ClipCursor") (cConstStar cRect) (successState "ClipCursor") - - val CopyCursor = - checkCursor o - winCall1 (user "CopyCursor") (cHCURSOR) cHCURSOR - - val DestroyCursor = - winCall1 (user "DestroyCursor") (cHCURSOR) (successState "DestroyCursor") - - local - val getClipCursor = - winCall1 (user "GetClipCursor") (cStar cRect) (successState "GetClipCursor") - in - fun GetClipCursor (): RECT = - let - val r = ref { top = 0, bottom = 0, left = 0, right = 0 } - in - getClipCursor r; - !r - end - end - - val GetCursor = winCall0 (user "GetCursor") () cHCURSOR - - local - val getCursorPos = - winCall1 (user "GetCursorPos") (cStar cPoint) (successState "GetCursorPos") - in - fun GetCursorPos (): POINT = - let - val r = ref { x = 0, y = 0 } - in - getCursorPos r; - !r - end - end - - val SetCursor = winCall1 (user "SetCursor") cHCURSOR cHCURSOR - - val SetCursorPos = - winCall2 (user "SetCursorPos") (cInt, cInt) (successState "SetCursorPos") - - val ShowCursor = winCall1 (user "ShowCursor") cBool cInt - - (* Superseded by LoadImage *) - val LoadCursor = - checkCursor o - winCall2 (user "LoadCursorA") (cHINSTANCE, cRESID) cHCURSOR - - local - val loadCursor = - checkCursor o winCall2 (user "LoadCursorA") (cHINSTANCE, CURSORID) cHCURSOR - in - fun LoadSystemCursor(id: CursorId) = loadCursor(hinstanceNull, id) - end -(* -TODO: -CreateCursor - a little complicated because it includes bit maps. -*) - end -end; diff --git a/mlsource/extra/Win/DeviceBase.sml b/mlsource/extra/Win/DeviceBase.sml deleted file mode 100644 index f1fd22b9..00000000 --- a/mlsource/extra/Win/DeviceBase.sml +++ /dev/null @@ -1,533 +0,0 @@ -(* - Copyright (c) 2001, 2015, 2019 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure DeviceBase = -struct - local - open Foreign Base - in - (* Paper sizes. *) - (* Colours. Retain the American spelling for compatibility. *) - datatype DMColor = DMCOLOR_MONOCHROME | DMCOLOR_COLOR - local - val tab = [ - (DMCOLOR_MONOCHROME, 1), - (DMCOLOR_COLOR, 2)] - in - val (fromDMC, toDMC) = tableLookup(tab, NONE) - end - - (* Default source. *) - datatype DMSource = DMBIN_UPPER | DMBIN_ONLYONE | DMBIN_LOWER | DMBIN_MIDDLE | DMBIN_MANUAL | - DMBIN_ENVELOPE | DMBIN_ENVMANUAL | DMBIN_AUTO | DMBIN_TRACTOR | - DMBIN_SMALLFMT | DMBIN_LARGEFMT | DMBIN_LARGECAPACITY | DMBIN_CASSETTE | - DMBIN_FORMSOURCE | DMSOURCE_OTHER of int - local - val tab = [ - (DMBIN_ONLYONE, 1), - (DMBIN_UPPER, 1), - (DMBIN_LOWER, 2), - (DMBIN_MIDDLE, 3), - (DMBIN_MANUAL, 4), - (DMBIN_ENVELOPE, 5), - (DMBIN_ENVMANUAL, 6), - (DMBIN_AUTO, 7), - (DMBIN_TRACTOR, 8), - (DMBIN_SMALLFMT, 9), - (DMBIN_LARGEFMT, 10), - (DMBIN_LARGECAPACITY, 11), - (DMBIN_CASSETTE, 14), - (DMBIN_FORMSOURCE, 15)] - in - fun doConv (DMSOURCE_OTHER i) = i | doConv _ = raise Match - val (fromDMS, toDMS) = tableLookup(tab, SOME(DMSOURCE_OTHER, doConv)) - end - (* Print quality. Positive numbers represent dots per inch. *) - datatype DMResolution = DMRES_DRAFT | DMRES_LOW | DMRES_MEDIUM | DMRES_HIGH | DMRES_DPI of int - local - val tab = [ - (DMRES_DRAFT, ~1), - (DMRES_LOW, ~2), - (DMRES_MEDIUM, ~3), - (DMRES_HIGH, ~4)] - in - fun doConv (DMRES_DPI i) = i | doConv _ = raise Match - val (fromDMR, toDMR) = tableLookup(tab, SOME(DMRES_DPI, doConv)) - end - - datatype DMDuplex = DMDUP_SIMPLEX | DMDUP_VERTICAL | DMDUP_HORIZONTAL - local - val tab = [ - (DMDUP_SIMPLEX, 1), - (DMDUP_VERTICAL, 2), - (DMDUP_HORIZONTAL, 3)] - in - val (fromDMD, toDMD) = tableLookup(tab, NONE) - end - - datatype DMTrueType = DMTT_BITMAP | DMTT_DOWNLOAD | DMTT_SUBDEV | DMTT_DOWNLOAD_OUTLINE - local - val tab = [ - (DMTT_BITMAP, 1), - (DMTT_DOWNLOAD, 2), - (DMTT_SUBDEV, 3), - (DMTT_DOWNLOAD_OUTLINE, 4)] - in - val (fromDMTT, toDMTT) = tableLookup(tab, NONE) - end - - datatype DMICMMethod = DMICMMETHOD_NONE | DMICMMETHOD_SYSTEM | DMICMMETHOD_DRIVER | - DMICMMETHOD_DEVICE | DMICMMETHOD_OTHER of int - local - val tab = [ - (DMICMMETHOD_NONE, 1), - (DMICMMETHOD_SYSTEM, 2), - (DMICMMETHOD_DRIVER, 3), - (DMICMMETHOD_DEVICE, 4)] - in - fun doConv (DMICMMETHOD_OTHER i) = i | doConv _ = raise Match - val (fromDMICMM, toDMICMM) = tableLookup(tab, SOME(DMICMMETHOD_OTHER, doConv)) - end - - datatype DMICMIntent = DMICM_SATURATE | DMICM_CONTRAST | DMICM_COLORMETRIC | - DMICMINTENT_OTHER of int - local - val tab = [ - (DMICM_SATURATE, 1), - (DMICM_CONTRAST, 2), - (DMICM_COLORMETRIC, 3)] - in - fun doConv (DMICMINTENT_OTHER i) = i | doConv _ = raise Match - val (fromDMICMI, toDMICMI) = tableLookup(tab, SOME(DMICMINTENT_OTHER, doConv)) - end - - datatype DMMedia = DMMEDIA_STANDARD | DMMEDIA_TRANSPARENCY | DMMEDIA_GLOSSY | DMICMMEDIA_OTHER of int - local - val tab = [ - (DMMEDIA_STANDARD, 1), - (DMMEDIA_TRANSPARENCY, 2), - (DMMEDIA_GLOSSY, 3)] - in - fun doConv (DMICMMEDIA_OTHER i) = i | doConv _ = raise Match - val (fromDMM, toDMM) = tableLookup(tab, SOME(DMICMMEDIA_OTHER, doConv)) - end - - datatype DMDither = DMDITHER_NONE | DMDITHER_COARSE | DMDITHER_FINE | DMDITHER_LINEART | - DMDITHER_GRAYSCALE | DMDITHER_OTHER of int - local - val tab = [ - (DMDITHER_NONE, 1), - (DMDITHER_COARSE, 2), - (DMDITHER_FINE, 3), - (DMDITHER_LINEART, 4), - (DMDITHER_GRAYSCALE, 5)] - in - fun doConv (DMDITHER_OTHER i) = i | doConv _ = raise Match - val (fromDMDi, toDMDi) = tableLookup(tab, SOME(DMDITHER_OTHER, doConv)) - end - - (* Paper orientation. *) - datatype DMOrientation = DMORIENT_PORTRAIT | DMORIENT_LANDSCAPE - local - val tab = [ - (DMORIENT_PORTRAIT, 1), - (DMORIENT_LANDSCAPE, 2)] - in - (* Because we use getShort to get the values we don't need a Conversion. *) - val (fromDMO, toDMO) = tableLookup(tab, NONE) - end - - datatype DMPaperSize = DMPAPER_LETTER | DMPAPER_LETTERSMALL | DMPAPER_TABLOID | DMPAPER_LEDGER | - DMPAPER_LEGAL | DMPAPER_STATEMENT | DMPAPER_EXECUTIVE | DMPAPER_A3 | DMPAPER_A4 | - DMPAPER_A4SMALL | DMPAPER_A5 | DMPAPER_B4 | DMPAPER_B5 | DMPAPER_FOLIO | DMPAPER_QUARTO | - DMPAPER_10X14 | DMPAPER_11X17 | DMPAPER_NOTE | DMPAPER_ENV_9 | DMPAPER_ENV_10 | DMPAPER_ENV_11 | - DMPAPER_ENV_12 | DMPAPER_ENV_14 | DMPAPER_CSHEET | DMPAPER_DSHEET | DMPAPER_ESHEET | - DMPAPER_ENV_DL | DMPAPER_ENV_C5 | DMPAPER_ENV_C3 | DMPAPER_ENV_C4 | DMPAPER_ENV_C6 | - DMPAPER_ENV_C65 | DMPAPER_ENV_B4 | DMPAPER_ENV_B5 | DMPAPER_ENV_B6 | DMPAPER_ENV_ITALY | - DMPAPER_ENV_MONARCH | DMPAPER_ENV_PERSONAL | DMPAPER_FANFOLD_US | DMPAPER_FANFOLD_STD_GERMAN | - DMPAPER_FANFOLD_LGL_GERMAN | DMPAPER_ISO_B4 | DMPAPER_JAPANESE_POSTCARD | DMPAPER_9X11 | - DMPAPER_10X11 | DMPAPER_15X11 | DMPAPER_ENV_INVITE | DMPAPER_RESERVED_48 | DMPAPER_RESERVED_49 | - DMPAPER_LETTER_EXTRA | DMPAPER_LEGAL_EXTRA | DMPAPER_TABLOID_EXTRA | DMPAPER_A4_EXTRA | - DMPAPER_LETTER_TRANSVERSE | DMPAPER_A4_TRANSVERSE | DMPAPER_LETTER_EXTRA_TRANSVERSE | - DMPAPER_A_PLUS | DMPAPER_B_PLUS | DMPAPER_LETTER_PLUS | DMPAPER_A4_PLUS | - DMPAPER_A5_TRANSVERSE | DMPAPER_B5_TRANSVERSE | DMPAPER_A3_EXTRA | DMPAPER_A5_EXTRA | - DMPAPER_B5_EXTRA | DMPAPER_A2 | DMPAPER_A3_TRANSVERSE | DMPAPER_A3_EXTRA_TRANSVERSE | - DMPAPER_OTHER of int - - local - val tab = [ - (DMPAPER_LETTER, 1), - (DMPAPER_LETTERSMALL, 2), - (DMPAPER_TABLOID, 3), - (DMPAPER_LEDGER, 4), - (DMPAPER_LEGAL, 5), - (DMPAPER_STATEMENT, 6), - (DMPAPER_EXECUTIVE, 7), - (DMPAPER_A3, 8), - (DMPAPER_A4, 9), - (DMPAPER_A4SMALL, 10), - (DMPAPER_A5, 11), - (DMPAPER_B4, 12), - (DMPAPER_B5, 13), - (DMPAPER_FOLIO, 14), - (DMPAPER_QUARTO, 15), - (DMPAPER_10X14, 16), - (DMPAPER_11X17, 17), - (DMPAPER_NOTE, 18), - (DMPAPER_ENV_9, 19), - (DMPAPER_ENV_10, 20), - (DMPAPER_ENV_11, 21), - (DMPAPER_ENV_12, 22), - (DMPAPER_ENV_14, 23), - (DMPAPER_CSHEET, 24), - (DMPAPER_DSHEET, 25), - (DMPAPER_ESHEET, 26), - (DMPAPER_ENV_DL, 27), - (DMPAPER_ENV_C5, 28), - (DMPAPER_ENV_C3, 29), - (DMPAPER_ENV_C4, 30), - (DMPAPER_ENV_C6, 31), - (DMPAPER_ENV_C65, 32), - (DMPAPER_ENV_B4, 33), - (DMPAPER_ENV_B5, 34), - (DMPAPER_ENV_B6, 35), - (DMPAPER_ENV_ITALY, 36), - (DMPAPER_ENV_MONARCH, 37), - (DMPAPER_ENV_PERSONAL, 38), - (DMPAPER_FANFOLD_US, 39), - (DMPAPER_FANFOLD_STD_GERMAN, 40), - (DMPAPER_FANFOLD_LGL_GERMAN, 41), - (DMPAPER_ISO_B4, 42), - (DMPAPER_JAPANESE_POSTCARD, 43), - (DMPAPER_9X11, 44), - (DMPAPER_10X11, 45), - (DMPAPER_15X11, 46), - (DMPAPER_ENV_INVITE, 47), - (DMPAPER_RESERVED_48, 48), - (DMPAPER_RESERVED_49, 49), - (DMPAPER_LETTER_EXTRA, 50), - (DMPAPER_LEGAL_EXTRA, 51), - (DMPAPER_TABLOID_EXTRA, 52), - (DMPAPER_A4_EXTRA, 53), - (DMPAPER_LETTER_TRANSVERSE, 54), - (DMPAPER_A4_TRANSVERSE, 55), - (DMPAPER_LETTER_EXTRA_TRANSVERSE, 56), - (DMPAPER_A_PLUS, 57), - (DMPAPER_B_PLUS, 58), - (DMPAPER_LETTER_PLUS, 59), - (DMPAPER_A4_PLUS, 60), - (DMPAPER_A5_TRANSVERSE, 61), - (DMPAPER_B5_TRANSVERSE, 62), - (DMPAPER_A3_EXTRA, 63), - (DMPAPER_A5_EXTRA, 64), - (DMPAPER_B5_EXTRA, 65), - (DMPAPER_A2, 66), - (DMPAPER_A3_TRANSVERSE, 67), - (DMPAPER_A3_EXTRA_TRANSVERSE, 68) ] - in - (* Because we use getShort to get the values we don't need a Conversion. *) - fun doConv (DMPAPER_OTHER i) = i | doConv _ = raise Match - val (fromDMPS, toDMPS) = tableLookup(tab, SOME(DMPAPER_OTHER, doConv)) - end - - type DEVMODE = { - deviceName: string, - driverVersion: int, - orientation: DMOrientation option, - paperSize: DMPaperSize option, - paperLength: int option, - paperWidth: int option, - scale: int option, - copies: int option, - defaultSource: DMSource option, - printQuality: DMResolution option, - color: DMColor option, - duplex: DMDuplex option, - yResolution: int option, - ttOption: DMTrueType option, - collate: bool option, - formName: string option, - logPixels: int option, - bitsPerPixel: int option, - pelsWidth: int option, - pelsHeight: int option, - displayFlags: int option, (* Apparently no longer used. *) - displayFrequency: int option, - icmMethod: DMICMMethod option, - icmIntent: DMICMIntent option, - mediaType: DMMedia option, - ditherType: DMDither option, - panningWidth: int option, - panningHeight: int option, - driverPrivate: Word8Vector.vector - } - - local - val DM_SPECVERSION = 0x0401 - (* The size of the structure is the same in both 32-bit and 64-bit modes - but is larger in Unicode (220 bytes). *) - val DMBaseSize = 0w156 (* Size of structure without any user data. *) - - (* These bits indicate the valid fields in the structure. *) - val DM_ORIENTATION = 0x00000001 - val DM_PAPERSIZE = 0x00000002 - val DM_PAPERLENGTH = 0x00000004 - val DM_PAPERWIDTH = 0x00000008 - val DM_SCALE = 0x00000010 - val DM_COPIES = 0x00000100 - val DM_DEFAULTSOURCE = 0x00000200 - val DM_PRINTQUALITY = 0x00000400 - val DM_COLOR = 0x00000800 - val DM_DUPLEX = 0x00001000 - val DM_YRESOLUTION = 0x00002000 - val DM_TTOPTION = 0x00004000 - val DM_COLLATE = 0x00008000 - val DM_FORMNAME = 0x00010000 - val DM_LOGPIXELS = 0x00020000 - val DM_BITSPERPEL = 0x00040000 - val DM_PELSWIDTH = 0x00080000 - val DM_PELSHEIGHT = 0x00100000 - val DM_DISPLAYFLAGS = 0x00200000 - val DM_DISPLAYFREQUENCY = 0x00400000 - val DM_PANNINGWIDTH = 0x00800000 - val DM_PANNINGHEIGHT = 0x01000000 - val DM_ICMMETHOD = 0x02000000 - val DM_ICMINTENT = 0x04000000 - val DM_MEDIATYPE = 0x08000000 - val DM_DITHERTYPE = 0x10000000 - - open Memory - infix 6 ++ - - val {load=loadShort, store=storeShort, ctype={size=sizeShort, ...}} = - breakConversion cShort - val {load=loadDWord, store=storeDWord, ctype={size=sizeDWord, ...}} = - breakConversion cDWORD - - (* We need separate versions of this for local and global storage. PageSetupDlg - requires a HGLOBAL handle to the memory. *) - fun getCDevMode(v: voidStar) : DEVMODE = - let - val ptr = ref v - - fun getShort() = loadShort(!ptr) before ptr := !ptr ++ sizeShort - and getDWord() = loadDWord(!ptr) before ptr := !ptr ++ sizeDWord - - val deviceName = fromCstring (!ptr) - val () = ptr := !ptr ++ 0w32 - val _ = getShort() - val driverVersion = getShort() - val _ = getShort() - val driverExtra = getShort() - (* The "fields" value determines which of the fields are valid. *) - val fields = getDWord() - fun getOpt opt conv v = - if Word.andb(Word.fromInt fields, Word.fromInt opt) = 0w0 then NONE else SOME(conv v) - fun I x = x - - val orientation = (getOpt DM_ORIENTATION toDMO o getShort) () - val paperSize = (getOpt DM_PAPERSIZE toDMPS o getShort) () - val paperLength = getOpt DM_PAPERLENGTH I (getShort()) - val paperWidth = getOpt DM_PAPERWIDTH I (getShort()) - val scale = getOpt DM_SCALE I (getShort()) - val copies = getOpt DM_COPIES I (getShort()) - val defaultSource = (getOpt DM_DEFAULTSOURCE toDMS o getShort) () - val printQuality = (getOpt DM_PRINTQUALITY toDMR o getShort) () - val colour = (getOpt DM_COLOR toDMC o getShort) () - val duplex = (getOpt DM_DUPLEX toDMD o getShort) () - val yResolution = getOpt DM_YRESOLUTION I (getShort()) - val ttOption = (getOpt DM_TTOPTION toDMTT o getShort) () - val collate = getOpt DM_COLLATE I (getShort()) - val formName = getOpt DM_FORMNAME I (fromCstring(!ptr)) - val () = ptr := !ptr ++ 0w32 - val logPixels = getOpt DM_LOGPIXELS I (getShort()) - val bitsPerPixel = getOpt DM_BITSPERPEL I (getDWord()) - val pelsWidth = getOpt DM_PELSWIDTH I (getDWord()) - val pelsHeight = getOpt DM_PELSHEIGHT I (getDWord()) - val displayFlags = getOpt DM_DISPLAYFLAGS I (getDWord()) (* Or dmNup *) - val displayFrequency = getOpt DM_DISPLAYFREQUENCY I (getDWord()) - val icmMethod = (getOpt DM_ICMMETHOD toDMICMM o getDWord) () - val icmIntent = (getOpt DM_ICMINTENT toDMICMI o getDWord) () - val mediaType = (getOpt DM_MEDIATYPE toDMM o getDWord) () - val ditherType = (getOpt DM_DITHERTYPE toDMDi o getDWord) () - val (*iccManufacturer*)_ = getDWord() - val (*iccModel*)_ = getDWord() - val panningWidth = getOpt DM_PANNINGWIDTH I (getDWord()) - val panningHeight = getOpt DM_PANNINGHEIGHT I (getDWord()) - val _ = - voidStar2Sysword(!ptr) - voidStar2Sysword v = Word.toLargeWord DMBaseSize orelse raise Fail "loadCDevMode: length wrong" - (* There may be private data at the end. *) - fun loadByte _ = Memory.get8(!ptr, 0w0) before ptr := !ptr ++ 0w1 - val driverPrivate = Word8Vector.tabulate(driverExtra, loadByte) - in - { - deviceName = deviceName, - driverVersion = driverVersion, - orientation = orientation, - paperSize = paperSize, - paperLength = paperLength, - paperWidth = paperWidth, - scale = scale, - copies = copies, - defaultSource = defaultSource, - printQuality = printQuality, - color = colour, - duplex = duplex, - yResolution = yResolution, - ttOption = ttOption, - collate = case collate of NONE => NONE | SOME 0 => SOME false | SOME _ => SOME true, - formName = formName, - logPixels = logPixels, - bitsPerPixel = bitsPerPixel, - pelsWidth = pelsWidth, - pelsHeight = pelsHeight, - displayFlags = displayFlags, - displayFrequency = displayFrequency, - icmMethod = icmMethod, - icmIntent = icmIntent, - mediaType = mediaType, - ditherType = ditherType, - panningWidth = panningWidth, - panningHeight = panningHeight, - driverPrivate = driverPrivate - } - end - - fun setCDevMode(v: voidStar, (* This is the address of the data *) - { - deviceName: string, - driverVersion: int, - orientation: DMOrientation option, - paperSize: DMPaperSize option, - paperLength: int option, - paperWidth: int option, - scale: int option, - copies: int option, - defaultSource: DMSource option, - printQuality: DMResolution option, - color: DMColor option, - duplex: DMDuplex option, - yResolution: int option, - ttOption: DMTrueType option, - collate: bool option, - formName: string option, - logPixels: int option, - bitsPerPixel: int option, - pelsWidth: int option, - pelsHeight: int option, - displayFlags: int option, (* Apparently no longer used. *) - displayFrequency: int option, - icmMethod: DMICMMethod option, - icmIntent: DMICMIntent option, - mediaType: DMMedia option, - ditherType: DMDither option, - panningWidth: int option, - panningHeight: int option, - driverPrivate: Word8Vector.vector - }: DEVMODE) : unit = - let - val ptr = ref v - (* The name can be at most 31 characters. *) - val devName = - if size deviceName > 31 then String.substring(deviceName, 0, 31) else deviceName - (* setShort and setLong set the appropriate field and advance the pointer. *) - fun setShort i = ignore(storeShort(!ptr, i)) before ptr := !ptr ++ sizeShort - and setDWord i = ignore(storeDWord(!ptr, i)) before ptr := !ptr ++ sizeDWord - - (* Optional values default to zero. If the option is SOME v we set the - appropriate bit in "fields". *) - val fields = ref 0 - fun setOpt _ _ NONE = 0 - | setOpt opt conv (SOME v) = (fields := Word.toInt(Word.orb(Word.fromInt(!fields), Word.fromInt opt)); conv v) - fun I x = x - fun fromCollate true = 1 | fromCollate false = 0 - val form = - case formName of NONE => "" - | SOME s => if size s > 31 then String.substring(s, 0, 31) else s - in - CharVector.appi(fn (i, c) => set8(!ptr, Word.fromInt i, Word8.fromInt(ord c))) devName; - set8(!ptr, Word.fromInt(size devName), 0w0); - ptr := !ptr ++ 0w32; - setShort DM_SPECVERSION; - setShort driverVersion; - setShort (Word.toInt DMBaseSize); - setShort (Word8Vector.length driverPrivate); - setDWord 0; (* Fields - set this later. *) - setShort(setOpt DM_ORIENTATION fromDMO orientation); - setShort(setOpt DM_PAPERSIZE fromDMPS paperSize); - setShort(setOpt DM_PAPERLENGTH I paperLength); - setShort(setOpt DM_PAPERWIDTH I paperWidth); - setShort(setOpt DM_SCALE I scale); - setShort(setOpt DM_COPIES I copies); - setShort(setOpt DM_DEFAULTSOURCE fromDMS defaultSource); - setShort(setOpt DM_PRINTQUALITY fromDMR printQuality); - setShort(setOpt DM_COLOR fromDMC color); - setShort(setOpt DM_DUPLEX fromDMD duplex); - setShort(setOpt DM_YRESOLUTION I yResolution); - setShort(setOpt DM_TTOPTION fromDMTT ttOption); - setShort(setOpt DM_COLLATE fromCollate collate); - CharVector.appi(fn (i, c) => set8(!ptr, Word.fromInt i, Word8.fromInt(ord c))) form; - set8(!ptr, Word.fromInt(size form), 0w0); - ptr := !ptr ++ 0w32; - setShort(setOpt DM_LOGPIXELS I logPixels); - setDWord(setOpt DM_BITSPERPEL I bitsPerPixel); - setDWord(setOpt DM_PELSWIDTH I pelsWidth); - setDWord(setOpt DM_PELSHEIGHT I pelsHeight); - setDWord(setOpt DM_DISPLAYFLAGS I displayFlags); - setDWord(setOpt DM_DISPLAYFREQUENCY I displayFrequency); - setDWord(setOpt DM_ICMMETHOD fromDMICMM icmMethod); - setDWord(setOpt DM_ICMINTENT fromDMICMI icmIntent); - setDWord(setOpt DM_MEDIATYPE fromDMM mediaType); - setDWord(setOpt DM_DITHERTYPE fromDMDi ditherType); - setDWord 0; - setDWord 0; - setDWord(setOpt DM_PANNINGWIDTH I panningWidth); - setDWord(setOpt DM_PANNINGHEIGHT I panningHeight); - - (* Set the fields now. *) - ignore(storeDWord(v ++ 0w40, !fields)); - - let - fun copyToBuf (_, c) = set8(!ptr, 0w0, c) before ptr := !ptr ++ 0w1 - in - Word8Vector.appi copyToBuf driverPrivate - end - end - - fun devModeSize({driverPrivate: Word8Vector.vector, ...}: DEVMODE): word = - DMBaseSize + Word.fromInt (Word8Vector.length driverPrivate) - - fun storeCDevMode(vaddr: voidStar, devmode) = - let - val v = malloc (devModeSize devmode) - val () = setAddress(vaddr, 0w0, v) - in - setCDevMode(v, devmode); - fn () => free v - end - - fun loadCDevMode(vaddr: voidStar) : DEVMODE = getCDevMode(getAddress(vaddr, 0w0)) - in - val LPDEVMODE = - makeConversion{load=loadCDevMode, store=storeCDevMode, ctype=LowLevel.cTypePointer } - val getCDevMode = getCDevMode - and setCDevMode = setCDevMode - and devModeSize = devModeSize - end - end -end; diff --git a/mlsource/extra/Win/DeviceContext.sml b/mlsource/extra/Win/DeviceContext.sml deleted file mode 100644 index 0d04d0d9..00000000 --- a/mlsource/extra/Win/DeviceContext.sml +++ /dev/null @@ -1,706 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure DeviceContext: - sig - type BITMAP and HDC and HGDIOBJ and HWND and HRGN - type LOGBRUSH = Brush.LOGBRUSH - type LOGFONT = Font.LOGFONT - type LOGPEN = Pen.LOGPEN - type POINT = {x: int, y: int} - - type StockObjectType - val ANSI_FIXED_FONT : StockObjectType - val ANSI_VAR_FONT : StockObjectType - val BLACK_BRUSH : StockObjectType - val BLACK_PEN : StockObjectType - val CLR_INVALID : StockObjectType - val DEFAULT_PALETTE : StockObjectType - val DEVICE_DEFAULT_FONT : StockObjectType - val DKGRAY_BRUSH : StockObjectType - val GRAY_BRUSH : StockObjectType - val HOLLOW_BRUSH : StockObjectType - val LTGRAY_BRUSH : StockObjectType - val NULL_BRUSH : StockObjectType - val NULL_PEN : StockObjectType - val OEM_FIXED_FONT : StockObjectType - val SYSTEM_FIXED_FONT : StockObjectType - val SYSTEM_FONT : StockObjectType - val WHITE_BRUSH : StockObjectType - val WHITE_PEN : StockObjectType - - val GetStockObject : StockObjectType -> HGDIOBJ - - eqtype DeviceItem - val ASPECTX : DeviceItem - val ASPECTXY : DeviceItem - val ASPECTY : DeviceItem - val BITSPIXEL : DeviceItem - val CLIPCAPS : DeviceItem - val COLORRES : DeviceItem - val CURVECAPS : DeviceItem - val DRIVERVERSION : DeviceItem - val HORZRES : DeviceItem - val HORZSIZE : DeviceItem - val LINECAPS : DeviceItem - val LOGPIXELSX : DeviceItem - val LOGPIXELSY : DeviceItem - val NUMBRUSHES : DeviceItem - val NUMCOLORS : DeviceItem - val NUMFONTS : DeviceItem - val NUMMARKERS : DeviceItem - val NUMPENS : DeviceItem - val NUMRESERVED : DeviceItem - val PDEVICESIZE : DeviceItem - val PHYSICALHEIGHT : DeviceItem - val PHYSICALOFFSETX : DeviceItem - val PHYSICALOFFSETY : DeviceItem - val PHYSICALWIDTH : DeviceItem - val PLANES : DeviceItem - val POLYGONALCAPS : DeviceItem - val RASTERCAPS : DeviceItem - val SCALINGFACTORX : DeviceItem - val SCALINGFACTORY : DeviceItem - val SIZEPALETTE : DeviceItem - val TECHNOLOGY : DeviceItem - val TEXTCAPS : DeviceItem - val VERTRES : DeviceItem - val VERTSIZE : DeviceItem - - val GetDeviceCaps : HDC * DeviceItem -> int - - (* Results of various calls to GetDeviceCaps. Perhaps its result type should - be a union. *) - val CC_CHORD : int - val CC_CIRCLES : int - val CC_ELLIPSES : int - val CC_INTERIORS : int - val CC_NONE : int - val CC_PIE : int - val CC_ROUNDRECT : int - val CC_STYLED : int - val CC_WIDE : int - val CC_WIDESTYLED : int - - val CP_NONE : int - val CP_RECTANGLE : int - val CP_REGION : int - - val DT_CHARSTREAM : int - val DT_DISPFILE : int - val DT_METAFILE : int - val DT_PLOTTER : int - val DT_RASCAMERA : int - val DT_RASDISPLAY : int - val DT_RASPRINTER : int - - val LC_INTERIORS : int - val LC_MARKER : int - val LC_NONE : int - val LC_POLYLINE : int - val LC_POLYMARKER : int - val LC_STYLED : int - val LC_WIDE : int - val LC_WIDESTYLED : int - - val PC_INTERIORS : int - val PC_NONE : int - val PC_PATHS : int - val PC_POLYGON : int - val PC_POLYPOLYGON : int - val PC_RECTANGLE : int - val PC_SCANLINE : int - val PC_STYLED : int - val PC_TRAPEZOID : int - val PC_WIDE : int - val PC_WIDESTYLED : int - val PC_WINDPOLYGON : int - - val RC_BANDING : int - val RC_BIGFONT : int - val RC_BITBLT : int - val RC_BITMAP64 : int - val RC_DEVBITS : int - val RC_DIBTODEV : int - val RC_DI_BITMAP : int - val RC_FLOODFILL : int - val RC_GDI20_OUTPUT : int - val RC_GDI20_STATE : int - val RC_OP_DX_OUTPUT : int - val RC_PALETTE : int - val RC_SAVEBITMAP : int - val RC_SCALING : int - val RC_STRETCHBLT : int - val RC_STRETCHDIB : int - - val TC_CP_STROKE : int - val TC_CR_90 : int - val TC_CR_ANY : int - val TC_EA_DOUBLE : int - val TC_IA_ABLE : int - val TC_OP_CHARACTER : int - val TC_OP_STROKE : int - val TC_RA_ABLE : int - val TC_RESERVED : int - val TC_SA_CONTIN : int - val TC_SA_DOUBLE : int - val TC_SA_INTEGER : int - val TC_SCROLLBLT : int - val TC_SF_X_YINDEP : int - val TC_SO_ABLE : int - val TC_UA_ABLE : int - val TC_VA_ABLE : int - - datatype DMColor = DMCOLOR_COLOR | DMCOLOR_MONOCHROME - and DMDither = - DMDITHER_COARSE - | DMDITHER_FINE - | DMDITHER_GRAYSCALE - | DMDITHER_LINEART - | DMDITHER_NONE - | DMDITHER_OTHER of int - and DMDuplex = DMDUP_HORIZONTAL | DMDUP_SIMPLEX | DMDUP_VERTICAL - and DMICMIntent = - DMICMINTENT_OTHER of int - | DMICM_COLORMETRIC - | DMICM_CONTRAST - | DMICM_SATURATE - and DMICMMethod = - DMICMMETHOD_DEVICE - | DMICMMETHOD_DRIVER - | DMICMMETHOD_NONE - | DMICMMETHOD_OTHER of int - | DMICMMETHOD_SYSTEM - and DMMedia = - DMICMMEDIA_OTHER of int - | DMMEDIA_GLOSSY - | DMMEDIA_STANDARD - | DMMEDIA_TRANSPARENCY - and DMOrientation = DMORIENT_LANDSCAPE | DMORIENT_PORTRAIT - and DMPaperSize = - DMPAPER_10X11 - | DMPAPER_10X14 - | DMPAPER_11X17 - | DMPAPER_15X11 - | DMPAPER_9X11 - | DMPAPER_A2 - | DMPAPER_A3 - | DMPAPER_A3_EXTRA - | DMPAPER_A3_EXTRA_TRANSVERSE - | DMPAPER_A3_TRANSVERSE - | DMPAPER_A4 - | DMPAPER_A4SMALL - | DMPAPER_A4_EXTRA - | DMPAPER_A4_PLUS - | DMPAPER_A4_TRANSVERSE - | DMPAPER_A5 - | DMPAPER_A5_EXTRA - | DMPAPER_A5_TRANSVERSE - | DMPAPER_A_PLUS - | DMPAPER_B4 - | DMPAPER_B5 - | DMPAPER_B5_EXTRA - | DMPAPER_B5_TRANSVERSE - | DMPAPER_B_PLUS - | DMPAPER_CSHEET - | DMPAPER_DSHEET - | DMPAPER_ENV_10 - | DMPAPER_ENV_11 - | DMPAPER_ENV_12 - | DMPAPER_ENV_14 - | DMPAPER_ENV_9 - | DMPAPER_ENV_B4 - | DMPAPER_ENV_B5 - | DMPAPER_ENV_B6 - | DMPAPER_ENV_C3 - | DMPAPER_ENV_C4 - | DMPAPER_ENV_C5 - | DMPAPER_ENV_C6 - | DMPAPER_ENV_C65 - | DMPAPER_ENV_DL - | DMPAPER_ENV_INVITE - | DMPAPER_ENV_ITALY - | DMPAPER_ENV_MONARCH - | DMPAPER_ENV_PERSONAL - | DMPAPER_ESHEET - | DMPAPER_EXECUTIVE - | DMPAPER_FANFOLD_LGL_GERMAN - | DMPAPER_FANFOLD_STD_GERMAN - | DMPAPER_FANFOLD_US - | DMPAPER_FOLIO - | DMPAPER_ISO_B4 - | DMPAPER_JAPANESE_POSTCARD - | DMPAPER_LEDGER - | DMPAPER_LEGAL - | DMPAPER_LEGAL_EXTRA - | DMPAPER_LETTER - | DMPAPER_LETTERSMALL - | DMPAPER_LETTER_EXTRA - | DMPAPER_LETTER_EXTRA_TRANSVERSE - | DMPAPER_LETTER_PLUS - | DMPAPER_LETTER_TRANSVERSE - | DMPAPER_NOTE - | DMPAPER_OTHER of int - | DMPAPER_QUARTO - | DMPAPER_RESERVED_48 - | DMPAPER_RESERVED_49 - | DMPAPER_STATEMENT - | DMPAPER_TABLOID - | DMPAPER_TABLOID_EXTRA - and DMResolution = - DMRES_DPI of int - | DMRES_DRAFT - | DMRES_HIGH - | DMRES_LOW - | DMRES_MEDIUM - and DMSource = - DMBIN_AUTO - | DMBIN_CASSETTE - | DMBIN_ENVELOPE - | DMBIN_ENVMANUAL - | DMBIN_FORMSOURCE - | DMBIN_LARGECAPACITY - | DMBIN_LARGEFMT - | DMBIN_LOWER - | DMBIN_MANUAL - | DMBIN_MIDDLE - | DMBIN_ONLYONE - | DMBIN_SMALLFMT - | DMBIN_TRACTOR - | DMBIN_UPPER - | DMSOURCE_OTHER of int - and DMTrueType = - DMTT_BITMAP - | DMTT_DOWNLOAD - | DMTT_DOWNLOAD_OUTLINE - | DMTT_SUBDEV - - type DEVMODE = { - deviceName: string, - driverVersion: int, - orientation: DMOrientation option, - paperSize: DMPaperSize option, - paperLength: int option, - paperWidth: int option, - scale: int option, - copies: int option, - defaultSource: DMSource option, - printQuality: DMResolution option, - color: DMColor option, - duplex: DMDuplex option, - yResolution: int option, - ttOption: DMTrueType option, - collate: bool option, - formName: string option, - logPixels: int option, - bitsPerPixel: int option, - pelsWidth: int option, - pelsHeight: int option, - displayFlags: int option, (* Apparently no longer used. *) - displayFrequency: int option, - icmMethod: DMICMMethod option, - icmIntent: DMICMIntent option, - mediaType: DMMedia option, - ditherType: DMDither option, - panningWidth: int option, - panningHeight: int option, - driverPrivate: Word8Vector.vector - } - - val CancelDC : HDC -> unit - val CreateCompatibleDC : HDC -> HDC - val CreateDC : string option * string option * string option * DEVMODE option -> HDC - - val DeleteDC : HDC -> unit - val DeleteObject : HGDIOBJ -> unit - - datatype - EnumObject = - OBJ_BITMAP - | OBJ_BRUSH - | OBJ_DC - | OBJ_ENHMETADC - | OBJ_ENHMETAFILE - | OBJ_EXTPEN - | OBJ_FONT - | OBJ_MEMDC - | OBJ_METADC - | OBJ_METAFILE - | OBJ_PAL - | OBJ_PEN - | OBJ_REGION - val GetCurrentObject : HDC * EnumObject -> HGDIOBJ - val GetDC : HWND -> HDC - - datatype - DeviceContextFlag = - DCX_CACHE - | DCX_CLIPCHILDREN - | DCX_CLIPSIBLINGS - | DCX_EXCLUDERGN - | DCX_EXCLUDEUPDATE - | DCX_INTERSECTRGN - | DCX_INTERSECTUPDATE - | DCX_LOCKWINDOWUPDATE - | DCX_NORECOMPUTE - | DCX_NORESETATTRS - | DCX_PARENTCLIP - | DCX_VALIDATE - | DCX_WINDOW - - val GetDCEx : HWND * HRGN * DeviceContextFlag list -> HDC - val GetDCOrgEx : HDC -> POINT - - datatype - GetObject = - GO_Bitmap of BITMAP - | GO_Brush of LOGBRUSH - | GO_Font of LOGFONT - | GO_Palette of int - | GO_Pen of LOGPEN - - val GetObject : HGDIOBJ -> GetObject - - val GetObjectType : HGDIOBJ -> EnumObject - - - val ReleaseDC : HWND * HDC -> bool - val ResetDC : HDC * DEVMODE -> HDC - val RestoreDC : HDC * int -> unit - val SaveDC : HDC -> int - val SelectObject : HDC * HGDIOBJ -> HGDIOBJ - - type DEVNAMES = {driver: string, device: string, output: string, default: bool} - end - = -struct - local - open Foreign Base - fun checkDC c = (checkResult(not(isHdcNull c)); c) - in - type HDC = HDC and HGDIOBJ = HGDIOBJ and HWND = HWND and HRGN = HRGN - type LOGFONT = Font.LOGFONT - - open GdiBase DeviceBase - - type POINT = POINT - - datatype DeviceContextFlag = - DCX_WINDOW | DCX_CACHE | DCX_NORESETATTRS | DCX_CLIPCHILDREN | DCX_CLIPSIBLINGS | - DCX_PARENTCLIP | DCX_EXCLUDERGN | DCX_INTERSECTRGN | DCX_EXCLUDEUPDATE | DCX_INTERSECTUPDATE | - DCX_LOCKWINDOWUPDATE | DCX_NORECOMPUTE | DCX_VALIDATE - local - val tab = [ - (DCX_WINDOW, 0wx00000001), - (DCX_CACHE, 0wx00000002), - (DCX_NORESETATTRS, 0wx00000004), - (DCX_CLIPCHILDREN, 0wx00000008), - (DCX_CLIPSIBLINGS, 0wx00000010), - (DCX_PARENTCLIP, 0wx00000020), - (DCX_EXCLUDERGN, 0wx00000040), - (DCX_INTERSECTRGN, 0wx00000080), - (DCX_EXCLUDEUPDATE, 0wx00000100), - (DCX_INTERSECTUPDATE, 0wx00000200), - (DCX_LOCKWINDOWUPDATE, 0wx00000400), - (DCX_NORECOMPUTE, 0wx00100000), - (DCX_VALIDATE, 0wx00200000)] - in - val DEVICECONTEXTFLAG = tableSetConversion(tab, NONE) - end - - - (* DEVNAMES is not actually used in this structure. *) - type DEVNAMES = {driver: string, device: string, output: string, default: bool} - - datatype EnumObject = OBJ_PEN | OBJ_BRUSH | OBJ_DC | OBJ_METADC | OBJ_PAL | OBJ_FONT | - OBJ_BITMAP | OBJ_REGION | OBJ_METAFILE | OBJ_MEMDC | OBJ_EXTPEN | OBJ_ENHMETADC | - OBJ_ENHMETAFILE - - local - val tab = [ - (OBJ_PEN, 1), - (OBJ_BRUSH, 2), - (OBJ_DC, 3), - (OBJ_METADC, 4), - (OBJ_PAL, 5), - (OBJ_FONT, 6), - (OBJ_BITMAP, 7), - (OBJ_REGION, 8), - (OBJ_METAFILE, 9), - (OBJ_MEMDC, 10), - (OBJ_EXTPEN, 11), - (OBJ_ENHMETADC, 12), - (OBJ_ENHMETAFILE, 13) - ] - datatype EnumObject = - W of int - (* GetObjectType returns 0 in the event of an error. *) - fun toInt _ = raise Match - fun fromInt i = (checkResult(i <> 0); raise Match); - in - val ENUMOBJECT = tableConversion(tab, SOME(fromInt, toInt)) cUint - end - - local - datatype DeviceItem = - W of int - in - type DeviceItem = DeviceItem - val DEVICEITEM = absConversion {abs = W, rep = fn W n => n} cInt - - val DRIVERVERSION = W (0 (* Device driver version *)) - val TECHNOLOGY = W (2 (* Device classification *)) - val HORZSIZE = W (4 (* Horizontal size in millimeters *)) - val VERTSIZE = W (6 (* Vertical size in millimeters *)) - val HORZRES = W (8 (* Horizontal width in pixels *)) - val VERTRES = W (10 (* Vertical width in pixels *)) - val BITSPIXEL = W (12 (* Number of bits per pixel *)) - val PLANES = W (14 (* Number of planes *)) - val NUMBRUSHES = W (16 (* Number of brushes the device has *)) - val NUMPENS = W (18 (* Number of pens the device has *)) - val NUMMARKERS = W (20 (* Number of markers the device has *)) - val NUMFONTS = W (22 (* Number of fonts the device has *)) - val NUMCOLORS = W (24 (* Number of colors the device supports *)) - val PDEVICESIZE = W (26 (* Size required for device descriptor *)) - val CURVECAPS = W (28 (* Curve capabilities *)) - val LINECAPS = W (30 (* Line capabilities *)) - val POLYGONALCAPS = W (32 (* Polygonal capabilities *)) - val TEXTCAPS = W (34 (* Text capabilities *)) - val CLIPCAPS = W (36 (* Clipping capabilities *)) - val RASTERCAPS = W (38 (* Bitblt capabilities *)) - val ASPECTX = W (40 (* Length of the X leg *)) - val ASPECTY = W (42 (* Length of the Y leg *)) - val ASPECTXY = W (44 (* Length of the hypotenuse *)) - val LOGPIXELSX = W (88 (* Logical pixels/inch in X *)) - val LOGPIXELSY = W (90 (* Logical pixels/inch in Y *)) - val SIZEPALETTE = W (104 (* Number of entries in physical palette *)) - val NUMRESERVED = W (106 (* Number of reserved entries in palette *)) - val COLORRES = W (108 (* Actual color resolution *)) - val PHYSICALWIDTH = W (110 (* Physical Width in device units *)) - val PHYSICALHEIGHT = W (111 (* Physical Height in device units *)) - val PHYSICALOFFSETX = W (112 (* Physical Printable Area x margin *)) - val PHYSICALOFFSETY = W (113 (* Physical Printable Area y margin *)) - val SCALINGFACTORX = W (114 (* Scaling factor x *)) - val SCALINGFACTORY = W (115 (* Scaling factor y *)) - end - - (* Results of GetDeviceCaps. Since it returns an int all these are simply ints. *) - - val DT_PLOTTER = 0 (* Vector plotter *) - val DT_RASDISPLAY = 1 (* Raster display *) - val DT_RASPRINTER = 2 (* Raster printer *) - val DT_RASCAMERA = 3 (* Raster camera *) - val DT_CHARSTREAM = 4 (* Character-stream, PLP *) - val DT_METAFILE = 5 (* Metafile, VDM *) - val DT_DISPFILE = 6 (* Display-file *) - - (* Curve Capabilities *) - val CC_NONE = 0 (* Curves not supported *) - val CC_CIRCLES = 1 (* Can do circles *) - val CC_PIE = 2 (* Can do pie wedges *) - val CC_CHORD = 4 (* Can do chord arcs *) - val CC_ELLIPSES = 8 (* Can do ellipese *) - val CC_WIDE = 16 (* Can do wide lines *) - val CC_STYLED = 32 (* Can do styled lines *) - val CC_WIDESTYLED = 64 (* Can do wide styled lines *) - val CC_INTERIORS = 128 (* Can do interiors *) - val CC_ROUNDRECT = 256 (* *) - - (* Line Capabilities *) - val LC_NONE = 0 (* Lines not supported *) - val LC_POLYLINE = 2 (* Can do polylines *) - val LC_MARKER = 4 (* Can do markers *) - val LC_POLYMARKER = 8 (* Can do polymarkers *) - val LC_WIDE = 16 (* Can do wide lines *) - val LC_STYLED = 32 (* Can do styled lines *) - val LC_WIDESTYLED = 64 (* Can do wide styled lines *) - val LC_INTERIORS = 128 (* Can do interiors *) - - (* Polygonal Capabilities *) - val PC_NONE = 0 (* Polygonals not supported *) - val PC_POLYGON = 1 (* Can do polygons *) - val PC_RECTANGLE = 2 (* Can do rectangles *) - val PC_WINDPOLYGON = 4 (* Can do winding polygons *) - val PC_TRAPEZOID = 4 (* Can do trapezoids *) - val PC_SCANLINE = 8 (* Can do scanlines *) - val PC_WIDE = 16 (* Can do wide borders *) - val PC_STYLED = 32 (* Can do styled borders *) - val PC_WIDESTYLED = 64 (* Can do wide styled borders *) - val PC_INTERIORS = 128 (* Can do interiors *) - val PC_POLYPOLYGON = 256 (* Can do polypolygons *) - val PC_PATHS = 512 (* Can do paths *) - - (* Clipping Capabilities *) - val CP_NONE = 0 (* No clipping of output *) - val CP_RECTANGLE = 1 (* Output clipped to rects *) - val CP_REGION = 2 (* obsolete *) - - (* Text Capabilities *) - val TC_OP_CHARACTER = 0x00000001 (* Can do OutputPrecision CHARACTER *) - val TC_OP_STROKE = 0x00000002 (* Can do OutputPrecision STROKE *) - val TC_CP_STROKE = 0x00000004 (* Can do ClipPrecision STROKE *) - val TC_CR_90 = 0x00000008 (* Can do CharRotAbility 90 *) - val TC_CR_ANY = 0x00000010 (* Can do CharRotAbility ANY *) - val TC_SF_X_YINDEP = 0x00000020 (* Can do ScaleFreedom X_YINDEPENDENT *) - val TC_SA_DOUBLE = 0x00000040 (* Can do ScaleAbility DOUBLE *) - val TC_SA_INTEGER = 0x00000080 (* Can do ScaleAbility INTEGER *) - val TC_SA_CONTIN = 0x00000100 (* Can do ScaleAbility CONTINUOUS *) - val TC_EA_DOUBLE = 0x00000200 (* Can do EmboldenAbility DOUBLE *) - val TC_IA_ABLE = 0x00000400 (* Can do ItalisizeAbility ABLE *) - val TC_UA_ABLE = 0x00000800 (* Can do UnderlineAbility ABLE *) - val TC_SO_ABLE = 0x00001000 (* Can do StrikeOutAbility ABLE *) - val TC_RA_ABLE = 0x00002000 (* Can do RasterFontAble ABLE *) - val TC_VA_ABLE = 0x00004000 (* Can do VectorFontAble ABLE *) - val TC_RESERVED = 0x00008000 - val TC_SCROLLBLT = 0x00010000 (* Don't do text scroll with blt *) - - (* Raster Capabilities *) - val RC_BITBLT = 1 (* Can do standard BLT. *) - val RC_BANDING = 2 (* Device requires banding support *) - val RC_SCALING = 4 (* Device requires scaling support *) - val RC_BITMAP64 = 8 (* Device can support >64K bitmap *) - val RC_GDI20_OUTPUT = 0x0010 (* has 2.0 output calls *) - val RC_GDI20_STATE = 0x0020 - val RC_SAVEBITMAP = 0x0040 - val RC_DI_BITMAP = 0x0080 (* supports DIB to memory *) - val RC_PALETTE = 0x0100 (* supports a palette *) - val RC_DIBTODEV = 0x0200 (* supports DIBitsToDevice *) - val RC_BIGFONT = 0x0400 (* supports >64K fonts *) - val RC_STRETCHBLT = 0x0800 (* supports StretchBlt *) - val RC_FLOODFILL = 0x1000 (* supports FloodFill *) - val RC_STRETCHDIB = 0x2000 (* supports StretchDIBits *) - val RC_OP_DX_OUTPUT = 0x4000 - val RC_DEVBITS = 0x8000 - - local - datatype StockObjectType = - W of int - in - type StockObjectType = StockObjectType - val STOCKOBJECTTYPE = absConversion {abs = W, rep = fn W n => n} cInt - - val WHITE_BRUSH = W (0) - val LTGRAY_BRUSH = W (1) - val GRAY_BRUSH = W (2) - val DKGRAY_BRUSH = W (3) - val BLACK_BRUSH = W (4) - val NULL_BRUSH = W (5) - val HOLLOW_BRUSH = NULL_BRUSH - val WHITE_PEN = W (6) - val BLACK_PEN = W (7) - val NULL_PEN = W (8) - val OEM_FIXED_FONT = W (10) - val ANSI_FIXED_FONT = W (11) - val ANSI_VAR_FONT = W (12) - val SYSTEM_FONT = W (13) - val DEVICE_DEFAULT_FONT = W (14) - val DEFAULT_PALETTE = W (15) - val SYSTEM_FIXED_FONT = W (16) - (*val STOCK_LAST = W (16)*) - val CLR_INVALID = W (0xFFFFFFFF) - end - - val CancelDC = winCall1(gdi "CancelDC") (cHDC) (successState "CancelDC") - val CreateCompatibleDC = winCall1(gdi "CreateCompatibleDC") (cHDC) cHDC - val DeleteDC = winCall1(gdi "DeleteDC") (cHDC) (successState "DeleteDC") - val DeleteObject = winCall1(gdi "DeleteObject") (cHGDIOBJ) (successState "DeleteObject") - val GetCurrentObject = winCall2(gdi "GetCurrentObject") (cHDC,ENUMOBJECT) cHGDIOBJ - val GetDC = checkDC o winCall1(user "GetDC") (cHWND) cHDC - val GetDCEx = checkDC o winCall3(user "GetDCEx") (cHWND,cHRGN,DEVICECONTEXTFLAG) cHDC - - local - val getDCOrgEx = winCall2(gdi "GetDCOrgEx") (cHDC, cStar cPoint) (successState "GetDCOrgEx") - in - fun GetDCOrgEx hdc = let val v = ref {x=0, y=0} in getDCOrgEx(hdc, v); !v end - end - - val GetDeviceCaps = winCall2(gdi "GetDeviceCaps") (cHDC,DEVICEITEM) cInt - val GetObjectType = winCall1(gdi "GetObjectType") (cHGDIOBJ) ENUMOBJECT - val GetStockObject = winCall1 (gdi "GetStockObject") (STOCKOBJECTTYPE) cHGDIOBJ - val ReleaseDC = winCall2(user "ReleaseDC") (cHWND,cHDC) cBool - val RestoreDC = winCall2(gdi "RestoreDC") (cHDC,cInt) (successState "RestoreDC") - val SaveDC = winCall1(gdi "SaveDC") (cHDC) cInt - val ResetDC = winCall2 (gdi "ResetDC") (cHDC, LPDEVMODE) cHDC - (* The result of SelectObject is a bit of a mess. It is the original object being - replaced except if the argument is a region when it returns a RESULTREGION. - Perhaps we need a different function for that. *) - val SelectObject = winCall2(gdi "SelectObject") (cHDC,cHGDIOBJ) cHGDIOBJ - - val CreateDC = winCall4 (gdi "CreateDCA") (STRINGOPT, STRINGOPT, STRINGOPT, cOptionPtr LPDEVMODE) cHDC - - (* GetObject returns information about different kinds of GDI object. - It takes a pointer to a structure whose size and format differ according - to the type of object. To implement this properly in ML we have to - find out the type before we start. *) - datatype GetObject = - GO_Bitmap of BITMAP - (*| GO_DIBSection of DIBSECTION*) (* This is a subset of BITMAP *) - (*| GO_ExPen of EXTLOGPEN*) - | GO_Brush of LOGBRUSH - | GO_Font of LOGFONT - | GO_Pen of LOGPEN - | GO_Palette of int - local - val getObj = winCall3 (gdi "GetObjectA") (cHGDIOBJ, cInt, cPointer) cInt - val {load=fromCBM, ...} = breakConversion cBITMAP - val {load=fromCLF, ...} = breakConversion FontBase.cLOGFONT - val {load=fromCLB, ...} = breakConversion cLOGBRUSH - val {load=fromCLP, ...} = breakConversion cLOGPEN - val {load=fromCshort, ...} = breakConversion cShort - in - fun GetObject(hgdi: HGDIOBJ): GetObject = - let - (* Call with a NULL buffer to find out the memory required. Also - checks the GDI object. *) - open Memory - val space = getObj(hgdi, 0, Memory.null) - val _ = checkResult(space > 0); - val mem = malloc (Word.fromInt space) - val _ = - getObj(hgdi, space, mem) handle ex => (free mem; raise ex) - in - (case GetObjectType hgdi of - OBJ_PEN => GO_Pen(fromCLP mem) - | OBJ_BRUSH => GO_Brush(fromCLB mem) - | OBJ_BITMAP => GO_Bitmap(fromCBM mem) - | OBJ_FONT => GO_Font(fromCLF mem) - (*| OBJ_EXPEN => *) (* TODO!!*) - | OBJ_PAL => GO_Palette(fromCshort mem) (* Number of entries. *) - | _ => raise Fail "Different type") - before free mem - end - end - - (* - Other Device context functions: - ChangeDisplaySettings - ChangeDisplaySettingsEx - CreateIC - DeviceCapabilities - DrawEscape - EnumDisplayDevices - EnumDisplaySettings - EnumObjects - EnumObjectsProc - GetDCBrushColor - NT 5.0 and Win 98 only - GetDCPenColor - NT 5.0 and Win 98 only - SetDCBrushColor - NT 5.0 and Win 98 only - SetDCPenColor - NT 5.0 and Win 98 only - *) - end -end; diff --git a/mlsource/extra/Win/Dialog.sml b/mlsource/extra/Win/Dialog.sml deleted file mode 100644 index bb25636a..00000000 --- a/mlsource/extra/Win/Dialog.sml +++ /dev/null @@ -1,556 +0,0 @@ -(* - Copyright (c) 2001-7, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* -Dialogue boxes and operations on them. -*) -structure Dialog: -sig - type HWND and HINSTANCE - datatype - DLGCLASSES = - DLG_CLASS of string * Window.Style.flags - | DLG_BUTTON of Button.Style.flags - | DLG_COMBOBOX of Combobox.Style.flags - | DLG_EDIT of Edit.Style.flags - | DLG_LISTBOX of Listbox.Style.flags - | DLG_SCROLLBAR of Scrollbar.Style.flags - | DLG_STATIC of Static.Style.flags - - datatype DLGTITLE = DLG_TITLERESOURCE of int | DLG_TITLESTRING of string - - structure Style: - sig - include BIT_FLAGS - val WS_OVERLAPPED: flags and WS_POPUP: flags and WS_CHILD: flags and WS_MINIMIZE: flags - and WS_VISIBLE: flags and WS_DISABLED:flags and WS_CLIPSIBLINGS:flags - and WS_CLIPCHILDREN:flags and WS_MAXIMIZE:flags and WS_CAPTION:flags - and WS_BORDER:flags and WS_DLGFRAME:flags and WS_VSCROLL:flags and WS_HSCROLL:flags - and WS_SYSMENU:flags and WS_THICKFRAME:flags and WS_GROUP:flags and WS_TABSTOP:flags - and WS_MINIMIZEBOX:flags and WS_MAXIMIZEBOX:flags and WS_TILED:flags and WS_ICONIC:flags - and WS_SIZEBOX:flags and WS_OVERLAPPEDWINDOW:flags and WS_TILEDWINDOW:flags - and WS_POPUPWINDOW:flags and WS_CHILDWINDOW:flags - and DS_3DLOOK: flags and DS_ABSALIGN: flags and DS_CENTER: flags and DS_CENTERMOUSE: flags - and DS_CONTEXTHELP: flags and DS_CONTROL: flags and DS_FIXEDSYS: flags - and DS_LOCALEDIT: flags and DS_MODALFRAME: flags and DS_NOFAILCREATE: flags - and DS_NOIDLEMSG: flags and DS_SETFONT: flags and DS_SETFOREGROUND: flags - and DS_SYSMODAL: flags - end - - type DLGITEMTEMPLATE = - { extendedStyle: int, - x: int, - y: int, - cx : int, - cy: int, - id: int, - class: DLGCLASSES, - title: DLGTITLE, - creationData: Word8Vector.vector option - } - - type DLGTEMPLATE = - { style: Style.flags, - extendedStyle: int, - x : int, - y: int, - cx: int, - cy: int, - menu: Resource.RESID option, - class: Resource.RESID option, - title: string, - font: (int * string) option, - items: DLGITEMTEMPLATE list - } - - - val DialogBox : - HINSTANCE * Resource.RESID * HWND * - (HWND * Message.Message * 'a -> Message.LRESULT * 'a) * 'a -> int - val DialogBoxIndirect: HINSTANCE * DLGTEMPLATE * HWND * - (HWND * Message.Message * 'a -> Message.LRESULT * 'a) * 'a -> int - val CreateDialog : HINSTANCE * Resource.RESID * HWND * - (HWND * Message.Message * 'a -> Message.LRESULT * 'a) * 'a -> HWND - val CreateDialogIndirect: HINSTANCE * DLGTEMPLATE * HWND * - (HWND * Message.Message * 'a -> Message.LRESULT * 'a) * 'a -> HWND - - val GetDialogBaseUnits : unit -> {horizontal: int, vertical: int} - - val GetDlgCtrlID: HWND -> int - and GetDlgItem: HWND * int -> HWND - and GetDlgItemText: HWND * int -> string - and IsDialogMessage: HWND * Message.MSG -> bool - and EndDialog: HWND * int -> unit - -(* MessageBox and MessageBeep are in the MessageBox structure. *) -(* -CreateDialogIndirectParam -CreateDialogParam -DefDlgProc - Used to create custom dialogues -DialogBoxIndirectParam -DialogBoxParam -DialogProc -GetDlgItemInt - Ignore - probably better done with Int.toString -SetDlgItemInt - ditto -GetNextDlgGroupItem -GetNextDlgTabItem -MapDialogRect -MessageBoxEx -SendDlgItemMessage -SetDlgItemText -MessageBoxIndirect -*) - - - val compileTemplate : DLGTEMPLATE -> Word8Vector.vector - val decompileTemplate : Word8Vector.vector -> DLGTEMPLATE -end = -struct - local - open Foreign - open Base - open Globals - open Window - open Resource - - fun checkWindow c = (checkResult(not(isHNull c)); c) - - (* Dialogue procedures never call DefWindowProc. *) - fun dlgProcRes (lres, state) = (lres, state) - in - type HWND = HWND and HINSTANCE = HINSTANCE - - datatype DLGCLASSES = - DLG_CLASS of string * Window.Style.flags (* Named window class. *) - | DLG_BUTTON of Button.Style.flags - | DLG_EDIT of Edit.Style.flags - | DLG_STATIC of Static.Style.flags - | DLG_LISTBOX of Listbox.Style.flags - | DLG_SCROLLBAR of Scrollbar.Style.flags - | DLG_COMBOBOX of Combobox.Style.flags - - datatype DLGTITLE = DLG_TITLESTRING of string | DLG_TITLERESOURCE of int - - structure Style = - struct - open Window.Style (* Include all the windows styles. *) - - val DS_ABSALIGN: flags = fromWord 0wx0001 - val DS_SYSMODAL: flags = fromWord 0wx0002 - val DS_LOCALEDIT: flags = fromWord 0wx0020 - val DS_SETFONT: flags = fromWord 0wx0040 - val DS_MODALFRAME: flags = fromWord 0wx0080 - val DS_NOIDLEMSG: flags = fromWord 0wx0100 - val DS_SETFOREGROUND: flags = fromWord 0wx0200 - val DS_3DLOOK: flags = fromWord 0wx0004 - val DS_FIXEDSYS: flags = fromWord 0wx0008 - val DS_NOFAILCREATE: flags = fromWord 0wx0010 - val DS_CONTROL: flags = fromWord 0wx0400 - val DS_CENTER: flags = fromWord 0wx0800 - val DS_CENTERMOUSE: flags = fromWord 0wx1000 - val DS_CONTEXTHELP: flags = fromWord 0wx2000 - - val all = flags[Window.Style.all, DS_ABSALIGN, DS_SYSMODAL, DS_LOCALEDIT, DS_SETFONT, - DS_MODALFRAME, DS_NOIDLEMSG, DS_SETFOREGROUND, DS_3DLOOK, DS_FIXEDSYS, - DS_NOFAILCREATE, DS_CONTROL, DS_CENTER, DS_CENTERMOUSE, DS_CONTEXTHELP] - - val intersect = - List.foldl (fn (a, b) => fromWord(SysWord.andb(toWord a, toWord b))) all - end - - type DLGITEMTEMPLATE = - { extendedStyle: int, - x: int, - y: int, - cx : int, - cy: int, - id: int, - class: DLGCLASSES, - title: DLGTITLE, - creationData: Word8Vector.vector option - } - - type DLGTEMPLATE = - { style: Style.flags, - extendedStyle: int, - x : int, - y: int, - cx: int, - cy: int, - menu: Resource.RESID option, - class: Resource.RESID option, - title: string, - font: (int * string) option, - items: DLGITEMTEMPLATE list - } - - (* Convert between the data structures and the templates. *) - (* TODO: This only deals with the basic templates not the extended - versions. *) - fun decompileTemplate (w: Word8Vector.vector): DLGTEMPLATE = - let - val ptr = ref 0 - val isExtended = PackWord32Little.subVec(w, 0) = 0wxFFFF0001 - val _ = if isExtended then raise Fail "Extended templates not implemented" else (); - - val style = PackWord32Little.subVec(w, !ptr div 4) - val _ = ptr := !ptr + 4; - val exStyle = LargeWord.toInt(PackWord32Little.subVec(w, !ptr div 4)) - val _ = ptr := !ptr + 4; - val cdit = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) - val _ = ptr := !ptr + 2; - val x = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) - val _ = ptr := !ptr + 2; - val y = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) - val _ = ptr := !ptr + 2; - val cx = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) - val _ = ptr := !ptr + 2; - val cy = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) - val _ = ptr := !ptr + 2; - - (* Extract a null-terminated Unicode string and advance ptr beyond it. *) - fun getString () = - let - val start = !ptr - fun advance () = - let - val next = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) - in - ptr := !ptr + 2; - if next = 0 then () else advance() - end - in - advance(); - unicodeToString(Word8VectorSlice.vector(Word8VectorSlice.slice(w, start, SOME(!ptr-start-2)))) - end - - fun ffffOrString(): Resource.RESID = - let - val next = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) - in - if next = 0xffff - then ( (* Resource identifier. *) - ptr := !ptr + 4; - Resource.IdAsInt(LargeWord.toInt(PackWord16Little.subVec(w, (!ptr-2) div 2))) - ) - else (* Resource name. *) - Resource.IdAsString(getString()) - end - - (* Menu. *) - val menu = - case ffffOrString() of - Resource.IdAsString "" => NONE - | r => SOME r - - (* Class. *) - val class = - case ffffOrString() of - Resource.IdAsString "" => NONE - | r => SOME r - - (* Title - null terminated Unicode string. *) - val title = getString() - (* Font - only if DS_SETFONT included in the style. *) - val font = - if Style.anySet(Style.fromWord style, Style.DS_SETFONT) - then - let - val size = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) - val _ = ptr := !ptr + 2 - val name = getString() - in - SOME(size, name) - end - else NONE - - (* Items. *) - fun processItem _ : DLGITEMTEMPLATE = - let - (* Must be aligned onto a DWORD boundary. *) - val _ = while !ptr mod 4 <> 0 do ptr := !ptr + 1; - - val style = PackWord32Little.subVec(w, !ptr div 4) - val _ = ptr := !ptr + 4; - val exStyle = LargeWord.toInt(PackWord32Little.subVec(w, !ptr div 4)) - val _ = ptr := !ptr + 4; - val x = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) - val _ = ptr := !ptr + 2; - val y = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) - val _ = ptr := !ptr + 2; - val cx = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) - val _ = ptr := !ptr + 2; - val cy = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) - val _ = ptr := !ptr + 2; - val id = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) - val _ = ptr := !ptr + 2; - - val class = - case ffffOrString() of - Resource.IdAsString s => DLG_CLASS (s, Window.Style.fromWord style) - | Resource.IdAsInt 0x0080 => DLG_BUTTON (Button.Style.fromWord style) - | Resource.IdAsInt 0x0081 => DLG_EDIT (Edit.Style.fromWord style) - | Resource.IdAsInt 0x0082 => DLG_STATIC (Static.Style.fromWord style) - | Resource.IdAsInt 0x0083 => DLG_LISTBOX (Listbox.Style.fromWord style) - | Resource.IdAsInt 0x0084 => DLG_SCROLLBAR (Scrollbar.Style.fromWord style) - | Resource.IdAsInt 0x0085 => DLG_COMBOBOX (Combobox.Style.fromWord style) - | _ => raise Fail "Unknown dialog type" - - val title = - case ffffOrString() of - Resource.IdAsString s => DLG_TITLESTRING s - | Resource.IdAsInt i => DLG_TITLERESOURCE i - - val creation = - let - val length = LargeWord.toInt(PackWord16Little.subVec(w, !ptr div 2)) - val _ = ptr := !ptr + 2; - val start = !ptr - val _ = ptr := !ptr + length - in - if length = 0 - then NONE - else SOME(Word8VectorSlice.vector(Word8VectorSlice.slice(w, start, SOME length))) - end - in - { - extendedStyle = exStyle, - x = x, - y = y, - cx = cx, - cy = cy, - id = id, - class = class, - title = title, - creationData = creation - } - end - in - { style = Style.fromWord style, - extendedStyle = exStyle, - x = x, - y = y, - cx = cx, - cy = cy, - menu = menu, - class = class, - title = title, - font = font, - items = List.tabulate(cdit, processItem) - } - end; - - (* Generate a dialogue template in memory. *) - fun compileTemplate (t: DLGTEMPLATE) = - let - val basis = Word8Array.array (18, 0w0) - val nullString = Word8Vector.tabulate(2, fn _ => 0w0) - (* Force DS_SETFONT in the style according to whether we have a font specified. *) - val style = - if #font t = NONE - then Style.clear(Style.DS_SETFONT, #style t) - else Style.flags[#style t, Style.DS_SETFONT] - val _ = PackWord32Little.update(basis, 0, Style.toWord style); - val _ = PackWord32Little.update(basis, 1, LargeWord.fromInt(#extendedStyle t)); - val _ = PackWord16Little.update(basis, 4, LargeWord.fromInt(List.length(#items t))); - val _ = PackWord16Little.update(basis, 5, LargeWord.fromInt(#x t)); - val _ = PackWord16Little.update(basis, 6, LargeWord.fromInt(#y t)); - val _ = PackWord16Little.update(basis, 7, LargeWord.fromInt(#cx t)); - val _ = PackWord16Little.update(basis, 8, LargeWord.fromInt(#cy t)); - - fun unicodeString s = Word8Vector.concat[stringToUnicode s, nullString] - - fun resOrString (Resource.IdAsString s) = unicodeString s - | resOrString (Resource.IdAsInt i) = - Word8Vector.fromList - [0wxff, 0wxff, Word8.fromInt i, Word8.fromInt(i div 256)] - val menu = - case #menu t of - NONE => nullString - | SOME r => resOrString r - - val class = - case #class t of - NONE => nullString - | SOME r => resOrString r - - val title = unicodeString(#title t) - val font = - case #font t of - SOME (size, name) => - [Word8Vector.fromList - [Word8.fromInt size, Word8.fromInt(size div 256)], - stringToUnicode name, nullString] - - | NONE => [] - - fun compileItems [] = [] - | compileItems((t: DLGITEMTEMPLATE) :: rest) = - let - val basis = Word8Array.array(18, 0w0) - val (style, class) = - case #class t of - DLG_CLASS(c, s) => (Window.Style.toWord s, Resource.IdAsString c) - | DLG_BUTTON s => (Button.Style.toWord s, Resource.IdAsInt 0x80) - | DLG_COMBOBOX s => (Combobox.Style.toWord s, Resource.IdAsInt 0x85) - | DLG_EDIT s => (Edit.Style.toWord s, Resource.IdAsInt 0x81) - | DLG_LISTBOX s => (Listbox.Style.toWord s, Resource.IdAsInt 0x83) - | DLG_SCROLLBAR s => (Scrollbar.Style.toWord s, Resource.IdAsInt 0x84) - | DLG_STATIC s => (Static.Style.toWord s, Resource.IdAsInt 0x82) - - val _ = PackWord32Little.update(basis, 0, style); - val _ = PackWord32Little.update(basis, 1, LargeWord.fromInt(#extendedStyle t)); - val _ = PackWord16Little.update(basis, 4, LargeWord.fromInt(#x t)); - val _ = PackWord16Little.update(basis, 5, LargeWord.fromInt(#y t)); - val _ = PackWord16Little.update(basis, 6, LargeWord.fromInt(#cx t)); - val _ = PackWord16Little.update(basis, 7, LargeWord.fromInt(#cy t)); - val _ = PackWord16Little.update(basis, 8, LargeWord.fromInt(#id t)); - val title = - resOrString( - case #title t of - DLG_TITLESTRING s => Resource.IdAsString s - | DLG_TITLERESOURCE i => Resource.IdAsInt i) - - val creation = - case #creationData t of - NONE => [nullString] - | SOME r => [r, nullString] - val vec = - Word8Vector.concat - (Word8ArraySlice.vector(Word8ArraySlice.full basis) :: - resOrString class :: title :: creation) - val rounding = Word8Vector.length vec mod 4 - in - (* Must align onto a 4-byte boundary except for the last. *) - (if rounding = 0 orelse rest = nil then vec - else Word8Vector.concat[vec, Word8Vector.tabulate(4-rounding, fn _ => 0w0)]) :: - compileItems rest - end - - val header = - Word8Vector.concat - (Word8ArraySlice.vector(Word8ArraySlice.full basis) :: menu :: class :: title :: font) - val rounding = Word8Vector.length header mod 4 - val alignment = Word8Vector.tabulate(4-rounding, fn _ => 0w0) - in - Word8Vector.concat(header :: alignment :: compileItems (#items t)) - end - - (* CreateDialogIndirect: Create a modeless dialogue using a resource. *) - local - val sysCreateDialog = - winCall5 (user "CreateDialogParamA") (cHINSTANCE, cRESID, cHWND, cFunction, cLPARAM) cHWND - in - fun CreateDialog (hInst, lpTemplate, hWndParent, dialogueProc, init) = - let - val _ = Message.setCallback(dlgProcRes o dialogueProc, init); - val res = checkWindow - (sysCreateDialog(hInst, lpTemplate, hWndParent, Message.mainWinProc, 0)) - in - (* Add this to the modeless dialogue list so that keyboard - operations will work. *) - Message.addModelessDialogue(res, NONE); - res - end - end - - (* CreateDialogIndirect: Create a modeless dialogue from a template. *) - local - val sysCreateDialogIndirect = - winCall5 (user "CreateDialogIndirectParamA") (cHINSTANCE, cPointer, cHWND, cFunction, cLPARAM) cHWND - in - fun CreateDialogIndirect (hInst, template, hWndParent, dialogueProc, init) = - let - val _ = Message.setCallback(dlgProcRes o dialogueProc, init); - (* Compile the template and copy it to C memory. *) - val compiled = compileTemplate template - val size = Word8Vector.length compiled - open Memory - val templ = malloc (Word.fromInt size) - fun copyToBuf(i, v) = set8(templ, Word.fromInt i, v) - val () = Word8Vector.appi copyToBuf compiled - val res = checkWindow - (sysCreateDialogIndirect(hInst, templ, hWndParent, Message.mainWinProc, 0)) - val () = free templ - in - (* Add this to the modeless dialogue list so that keyboard - operations will work. *) - Message.addModelessDialogue(res, NONE); - res - end - end - - (* DialogBox: create a dialogue using a resource. *) - local - val sysDialogBox = - winCall5 (user "DialogBoxParamA") (cHINSTANCE, cRESID, cHWND, cFunction, cLPARAM) cINT_PTR - in - fun DialogBox (hInst, lpTemplate, hWndParent, dialogueProc, init) = - let - (* We can use the normal window procedure as a dialogue proc. *) - val _ = Message.setCallback(dlgProcRes o dialogueProc, init); - val result = sysDialogBox(hInst, lpTemplate, hWndParent, Message.mainWinProc, 0) - in - (* How do we remove the callback? Look for the last message? *) - result - end - end - - (* DialogBoxIndirect: create a dialogue using a template. *) - local - val sysDialogBoxIndirect = - winCall5 (user "DialogBoxIndirectParamA") (cHINSTANCE, cPointer, cHWND, cFunction, cLPARAM) cINT_PTR - in - fun DialogBoxIndirect (hInst, template, hWndParent, dialogueProc, init) = - let - val _ = Message.setCallback(dlgProcRes o dialogueProc, init); - (* Compile the template and copy it to C memory. *) - val compiled = compileTemplate template - val size = Word8Vector.length compiled - open Memory - val templ = malloc (Word.fromInt size) - fun copyToBuf(i, v) = set8(templ, Word.fromInt i, v) - val _ = Word8Vector.appi copyToBuf compiled - in - sysDialogBoxIndirect(hInst, templ, hWndParent, Message.mainWinProc, 0) - before free templ - end - end - - (* Get average size of system font. *) - local - val getDialogBaseUnits = winCall0 (user "GetDialogBaseUnits") () cDWORDw (* Actually LONG *) - in - fun GetDialogBaseUnits() : {horizontal: int, vertical: int} = - let - val base = getDialogBaseUnits () - in - {horizontal = Word.toInt(LOWORD base), vertical = Word.toInt(HIWORD base)} - end - end - - val GetDlgCtrlID = winCall1 (user "GetDlgCtrlID") cHWND cInt - and GetDlgItem = winCall2 (user "GetDlgItem") (cHWND, cInt) cHWND - - val GetDlgItemText = Window.GetWindowText o GetDlgItem - - val IsDialogMessage = winCall2 (user "IsDialogMessage") (cHWND, Message.LPMSG) cBool - - val EndDialog = winCall2 (user "EndDialog") (cHWND, cINT_PTR) (successState "EndDialog") - end -end; diff --git a/mlsource/extra/Win/DragDrop.sml b/mlsource/extra/Win/DragDrop.sml deleted file mode 100644 index e87621b8..00000000 --- a/mlsource/extra/Win/DragDrop.sml +++ /dev/null @@ -1,78 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) -structure DragDrop: - sig - type HDROP - type HWND (* = Window.HWND *) - type POINT = { x: int, y: int } - val DragAcceptFiles : HWND * bool -> unit - val DragFinish : HDROP -> unit - val DragQueryFile : HDROP -> string list - val DragQueryPoint : HDROP -> POINT * bool - end = -struct - local - open Foreign Base - in - type HDROP = HDROP and HWND = HWND - type POINT = POINT - - (* Call DragAcceptFiles to accept files. *) - val DragAcceptFiles = winCall2 (shell "DragAcceptFiles") (cHWND,cBool) cVoid - - (* Call DragFinish when finished processing a WM_DROP message. *) - and DragFinish = winCall1 (shell "DragFinish") (cHDROP) cVoid - - (* Call DragQueryFile to get the file(s). *) - local - val dragQueryFile = winCall4 (shell "DragQueryFileA") (cHDROP,cUint,cPointer,cUint) cUint - in - fun DragQueryFile (hd: HDROP): string list = - let - val nfiles = dragQueryFile(hd, ~1, Memory.null, 0) - fun getFile n = - let - val buffsize = - dragQueryFile(hd, n, Memory.null, 0) + 1 (* Must add one for NULL *) - open Memory - val buff = malloc(Word.fromInt buffsize) - val _ = - dragQueryFile(hd, n, buff, buffsize) - handle ex => (free buff; raise ex) - in - fromCstring buff before free buff - end - in - List.tabulate(nfiles, getFile) - end - end - - (* Call DragQueryPoint to find out where to drop the file(s). *) - local - val dragQueryPoint = winCall2 (shell "DragQueryPoint") (cHDROP, cStar cPoint) cBool - in - fun DragQueryPoint (hd: HDROP): POINT * bool = - let - val r = ref {x=0, y=0} - val res = dragQueryPoint(hd, r) - in - (!r, res) - end - end - end -end; diff --git a/mlsource/extra/Win/Edit.sml b/mlsource/extra/Win/Edit.sml deleted file mode 100644 index 9ab7c3f5..00000000 --- a/mlsource/extra/Win/Edit.sml +++ /dev/null @@ -1,163 +0,0 @@ -(* - Copyright (c) 2001 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* Edit windows. *) -structure Edit: -sig - structure Style: - sig - (* We use the same type so we can use this everywhere we can use - the general window style. *) - include BIT_FLAGS where type flags = Window.Style.flags - val WS_OVERLAPPED: flags and WS_POPUP: flags and WS_CHILD: flags and WS_MINIMIZE: flags - and WS_VISIBLE: flags and WS_DISABLED:flags and WS_CLIPSIBLINGS:flags - and WS_CLIPCHILDREN:flags and WS_MAXIMIZE:flags and WS_CAPTION:flags - and WS_BORDER:flags and WS_DLGFRAME:flags and WS_VSCROLL:flags and WS_HSCROLL:flags - and WS_SYSMENU:flags and WS_THICKFRAME:flags and WS_GROUP:flags and WS_TABSTOP:flags - and WS_MINIMIZEBOX:flags and WS_MAXIMIZEBOX:flags and WS_TILED:flags and WS_ICONIC:flags - and WS_SIZEBOX:flags and WS_OVERLAPPEDWINDOW:flags and WS_TILEDWINDOW:flags - and WS_POPUPWINDOW:flags and WS_CHILDWINDOW:flags - and ES_LEFT: flags and ES_CENTER:flags and ES_RIGHT:flags and ES_MULTILINE:flags - and ES_UPPERCASE: flags and ES_LOWERCASE: flags and ES_PASSWORD: flags - and ES_AUTOVSCROLL: flags and ES_AUTOHSCROLL: flags and ES_NOHIDESEL: flags - and ES_OEMCONVERT: flags and ES_READONLY: flags and ES_WANTRETURN: flags and ES_NUMBER: flags - end - - structure Notifications: - sig - val EN_SETFOCUS: int - val EN_KILLFOCUS: int - val EN_CHANGE: int - val EN_UPDATE: int - val EN_ERRSPACE: int - val EN_MAXTEXT: int - val EN_HSCROLL: int - val EN_VSCROLL: int - end -end -= -struct - structure Style = - struct - open Window.Style (* Include all the windows styles. *) - - val ES_LEFT: flags = fromWord 0wx0000 - val ES_CENTER: flags = fromWord 0wx0001 - val ES_RIGHT: flags = fromWord 0wx0002 - val ES_MULTILINE: flags = fromWord 0wx0004 - val ES_UPPERCASE: flags = fromWord 0wx0008 - val ES_LOWERCASE: flags = fromWord 0wx0010 - val ES_PASSWORD: flags = fromWord 0wx0020 - val ES_AUTOVSCROLL: flags = fromWord 0wx0040 - val ES_AUTOHSCROLL: flags = fromWord 0wx0080 - val ES_NOHIDESEL: flags = fromWord 0wx0100 - val ES_OEMCONVERT: flags = fromWord 0wx0400 - val ES_READONLY: flags = fromWord 0wx0800 - val ES_WANTRETURN: flags = fromWord 0wx1000 - val ES_NUMBER: flags = fromWord 0wx2000 - - val all = flags[Window.Style.all, ES_LEFT, ES_CENTER, ES_RIGHT, ES_MULTILINE, - ES_UPPERCASE, ES_LOWERCASE, ES_PASSWORD, ES_AUTOVSCROLL, - ES_AUTOHSCROLL, ES_NOHIDESEL, ES_OEMCONVERT, ES_READONLY, - ES_WANTRETURN, ES_NUMBER] - - val intersect = - List.foldl (fn (a, b) => fromWord(SysWord.andb(toWord a, toWord b))) all - end - - structure Notifications = - struct - val EN_SETFOCUS = 0x0100 - val EN_KILLFOCUS = 0x0200 - val EN_CHANGE = 0x0300 - val EN_UPDATE = 0x0400 - val EN_ERRSPACE = 0x0500 - val EN_MAXTEXT = 0x0501 - val EN_HSCROLL = 0x0601 - val EN_VSCROLL = 0x0602 - end -end; - -(* -let - open Edit.Style - - val flagTable = - [(ES_CENTER, "ES_CENTER"), - (ES_RIGHT, "ES_RIGHT"), - (ES_MULTILINE, "ES_MULTILINE"), - (ES_UPPERCASE, "ES_UPPERCASE"), - (ES_LOWERCASE, "ES_LOWERCASE"), - (ES_PASSWORD, "ES_PASSWORD"), - (ES_AUTOVSCROLL, "ES_AUTOVSCROLL"), - (ES_AUTOHSCROLL, "ES_AUTOHSCROLL"), - (ES_NOHIDESEL, "ES_NOHIDESEL"), - (ES_OEMCONVERT, "ES_OEMCONVERT"), - (ES_READONLY, "ES_READONLY"), - (ES_WANTRETURN, "ES_WANTRETURN"), - (ES_NUMBER, "ES_NUMBER"), - (WS_POPUP, "WS_POPUP"), - (WS_CHILD, "WS_CHILD"), - (WS_MINIMIZE, "WS_MINIMIZE"), - (WS_VISIBLE, "WS_VISIBLE"), - (WS_DISABLED, "WS_DISABLED"), - (WS_CLIPSIBLINGS, "WS_CLIPSIBLINGS"), - (WS_CLIPCHILDREN, "WS_CLIPCHILDREN"), - (WS_MAXIMIZE, "WS_MAXIMIZE"), - (WS_CAPTION, "WS_CAPTION"), - (WS_BORDER, "WS_BORDER"), - (WS_DLGFRAME, "WS_DLGFRAME"), - (WS_VSCROLL, "WS_VSCROLL"), - (WS_HSCROLL, "WS_HSCROLL"), - (WS_SYSMENU, "WS_SYSMENU"), - (WS_THICKFRAME, "WS_THICKFRAME"), - (WS_GROUP, "WS_GROUP"), - (WS_TABSTOP, "WS_TABSTOP"), - (WS_MINIMIZEBOX, "WS_MINIMIZEBOX"), - (WS_MAXIMIZEBOX, "WS_MAXIMIZEBOX")] - - fun accumulateFlags f [] = [] - | accumulateFlags f ((w, s)::t) = - if allSet(w, f) then s :: accumulateFlags(clear(w, f)) t - else accumulateFlags f t - - fun printFlags(put, beg, brk, nd) depth _ x = - (* This is just the code to print a list. *) - let - - val stringFlags = accumulateFlags x flagTable - fun plist [] depth = () - | plist _ 0 = put "..." - | plist [h] depth = put h - | plist (h::t) depth = - ( put (h^","); - brk (1, 0); - plist t (depth - 1) - ) - in - beg (3, false); - put "["; - if depth <= 0 then put "..." else plist stringFlags depth; - put "]"; - nd () - end -in - PolyML.install_pp printFlags -end; -*) \ No newline at end of file diff --git a/mlsource/extra/Win/Examples/bitViewer.sml b/mlsource/extra/Win/Examples/bitViewer.sml deleted file mode 100644 index ed2629ca..00000000 --- a/mlsource/extra/Win/Examples/bitViewer.sml +++ /dev/null @@ -1,255 +0,0 @@ -(* - Copyright (c) 2001-7 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) -(* Example bitmap viewer. *) -fun bitViewer() = -let - open Window Message Class Clipboard Menu Bitmap DeviceContext Brush Metafile - open Font Color Painting Globals - - val app = ApplicationInstance() - - (* Identifiers for the menu items. *) - val menuCopy = 1 - and menuPaste = 2 - - local - val editMenu = - let - val editMenu = CreateMenu(); - in - AppendMenu(editMenu, [], MenuId menuCopy, MFT_STRING "&Copy"); - AppendMenu(editMenu, [], MenuId menuPaste, MFT_STRING "&Paste"); - editMenu - end; - - in - (* Create the main menu and append the sub-menu. *) - val menu = CreateMenu(); - val _ = AppendMenu(menu, [], MenuHandle editMenu, MFT_STRING "&Edit") - end; - - (* Window procedure for the window. *) - fun wndProc(w: HWND, WM_CREATE _, NONE) = - let - (* Create a sub-window to display a bitmap. *) - val static = CreateWindow{class = Static, name = "", - style = Static.Style.flags[Static.Style.WS_CHILD, Static.Style.WS_VISIBLE, Static.Style.SS_BITMAP], - x = CW_USEDEFAULT, y = CW_USEDEFAULT, - height = CW_USEDEFAULT, width = CW_USEDEFAULT, - relation = ChildWindow{parent=w, id=99 (* Not used *)}, - instance = app, init = ()} - in - (LRESINT 0, SOME static) (* Return it as the "state". *) - end - - | wndProc(w: HWND, WM_PAINT, state as SOME static) = - (* WM_PAINT is sent to the window when at least some of it needs to be redrawn. *) - let - (* Fill this window with grey. We use this to fill all the area that - isn't occupied by the subwindow containing the bitmap. - A simpler way of doing this is to define a background colour for - the class in which case we don't have to process this message at all. *) - val (hdc, ps) = BeginPaint w - val grey = RGB{red=128, blue=128, green=128} - val _ = SetBkColor(hdc, grey); - (* ExtTextOut with the ETO_OPAQUE is a common way of filling an area with - a single colour. *) - val _ = ExtTextOut(hdc, {x=0, y=0}, [ETO_OPAQUE], SOME(#paint ps), "", []); - in - EndPaint(w, ps); - (LRESINT 0, state) - end - - | wndProc(w: HWND, WM_SIZE {width, height, ...}, state as SOME static) = - (* The main window has been resized. Recentre the child window. *) - let - val subRect = GetClientRect static - in - MoveWindow{hWnd = static, x = (width - #right subRect) div 2, - y = (height - #bottom subRect) div 2, - height = #bottom subRect, width = #right subRect, repaint = true}; - (LRESINT 0, state) - end - - | wndProc(w: HWND, msg as WM_COMMAND{notifyCode = 0, wId = 1 (* menuCopy*), control}, - state as SOME static) = - (* WM_COMMAND messages are sent when a menu item is pulled down. wId is the - value we set as the ID when we created the menu. *) - (* Copy the bitmap to the window as a device-independent bitmap. We could - equally just copy the bitmap handle and let the clipboard do the work. *) - let - val LRESHANDLE (bitMap: HBITMAP) = - SendMessage(static, STM_GETIMAGE{imageType=IMAGE_BITMAP}) - in - if isHNull bitMap - then (DefWindowProc(w, msg), state) - else ( - OpenClipboard(SOME w); - let - val _ = EmptyClipboard(); (* Become owner. *) - val winDC = GetDC static - (* The first call returns the header of the bitmap that will be - created. We can use all the defaults in it but we need to - know the height which is the number of scan lines. *) - val dibHdr as {height, ...} = - getBitmapInfoHdr(GetDIBits(winDC, bitMap, 0, 0, NONE)) - val dib = GetDIBits(winDC, bitMap, 0, height, SOME dibHdr) - val _ = ReleaseDC(static, winDC) - in - SetClipboardData(CH_DIB dib) - end (* Make sure the clipboard is closed if anything goes wrong. *) - handle exn => (CloseClipboard(); raise exn); - CloseClipboard(); - (LRESINT 0, state) - ) - end - - | wndProc(w: HWND, msg as WM_COMMAND{notifyCode = 0, wId = 2 (* menuPaste*), control}, - state as SOME static) = - ( - case GetPriorityClipboardFormat[CF_DIB, CF_BITMAP, CF_ENHMETAFILE] of - (* Some drawing programs paste metafile information rather than bitmaps. *) - SOME CF_ENHMETAFILE => - ( - OpenClipboard(SOME w); - - let - val CH_ENHMETAFILE emh = GetClipboardData CF_ENHMETAFILE; - (* Get the bounding frame of this metafile. This gives us the size of - the bitmap. *) - val hdr as {bounds = { right, left, top, bottom }, ... } = GetEnhMetaFileHeader emh - val winDC = GetDC static - (* In order to write to a new bitmap we first have to create a memory - device context and select a new bitmap into it. *) - val memDC = CreateCompatibleDC winDC - val emfSize: SIZE = {cx = right - left, cy = bottom - top} - val newbm = CreateCompatibleBitmap(winDC, right - left, bottom - top) - (* Select the bitmap into the memory DC to draw to it. *) - val oldBM = SelectObject(memDC, newbm); - (* Play the metafile *) - val _ = PlayEnhMetaFile(memDC, emh, - {top = 0, left = 0, right = right - left, bottom = bottom - top }) - (* Deselect the bitmap by selecting in the original (most likely NULL). *) - val _ = SelectObject(memDC, oldBM); - val _ = DeleteDC memDC (* Get rid of the device context. *) - val _ = ReleaseDC(static, winDC) - in - setBitmap(newbm, w, static) - end - (* Make sure the clipboard is closed if anything goes wrong. *) - handle exn => (CloseClipboard(); raise exn); - - CloseClipboard(); - (LRESINT 0, state) - ) - - | SOME CF_DIB => - ( - OpenClipboard(SOME w); - - let - val CH_DIB dib = GetClipboardData CF_DIB; - val winDC = GetDC static - val { width, height, ...} = getBitmapInfoHdr dib - (* Height could be negative for a top-down DIB. *) - val newbm = CreateCompatibleBitmap(winDC, width, abs height) - val _ = SetDIBits(winDC, newbm, 0, abs height, dib) - val _ = ReleaseDC(static, winDC) - in - setBitmap(newbm, w, static) - end - (* Make sure the clipboard is closed if anything goes wrong. *) - handle exn => (CloseClipboard(); raise exn); - - CloseClipboard(); - (LRESINT 0, state) - ) - - (* The clipboard synthesises DIBs from bitmaps so this code will never be - executed. It's included for information only. *) - | SOME CF_BITMAP => - ( - OpenClipboard(SOME w); - let - val CH_BITMAP hb = GetClipboardData CF_BITMAP; - (* Get the size of the bitmap *) - val GO_Bitmap (bmp as {widthBytes, height, ...}) = GetObject hb - (* Create a copy. *) - val newb = CreateBitmapIndirect bmp - val bytes = widthBytes*height - val v = GetBitmapBits(hb, bytes) - val _ = SetBitmapBits(newb, v); - in - setBitmap(newb, w, static) - end - (* Make sure the clipboard is closed if anything goes wrong. *) - handle exn => (CloseClipboard(); raise exn); - - CloseClipboard(); - (LRESINT 0, state) - ) - | _ => (DefWindowProc(w, msg), state) (* Nothing we can use. *) - ) - - | wndProc(w: HWND, msg as WM_NCDESTROY, state) = - (* When the window is closed we send a QUIT message which exits from the application loop. *) - (PostQuitMessage 0; (DefWindowProc(w, msg), state)) - - | wndProc(w: HWND, msg: Message, state) = - (DefWindowProc(w, msg), state) (* Anything else. *) - - and setBitmap(newb: HBITMAP, main: HWND, static: HWND) = - let - (* Set this copy as the new image and get back the old one. *) - val LRESHANDLE oldBM = - SendMessage(static, STM_SETIMAGE{image=newb, imageType=IMAGE_BITMAP}) - (* Get the size of the main window and the subwindow. *) - val mainRect = GetClientRect main - and subRect = GetClientRect static - in - (* If there was previously a bitmap we have to delete it. *) - if isHNull oldBM - then () - else DeleteObject oldBM; - (* Centre the window. *) - MoveWindow{hWnd = static, x = (#right mainRect - #right subRect) div 2, - y = (#bottom mainRect - #bottom subRect) div 2, - height = #bottom subRect, width = #right subRect, repaint = true} - end - - (* Register a window class. *) - val at = Class.RegisterClassEx{style = Class.Style.flags[], - wndProc = wndProc, - hInstance = app, - hIcon = NONE, hCursor = NONE, hbrBackGround = NONE, menuName = NONE, - className = "bitViewerClass", hIconSm = NONE}; - - val w = CreateWindow{class = at, name = "bitViewer", style = Window.Style.WS_OVERLAPPEDWINDOW, - x = CW_USEDEFAULT, y = CW_USEDEFAULT, height = CW_USEDEFAULT, width = CW_USEDEFAULT, - relation = PopupWindow menu, - instance = app, init = NONE}; - -in - - ShowWindow(w, SW_SHOW); - SetForegroundWindow w; - - RunApplication(); - UnregisterClass("bitViewerClass", app) -end; diff --git a/mlsource/extra/Win/Examples/dialTest.sml b/mlsource/extra/Win/Examples/dialTest.sml deleted file mode 100644 index e4e2ceca..00000000 --- a/mlsource/extra/Win/Examples/dialTest.sml +++ /dev/null @@ -1,87 +0,0 @@ -(* - Copyright (c) 2001-7 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* Test routine for dialogue. Tests various messages. *) - -fun dlgProc (h, Message.WM_INITDIALOG _, ()) = (Message.LRESINT 1, ()) - | dlgProc (h, Message.WM_COMMAND{notifyCode = 0, wId, ...}, ()) = - (if wId = MessageBox.IDOK orelse wId = MessageBox.IDCANCEL - then (Dialog.EndDialog(h, wId); Message.PostQuitMessage 0) else (); - (Message.LRESINT 1, ())) - | dlgProc msg = ((*PolyML.print msg;*)(Message.LRESINT 0, ())); - -val dial = ref Base.hwndNull; - -local -open Dialog Window.Style -in -val template = - {x = 0, y = 0, cx = 215, cy = 135, font = SOME (8, "MS Sans Serif"), menu = NONE, - class = NONE, style = flags[WS_POPUP, WS_CAPTION, WS_SYSMENU], title = "Dialogue", - extendedStyle = 0, - items = - [{x = 158, y = 7, cx = 50, cy = 14, id = 1, creationData = NONE, extendedStyle = 0, - class = DLG_BUTTON(flags[WS_CHILD, WS_VISIBLE, WS_TABSTOP]), title = DLG_TITLESTRING "OK"}, - {x = 158, y = 24, cx = 50, cy = 14, id = 2,creationData = NONE, extendedStyle = 0, - class = DLG_BUTTON(flags[WS_CHILD, WS_VISIBLE, WS_TABSTOP]), title = DLG_TITLESTRING "Cancel"}, - {x = 45, y = 67, cx = 48, cy = 61, id = 1003, title = DLG_TITLESTRING "", - creationData = NONE, extendedStyle = 0, - class = DLG_COMBOBOX(flags[WS_CHILD, WS_VISIBLE, WS_VSCROLL, WS_TABSTOP])}, - {x = 23, y = 26, cx = 19, cy = 8, id = 65535, creationData = NONE, extendedStyle = 0, - class = DLG_STATIC(flags[WS_CHILD, WS_VISIBLE, WS_GROUP]), title = DLG_TITLESTRING "Static"}, - {x = 64, y = 24, cx = 40, cy = 14, id = 1000, creationData = NONE, extendedStyle = 0, - class = DLG_EDIT(flags[WS_CHILD, WS_VISIBLE, WS_BORDER, WS_TABSTOP]), title = DLG_TITLESTRING ""}, - {x = 14, y = 47, cx = 103, cy = 11, id = 1001, creationData = NONE, extendedStyle = 0, - class = DLG_SCROLLBAR(flags[WS_CHILD, WS_VISIBLE]), title = DLG_TITLESTRING ""}, - {x = 136, y = 46, cx = 58, cy = 72, id = 1002, creationData = NONE, extendedStyle = 0, - class = DLG_LISTBOX (flags[WS_CHILD, WS_VISIBLE, WS_BORDER, WS_VSCROLL, WS_TABSTOP]), - title = DLG_TITLESTRING ""}]} -fun makedial() = - CreateDialogIndirect(Globals.ApplicationInstance(), template, - Globals.MainWindow(), dlgProc, ()); -end; -(* -val hi = Resource.LoadLibrary "C:\\Source Files\\DialogueDLL\\Debug\\DialogueDLL.dll"; - -fun makedial() = Dialog.CreateDialog(hi, Resource.IdAsString "MYDIALOGUE", Globals.MainWindow(), - dlgProc, ()); -*) -(* The dialogue has to be created by the thread that will handle its messages. *) -fun runDialogue() = - ( - dial := makedial(); - Window.ShowWindow(!dial, Window.SW_SHOW); - Window.SetForegroundWindow (!dial); - Message.RunApplication(); - () - ); - -Thread.Thread.fork(runDialogue, []); - -val combo = Dialog.GetDlgItem(!dial, 1003); -val scroll = Dialog.GetDlgItem(!dial, 1001); -val listbox = Dialog.GetDlgItem(!dial, 1002); - -val info = ref {minPos = 10, maxPos = 20, pageSize = 4, pos = 15, trackPos = 0}; -Message.SendMessage(scroll, Message.SBM_SETSCROLLINFO{info= !info, options=Scrollbar.SIF_ALL}); -Message.SendMessage(scroll, Message.SBM_GETSCROLLINFO{info=info, options=Scrollbar.SIF_ALL}); -!info; -Message.SendMessage(combo, Message.CB_DIR{attrs = [], fileSpec ="C:\\*"}); - -Message.SendMessage(combo, Message.CB_DIR{attrs = [], fileSpec ="C:\\*"}); diff --git a/mlsource/extra/Win/Examples/mlEdit.sml b/mlsource/extra/Win/Examples/mlEdit.sml deleted file mode 100644 index e047b165..00000000 --- a/mlsource/extra/Win/Examples/mlEdit.sml +++ /dev/null @@ -1,628 +0,0 @@ -(* - Copyright (c) 2001-7 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) -(* Example text editor. *) -fun mlEdit () = -let - open Window Message Menu Edit Class Dialog CommonDialog MessageBox Caret - open DeviceContext Font Printing Transform Painting Color - open Keyboard - - (* Define values to be delivered when the menu items are selected. - The Id is delivered as part of a WM_COMMAND message. *) - val menuOpen = 1 - and menuQuit = 2 - and menuSave = 3 - and menuSaveAs = 4 - and menuCut = 5 - and menuCopy = 6 - and menuPaste = 7 - and menuFind = 8 - and menuPageSetup = 9 - and menuPrint = 10 - and menuAbout = 11 - - val app = Globals.ApplicationInstance() - - (* Borrow the Poly icon from the application program. It happens to - be icon id 102. If this doesn't work return NULL. *) - val polyIcon = - Icon.LoadIcon(app, Resource.MAKEINTRESOURCE 102) handle _ => Globals.hNull; - - local - (* Create sub-menus. *) - val fileMenu = - let - val fileMenu = CreateMenu(); - in - AppendMenu(fileMenu, [], MenuId menuOpen, MFT_STRING "&Open"); - AppendMenu(fileMenu, [], MenuId menuSave, MFT_STRING "&Save"); - AppendMenu(fileMenu, [], MenuId menuSaveAs, MFT_STRING "Save &As..."); - AppendMenu(fileMenu, [], MenuId 0, MFT_SEPARATOR); - AppendMenu(fileMenu, [], MenuId menuPageSetup, MFT_STRING "Page Set&up..."); - AppendMenu(fileMenu, [], MenuId menuPrint, MFT_STRING "P&rint..."); - AppendMenu(fileMenu, [], MenuId 0, MFT_SEPARATOR); - AppendMenu(fileMenu, [], MenuId menuQuit, MFT_STRING "&Quit"); - fileMenu - end; - - val editMenu = - let - val editMenu = CreateMenu(); - in - AppendMenu(editMenu, [], MenuId menuCut, MFT_STRING "Cu&t"); - AppendMenu(editMenu, [], MenuId menuCopy, MFT_STRING "&Copy"); - AppendMenu(editMenu, [], MenuId menuPaste, MFT_STRING "&Paste"); - AppendMenu(editMenu, [], MenuId menuFind, MFT_STRING "&Find"); - editMenu - end; - - val helpMenu = - let - val helpMenu = CreateMenu() - in - AppendMenu(helpMenu, [], MenuId menuAbout, MFT_STRING "&About mlEdit..."); - helpMenu - end - - in - (* Create the main menu and append the sub-menus. *) - val menu = CreateMenu(); - val _ = AppendMenu(menu, [], MenuHandle fileMenu, MFT_STRING "&File"); - val _ = AppendMenu(menu, [], MenuHandle editMenu, MFT_STRING "&Edit") - val _ = AppendMenu(menu, [], MenuHandle helpMenu, MFT_STRING "&Help") - end; - - (* The "state" of the editor. *) - type state = { - edit: HWND, (* Handle to the edit window. *) - devMode: DEVMODE option, devNames: DEVNAMES option, (* Printer settings *) - fileName: string - } - - fun wndProc(hw: HWND, msg: Message, NONE): LRESULT * state option = - ( - case msg of - WM_CREATE _ => (* Create an edit window and return it as the state. *) - let - val edit = - CreateWindow{class = Class.Edit, name = "", - (* The style does not include horizontal scrolling. That causes us to use word-wrapping. *) - style = Edit.Style.flags[Edit.Style.WS_CHILD, Edit.Style.WS_VISIBLE, Edit.Style.WS_VSCROLL, - (*Edit.Style.WS_HSCROLL, *)Edit.Style.ES_LEFT, Edit.Style.ES_MULTILINE, - Edit.Style.ES_AUTOVSCROLL(*, Edit.Style.ES_AUTOHSCROLL*)], - x = 0, y = 0, height = 0, width = 0, relation = ChildWindow{parent=hw, id=99}, - instance = Globals.ApplicationInstance(), init = ()} - - (* Create a 10 point Courier font. *) - val hDC = GetDC edit; - val height = ~10 * GetDeviceCaps(hDC, LOGPIXELSY) div 72; - val _ = ReleaseDC(edit, hDC); - val hFont = CreateFont{height=height, width=0, escapement=0, orientation=0, - weight=FW_DONTCARE, italic=false, underline=false, strikeOut=false, - charSet=ANSI_CHARSET, outputPrecision=OUT_DEFAULT_PRECIS, - clipPrecision=[CLIP_DEFAULT_PRECIS], quality=DEFAULT_QUALITY, - pitch=FIXED_PITCH, family=FF_MODERN, faceName="Courier"} - in - SendMessage(edit, WM_SETFONT{font=hFont, redrawflag=false}); - (LRESINT 0, SOME{edit=edit, devMode=NONE, devNames = NONE, fileName=""}) - end - - | _ => (DefWindowProc(hw, msg), NONE) - ) - - | wndProc(hw: HWND, - msg: Message, - state: state option as SOME{edit, devMode, devNames, fileName, ...}) = - case msg of - WM_SETFOCUS _ => - (* If we get a focus request we set the focus to the edit window. *) - (SetFocus(SOME edit); (DefWindowProc(hw, msg), state)) - - | WM_SIZE{height, width, ...} => - (* If we get a size change we set the size of the edit window. *) - (MoveWindow{hWnd=edit, x=0, y=0, height=height, width=width, repaint=true}; (DefWindowProc(hw, msg), state)) - - | WM_NCDESTROY => - (* When the window is closed we send a QUIT message which exits from the application loop. *) - (PostQuitMessage 0; (DefWindowProc(hw, msg), state)) - - | WM_CLOSE => - (* User has pressed the Close box. If it's ok to close we could call - DestroyWindow ourselves. Just as an example we return NONE which - passes it to the default window procedure and does it for us. *) - (if checkForSave(hw, edit, fileName) then DefWindowProc(hw, msg) else LRESINT 0, state) - - | WM_COMMAND{notifyCode = 0, wId, ...} => - (* Menu selections arrive here. *) - - if wId = menuQuit - then - ( - if checkForSave(hw, edit, fileName) then DestroyWindow hw else (); - (LRESINT 0, state) - ) - - else if wId = menuOpen - then - let - val on = { - owner = SOME hw, - template = TemplateDefault, - filter = - [("Text Files (*.txt)", "*.txt"), - ("ML Files (*.sml)", "*.sml"), - ("All Files (*.*)", "*.*")], - customFilter = NONE, - filterIndex = 1, - file = "", - maxFile = 1000, - fileTitle = "", - initialDir = NONE, - title = NONE, - flags = OpenFileFlags.flags[OpenFileFlags.OFN_HIDEREADONLY], - defExt = NONE - } - in - case GetOpenFileName on of - NONE => (LRESINT 0, state) - | SOME {file, ...} => - (* If it's been modified we need to ask before overwriting. *) - if checkForSave(hw, edit, fileName) - then - (let - val f = TextIO.openIn file - (* Text input will convert CRNL to \n. We need to - reverse the process. *) - fun nlToCrnl s = - String.translate(fn #"\n" => "\r\n" | c => String.str c) s - in - (* Should we save any existing file? *) - SetWindowText(edit, nlToCrnl(TextIO.inputAll f)); - TextIO.closeIn f; - SendMessage(edit, EM_SETMODIFY{modified=false}); - (LRESINT 0, SOME{edit=edit, devMode=devMode, devNames=devNames, - fileName=file}) - end) handle _ => - (MessageBox(SOME hw, - SOME(concat["Unable to open - ", file, "\n"(*, exnMessage exn*)]), - SOME "Open failure", MessageBoxStyle.MB_OK); - (LRESINT 0, state)) - else (LRESINT 0, state) - end - - else if wId = menuSave andalso fileName <> "" - then (* Save to the original file name if there is one. *) - ( - saveDocument(hw, fileName, edit); - (LRESINT 0, state) - ) - - else if wId = menuSaveAs orelse wId = menuSave (* andalso fileName = "" *) - then - ( - case saveAsDocument(hw, edit) of - NONE => (LRESINT 0, state) - | SOME newName => - (LRESINT 0, (* Use the selected file name. *) - SOME{edit=edit, devMode=devMode, devNames=devNames, - fileName=newName}) - ) - - else if wId = menuFind - then - let - open FindReplaceFlags - (* Create a "Find" dialogue. *) - val find = - FindText{owner = hw, template = TemplateDefault, - flags=flags[FR_DOWN, FR_HIDEWHOLEWORD], - findWhat="", replaceWith="", bufferSize = 100} - in - ShowWindow(find, SW_SHOW); - (LRESINT 0, state) - end - - (* Cut, Copy and Paste are all handled by the Edit window. *) - else if wId = menuCut - then (SendMessage(edit, WM_CUT); (LRESINT 0, state)) - else if wId = menuCopy - then (SendMessage(edit, WM_COPY); (LRESINT 0, state)) - else if wId = menuPaste - then (SendMessage(edit, WM_PASTE); (LRESINT 0, state)) - - else if wId = menuPageSetup - then - ( - (* Put up the dialogue and change the settings if necessary. *) - case PageSetupDlg {owner=SOME hw, devMode=devMode, devNames=devNames, - flags=PageSetupFlags.flags[], paperSize={x=0,y=0}, - minMargin={top=0,bottom=0,left=0,right=0}, - margin={top=0,bottom=0,left=0,right=0}} of - NONE => (LRESINT 0, state) - | SOME {devMode, devNames, ...} => - (LRESINT 0, SOME{edit=edit, devMode=devMode, devNames=devNames, - fileName=fileName}) - ) - - else if wId = menuPrint (* "Print" menu item. *) - then - let - (* Put up the dialogue box to get the settings. *) - val printSettings = - PrintDlg {owner=SOME hw, devMode=devMode, devNames=devNames, - context=NONE, - flags=PrintDlgFlags.flags[PrintDlgFlags.PD_RETURNDC, PrintDlgFlags.PD_NOSELECTION], - fromPage=1, toPage=65535, minPage=1, maxPage=65535, copies=1}; - in - case printSettings of - SOME {devMode, devNames, context = SOME hdc, flags, fromPage, toPage, ...} => - (let - (* If the "Selection" button has been pressed we only print the - selection. *) - val printWhat = - if PrintDlgFlags.anySet(flags, PrintDlgFlags.PD_SELECTION) - then - let - val from = ref 0 and to = ref 0 - val _ = SendMessage(edit, EM_GETSEL{startPos = from, endPos = to}) - val text = GetWindowText edit - in - if !from < 0 orelse !from > size text orelse - !to < 0 orelse !from > size text - then "" - else String.substring(text, !from, !to - !from) - end - else (* "All" button pressed or "Pages" pressed. *) - GetWindowText edit; - val textLength = size printWhat - - (* Tell the spooler to start the document. *) - val _ = StartDoc(hdc, {docName=fileName, output=NONE, dType=NONE}) - - (* Find out how big a character is. From this we can work out - how many characters fit on a line and how many lines on a - page. Since we're using a fixed width font this is fairly - easy. *) - val _ = SetMapMode(hdc, MM_TEXT) - val white = RGB{red=255, blue=255, green=255} - val black = RGB{red=0, blue=0, green = 0} - val pageWidth = GetDeviceCaps(hdc, HORZRES) - and pageHeight = GetDeviceCaps(hdc, VERTRES) - - (* Create the same font as we're using on the screen. Since this is - a fixed width font it makes calculating the number of characters - fairly easy. *) - val charHeight = ~10 * GetDeviceCaps(hdc, LOGPIXELSY) div 72; - val hFont = CreateFont{height=charHeight, width=0, escapement=0, orientation=0, - weight=FW_DONTCARE, italic=false, underline=false, strikeOut=false, - charSet=ANSI_CHARSET, outputPrecision=OUT_DEFAULT_PRECIS, - clipPrecision=[CLIP_DEFAULT_PRECIS], quality=DEFAULT_QUALITY, - pitch=FIXED_PITCH, family=FF_MODERN, faceName="Courier"} - val oldFont = SelectObject(hdc, hFont); (* Use this font. *) - - val textMetric = GetTextMetrics hdc; - - fun printPage pno index = - let - (* If we are printing a range of pages we need to check whether - we are in the range. *) - val printThisPage = - if PrintDlgFlags.anySet(flags, PrintDlgFlags.PD_PAGENUMS) - then pno >= fromPage andalso (pno <= toPage orelse toPage < 0) - else true - val pageRect = {top=0, left=0, bottom=pageHeight, right=pageWidth} - (* Calculate the number of lines and columns. *) - val nLines = pageHeight div #height textMetric; - val nCols = pageWidth div #maxCharWidth textMetric - - (* Output the lines to fill the page. *) - fun outputLines lineNo p = - if lineNo >= nLines - then p (* Return last pointer. *) - else - let - (* Find the point to split the line. We stop at the end of - the text, a line break, the last word break on the line - or the maximum number of characters. *) - fun findEnd lastBreak i = - if i >= textLength then (textLength, textLength) - else if i-p > nCols - then - ( - case lastBreak of - NONE => (* No breaks on the line - break just before here. *) - (i-1, i-1) - | SOME b => b (* Break at the last break. *) - ) - else if i < textLength - 1 andalso - String.sub(printWhat, i) = #"\r" andalso - String.sub(printWhat, i+1) = #"\n" - then (* End of line - stop here. *) - (i, i+2) - else if Char.isSpace(String.sub(printWhat, i)) - then (* Remember this. *) - findEnd (SOME(i, i+1)) (i+1) - (* Actually tabs need to be handled more carefully. *) - else findEnd lastBreak (i+1) - - val (endLine, nextLine) = findEnd NONE p - val thisLine = - if p >= textLength - then "" - else String.substring(printWhat, p, endLine-p) - in - if printThisPage - then - ( - TabbedTextOut(hdc, {x=0, y= lineNo * #height textMetric}, - thisLine, [], 0); - () - ) - else (); - outputLines (lineNo+1) nextLine - end - val nextPage = - if printThisPage - then - let - val _ = StartPage hdc; - (* Fill the page with white. *) - val _ = SetBkColor(hdc, white); - val _ = SetTextColor(hdc, black); - val _ = ExtTextOut(hdc, {x=0, y=0}, [ETO_OPAQUE], SOME pageRect, "", []); - (* Print the text. *) - val next = outputLines 0 index - in - EndPage hdc; - next - end - else (* Format the page but don't print it. *) outputLines 0 index - in - if nextPage >= size printWhat - then () - else printPage (pno+1) nextPage - end - - val _: unit = printPage 1 0 - in - EndDoc hdc; - (* Restore the original font and delete the new one. *) - SelectObject(hdc, oldFont); - DeleteObject(hFont); - DeleteDC hdc; (* Now delete the device context. *) - (LRESINT 0, SOME{edit=edit, devMode=devMode, devNames=devNames, - fileName=fileName}) - end - (* If any of the functions failed simply delete the device - context and return the original state. *) - handle (exn as OS.SysErr _) => ( - print (exnName exn); AbortDoc hdc; DeleteDC hdc; (LRESINT 0, state))) - | _ => (LRESINT 0, state) - end - - else if wId = menuAbout - then (aboutmlEdit hw; (LRESINT 0, state)) - - else (DefWindowProc(hw, msg), state) - - | FINDMSGSTRING{flags, findWhat, ...} => - if FindReplaceFlags.anySet(flags, FindReplaceFlags.FR_DIALOGTERM) - then (* The "find" box is going away. *) - ( - SetFocus(SOME edit); - (LRESINT 0, state) - ) - else if FindReplaceFlags.anySet(flags, FindReplaceFlags.FR_FINDNEXT) - then (* The Find Next button has been pressed. *) - let - (* Get the whole of the text - not very efficient. *) - val text = GetWindowText edit - val startPos = ref 0 and endPos = ref 0 - (* Get the starting position. *) - val _ = SendMessage(edit, EM_GETSEL{startPos=startPos, endPos=endPos}) - - val isDown = FindReplaceFlags.anySet(flags, FindReplaceFlags.FR_DOWN) - (* Get the starting position for the search. *) - val startPos = if isDown then !endPos else !startPos - 1 - - val findLen = size findWhat - (* Get the options. *) - local - val toLower = String.map Char.toLower - in - val doMatch: string * string -> bool = - if FindReplaceFlags.anySet(flags, FindReplaceFlags.FR_MATCHCASE) - then op = - else fn (s1, s2) => toLower s1 = toLower s2 - end - - fun doFind p = - let - val isMatch = - p >= 0 andalso size text - p >= size findWhat andalso - doMatch(String.substring(text, p, findLen), findWhat) - in - if isMatch then p - else if isDown - then if p = size text then p (* Finish *) else doFind(p+1) - else (* Find up *) if p = 0 then ~1 (* Finish *) else doFind(p-1) - end - val foundAt = doFind startPos - in - if foundAt >= 0 andalso foundAt + findLen < size text - then - ( - SendMessage(edit, EM_SETSEL{startPos=foundAt, endPos=foundAt + findLen}); - SendMessage(edit, EM_SCROLLCARET); - () - ) - else MessageBeep(MessageBoxStyle.fromWord 0wxFFFFFFFF); - (LRESINT 0, state) - end - else (DefWindowProc(hw, msg), state) - - | _ => (DefWindowProc(hw, msg), state) - - (* If this document has been modified we want to ask before quitting or - opening a new document. *) - and checkForSave(hw, edit, fileName) = - case SendMessage(edit, EM_GETMODIFY) of - LRESINT 0 => true (* Unmodified - continue. *) - | _ => - let - val res = - MessageBox(SOME hw, SOME "Save document?", SOME "Confirm", - MessageBoxStyle.MB_YESNOCANCEL) - in - if res = IDYES - then if fileName = "" - then saveAsDocument(hw, edit) <> NONE - else saveDocument(hw, fileName, edit) - else if res = IDNO - then true (* Continue anyway. *) - else false (* Cancel - don't exit or open. *) - end - - and saveDocument(hw, fileName, edit) = - (* Write the document to the given file name. *) - let - (* Write the file as binary. That way we don't need to - convert CRNL to NL before writing. *) - val f = BinIO.openOut fileName - val s = GetWindowText edit - in - BinIO.output(f, Byte.stringToBytes s); - BinIO.closeOut f; - (* Document is now unmodified. *) - SendMessage(edit, EM_SETMODIFY{modified=false}); - true (* Succeeded. *) - end handle _ => - (MessageBox(SOME hw, - SOME(concat["Unable to save to - ", fileName, "\n"(*, exnMessage exn*)]), - SOME "Open failure", MessageBoxStyle.MB_OK); - false) - - and saveAsDocument(hw, edit) = - (* Ask for the file name before trying to save. *) - let - val on = { - owner = SOME hw, - template = TemplateDefault, - filter = - [("Text Files (*.txt)", "*.txt"), - ("ML Files (*.sml)", "*.sml"), - ("All Files (*.*)", "*.*")], - customFilter = NONE, - filterIndex = 1, - file = "", - maxFile = 1000, - fileTitle = "", - initialDir = NONE, - title = NONE, - flags = OpenFileFlags.flags[], - defExt = NONE - } - in - case GetSaveFileName on of - NONE => NONE - | SOME {file, filterIndex, fileTitle, ...} => - let - (* If the user typed a file name without an extension use - the extension from the appropriate filter. *) - val suffix = - case filterIndex of - 1 => ".txt" - | 2 => ".sml" - | _ => "" - val fileName = - if Char.contains fileTitle #"." - then file else file ^ suffix - in - if saveDocument(hw, fileName, edit) - then SOME file (* Return the selected name. *) - else NONE - end - end - - and aboutmlEdit hw = - (* Called when the user selects "About..." from the help menu. *) - let - (* Dialogue template containing three items: an OK button, a static picture and - a piece of text. *) - val pictureId = 1000 (* Could use any number here. *) - open Static.Style - val template = - {x = 0, y = 0, cx = 210, cy = 94, font = SOME (8, "MS Sans Serif"), menu = NONE, - class = NONE,title = "About mlEdit", extendedStyle = 0, - style = flags[WS_POPUP, WS_CAPTION], - items = - [{x = 73, y = 62, cx = 50, cy = 14, id = 1, - class = DLG_BUTTON (flags[WS_CHILD, WS_VISIBLE, WS_TABSTOP]), - title = DLG_TITLESTRING "OK", creationData = NONE, extendedStyle = 0}, - {x = 7, y = 7, cx = 32, cy = 32, id = pictureId, - class = DLG_STATIC (flags[WS_CHILD, WS_VISIBLE, SS_ICON]), - title = DLG_TITLESTRING "", creationData = NONE, extendedStyle = 0}, - {x = 15, y = 39, cx = 180, cy = 21, id = 65535, - class = DLG_STATIC (flags[WS_CHILD, WS_VISIBLE, WS_GROUP]), - title = - DLG_TITLESTRING - "mlEdit - An example of Windows programming in Poly/ML\ - \\nCopyright David C.J. Matthews 2001-7", - creationData = NONE, extendedStyle = 0}] } - - (* Dialogue procedure. *) - fun dlgProc(dial, WM_INITDIALOG _, ()) = - ( - (* Send a message to the picture control to set it to this icon. *) - SendMessage(GetDlgItem(dial, pictureId), STM_SETICON{icon=polyIcon}); - (LRESINT 1, ()) - ) - - | dlgProc(dial, WM_COMMAND{notifyCode = 0, wId=1 (* OK button *), ...}, ()) = - (* When the OK button is pressed we end the dialogue. *) - (EndDialog(dial, 1); (LRESINT 1, ()) ) - - | dlgProc _ = (LRESINT 0, ()) - - in - DialogBoxIndirect(app, template, hw, dlgProc, ()); - () - end - - val className = "mlEditWindowClass" - (* Register a class for the top-level window. Use the Poly icon from the application. *) - val myWindowClass = RegisterClassEx{style = Class.Style.flags[], - wndProc = wndProc, hInstance = app, - hIcon = SOME polyIcon, hCursor = NONE, hbrBackGround = NONE, menuName = NONE, - className = className, hIconSm = NONE}; - - - val w = CreateWindow{class = myWindowClass, name = "mlEdit", style = Window.Style.WS_OVERLAPPEDWINDOW, - x = CW_USEDEFAULT, y = CW_USEDEFAULT, height = CW_USEDEFAULT, width = CW_USEDEFAULT, - relation = PopupWindow menu, - instance = app, init = NONE}; -in - ShowWindow(w, SW_SHOW); - SetForegroundWindow w; - - RunApplication(); - (* Must unregister the class before returning otherwise RegisterClass will - fail if we call mlEdit again. *) - UnregisterClass(className, app) -end; diff --git a/mlsource/extra/Win/FlagPrint.sml b/mlsource/extra/Win/FlagPrint.sml deleted file mode 100644 index 97d0bad8..00000000 --- a/mlsource/extra/Win/FlagPrint.sml +++ /dev/null @@ -1,54 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) -functor FlagPrint(structure BITS: BIT_FLAGS) = -struct - (* Auxiliary function to create a function to print out bit flags. - The function must actually be installed by the caller because - it has to be called with the type itself. *) - fun createFlagPrinter (flagTable: (BITS.flags * string) list) = - let - fun accumulateFlags _ [] = [] - | accumulateFlags f ((w, s)::t) = - if BITS.allSet(w, f) then s :: accumulateFlags(BITS.clear(w, f)) t - else accumulateFlags f t - - fun printFlags depth _ x = - (* This is just the code to print a list. *) - let - open PolyML - val stringFlags = accumulateFlags x flagTable - fun plist [] _ = [] - | plist _ 0 = [PrettyString "..."] - | plist [h] _ = [PrettyString h] - | plist (h::t) depth = - PrettyString(h ^ ",") :: - PrettyBreak (1, 0) :: - plist t (depth - 1) - in - PrettyBlock (3, false, [], - PrettyString "[" :: - ((if depth <= 0 then [PrettyString "..."] - else plist stringFlags depth) @ - [PrettyString "]"] - ) - ) - end - in - printFlags - end; -end; diff --git a/mlsource/extra/Win/Font.sml b/mlsource/extra/Win/Font.sml deleted file mode 100644 index fca327c0..00000000 --- a/mlsource/extra/Win/Font.sml +++ /dev/null @@ -1,562 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Font : - sig - type HDC and HFONT - type COLORREF = Color.COLORREF - type POINT = {x: int, y: int} - and SIZE = {cx: int, cy: int } - and RECT = { top: int, left: int, bottom: int, right: int } - - datatype FontFamily = - FF_DECORATIVE - | FF_DONTCARE - | FF_MODERN - | FF_ROMAN - | FF_SCRIPT - | FF_SWISS - and FontPitch = DEFAULT_PITCH | FIXED_PITCH | VARIABLE_PITCH - and OutputPrecision = - OUT_CHARACTER_PRECIS - | OUT_DEFAULT_PRECIS - | OUT_DEVICE_PRECIS - | OUT_OUTLINE_PRECIS - | OUT_RASTER_PRECIS - | OUT_SCREEN_OUTLINE_PRECIS - | OUT_STRING_PRECIS - | OUT_STROKE_PRECIS - | OUT_TT_ONLY_PRECIS - | OUT_TT_PRECIS - and OutputQuality = - DEFAULT_QUALITY | DRAFT_QUALITY | PROOF_QUALITY | ANTIALIASED_QUALITY | CLEARTYPE_QUALITY | NONANTIALIASED_QUALITY - and CharacterSet = - ANSI_CHARSET | DEFAULT_CHARSET | SYMBOL_CHARSET | MAC_CHARSET | - SHIFTJIS_CHARSET | HANGEUL_CHARSET | JOHAB_CHARSET | GB2312_CHARSET | - CHINESEBIG5_CHARSET | GREEK_CHARSET | TURKISH_CHARSET | VIETNAMESE_CHARSET | - HEBREW_CHARSET | ARABIC_CHARSET | BALTIC_CHARSET | RUSSIAN_CHARSET | - THAI_CHARSET | EASTEUROPE_CHARSET | OEM_CHARSET - - type FontWeight = int - val FW_BLACK : FontWeight - val FW_BOLD : FontWeight - val FW_DEMIBOLD : FontWeight - val FW_DONTCARE : FontWeight - val FW_EXTRABOLD : FontWeight - val FW_EXTRALIGHT : FontWeight - val FW_HEAVY : FontWeight - val FW_LIGHT : FontWeight - val FW_MEDIUM : FontWeight - val FW_NORMAL : FontWeight - val FW_REGULAR : FontWeight - val FW_SEMIBOLD : FontWeight - val FW_THIN : FontWeight - val FW_ULTRABOLD : FontWeight - val FW_ULTRALIGHT : FontWeight - - datatype ClippingPrecision = - CLIP_DEFAULT_PRECIS | CLIP_STROKE_PRECIS | CLIP_LH_ANGLES | CLIP_DFA_DISABLE | CLIP_EMBEDDED - - type LOGFONT = - { - height : int, - width : int, - escapement : int, - orientation : int, - weight : FontWeight, - italic : bool, - underline : bool, - strikeOut : bool, - charSet : CharacterSet, - outputPrecision: OutputPrecision, - clipPrecision : ClippingPrecision list, - quality : OutputQuality, - pitch: FontPitch, - family: FontFamily, - faceName : string - } - - datatype DrawTextMode = - DT_BOTTOM - | DT_CALCRECT - | DT_CENTER - | DT_EXPANDTABS - | DT_EXTERNALLEADING - | DT_INTERNAL - | DT_LEFT - | DT_NOCLIP - | DT_NOPREFIX - | DT_RIGHT - | DT_SINGLELINE - | DT_TABSTOP of int - | DT_TOP - | DT_VCENTER - | DT_WORDBREAK - and TextAlign = - TA_BASELINE - | TA_BOTTOM - | TA_CENTER - | TA_LEFT - | TA_NOUPDATECP - | TA_RIGHT - | TA_TOP - | TA_UPDATECP - and TextMetricPitch = - TMPF_DEVICE - | TMPF_FIXED_PITCH - | TMPF_TRUETYPE - | TMPF_VECTOR - and ExtendedTextMode = - ETO_CLIPPED - | ETO_GLYPH_INDEX - | ETO_IGNORELANGUAGE - | ETO_OPAQUE - | ETO_RTLREADING - - type TEXTMETRIC = - { height: int, ascent: int, descent: int, internalLeading: int, externalLeading: int, - aveCharWidth: int, maxCharWidth: int, weight: int, overhang: int, - digitizedAspectX: int, digitizedAspectY: int, firstChar: char, lastChar: char, - defaultChar: char, breakChar: char, italic: bool, underlined: bool, struckOut: bool, - pitch: TextMetricPitch list, family: FontFamily, charSet : CharacterSet } - - val AddFontResource : string -> int - val CreateFont : LOGFONT -> HFONT - val CreateFontIndirect : LOGFONT -> HFONT - val CreateScalableFontResource : int * string * string * string -> unit - val DrawText : HDC * string * RECT * DrawTextMode list -> int - val ExtTextOut : HDC * POINT * ExtendedTextMode list * - RECT option * string * int list -> unit - val GetAspectRatioFilterEx : HDC -> SIZE - val GetCharABCWidths : HDC * char * char -> (int * int * int) vector - val GetCharABCWidthsFloat : HDC * char * char -> (real * real * real) vector - val GetCharWidth32 : HDC * char * char -> int vector - val GetCharWidthFloat : HDC * char * char -> real vector - val GetTabbedTextExtent : HDC * string * int list -> SIZE - val GetTextAlign : HDC -> TextAlign list - val GetTextCharacterExtra : HDC -> int - val GetTextColor : HDC -> COLORREF - val GetTextExtentExPoint : HDC * string * int option -> - {fit: int option, size: SIZE, extents: int list} - val GetTextExtentPoint32 : HDC * string -> SIZE - val GetTextFace : HDC -> string - val GetTextMetrics : HDC -> TEXTMETRIC - val RemoveFontResource : string -> unit - val SetMapperFlags : HDC * bool -> bool - val SetTextAlign : HDC * TextAlign list -> TextAlign list - val SetTextCharacterExtra : HDC * int -> int - val SetTextColor : HDC * COLORREF -> COLORREF - val SetTextJustification : HDC * int * int -> unit - val TabbedTextOut: HDC * POINT * string * int list * int -> SIZE - val TextOut : HDC * POINT * String.string -> unit - end - = -struct - local - open Foreign Base GdiBase - (*val HEIGHT = INT: int conversion*) - in - type COLORREF = Color.COLORREF - type SIZE = SIZE and POINT = POINT and RECT = RECT - type HDC = HDC and HFONT = HFONT - - open FontBase (* Contains the types used in LOGFONT. *) - - datatype TextAlign = - TA_NOUPDATECP | TA_UPDATECP | TA_LEFT | TA_RIGHT | TA_CENTER | TA_TOP | TA_BOTTOM | TA_BASELINE - local - val tab = [ - (TA_NOUPDATECP, 0w0), - (TA_UPDATECP, 0w1), - (TA_LEFT, 0w0), - (TA_RIGHT, 0w2), - (TA_CENTER, 0w6), - (TA_TOP, 0w0), - (TA_BOTTOM, 0w8), - (TA_BASELINE, 0w24) - ] - val TEXTALIGN = tableSetConversion(tab, NONE) - in - val GetTextAlign = winCall1(gdi "GetTextAlign") (cHDC) TEXTALIGN - val SetTextAlign = winCall2(gdi "SetTextAlign") (cHDC,TEXTALIGN) TEXTALIGN - end - - (*TYPE: DrawTextMode *) - datatype DrawTextMode = DT_TOP | DT_LEFT | DT_CENTER | DT_RIGHT | DT_VCENTER | DT_BOTTOM | - DT_WORDBREAK | DT_SINGLELINE | DT_EXPANDTABS | DT_NOCLIP | DT_EXTERNALLEADING | - DT_CALCRECT | DT_NOPREFIX | DT_INTERNAL | DT_TABSTOP of int - local - val tab = [ - (DT_TOP, 0wx0000), - (DT_LEFT, 0wx0000), - (DT_CENTER, 0wx0001), - (DT_RIGHT, 0wx0002), - (DT_VCENTER, 0wx0004), - (DT_BOTTOM, 0wx0008), - (DT_WORDBREAK, 0wx0010), - (DT_SINGLELINE, 0wx0020), - (DT_EXPANDTABS, 0wx0040), - (DT_NOCLIP, 0wx0100), - (DT_EXTERNALLEADING, 0wx0200), - (DT_CALCRECT, 0wx0400), - (DT_NOPREFIX, 0wx0800), - (DT_INTERNAL, 0wx1000) - ] - val tabStop = 0wx0080 - fun toInt (DT_TABSTOP i) = Word32.orb(tabStop, Word32.fromInt i*0w256) | toInt _ = raise Match - fun fromInt i = - if Word32.andb(i, tabStop) = tabStop - then DT_TABSTOP(Word32.toInt(Word32.andb((Word32.>>(i, 0w8)), 0wxff))) - else raise Match; - val DRAWTEXTMODE = tableSetConversion(tab, SOME(fromInt, toInt)) - in - val DrawText = - winCall4(user "DrawTextA") (cHDC,cString,cConstStar cRect,DRAWTEXTMODE) cInt - end - - val AddFontResource = winCall1(gdi "AddFontResourceA") (cString) cInt - val CreateScalableFontResource = - winCall4(gdi "CreateScalableFontResourceA") (cDWORD,cString,cString,cString) (successState "CreateScalableFontResource") - - - val GetTextCharacterExtra = winCall1(gdi "GetTextCharacterExtra") (cHDC) cInt - val RemoveFontResource = winCall1(gdi "RemoveFontResourceA") (cString) (successState "RemoveFontResource") - - local - val cFONTMAPPERFLAG: bool conversion = - absConversion{rep=fn true => 0w1 | false => 0w0, abs=fn n => n <> 0w0} cDWORDw - in - val SetMapperFlags = winCall2(gdi "SetMapperFlags") (cHDC, cFONTMAPPERFLAG) cFONTMAPPERFLAG - end - - val SetTextCharacterExtra = winCall2(gdi "SetTextCharacterExtra") (cHDC,cInt) cInt - val SetTextJustification = winCall3(gdi "SetTextJustification") (cHDC,cInt,cInt) (successState "SetTextJustification") - val GetTextColor = winCall1 (gdi "GetTextColor") (cHDC) cCOLORREF - and SetTextColor = winCall2 (gdi "SetTextColor") (cHDC, cCOLORREF) cCOLORREF - - local - val getAspectRatioFilterEx = - winCall2(gdi "GetAspectRatioFilterEx") (cHDC, cStar cSize)(successState "GetAspectRatioFilterEx") - in - fun GetAspectRatioFilterEx hdc = - let - val s = ref{cx=0, cy= 0} - in - getAspectRatioFilterEx(hdc, s); - !s - end - end - - local - val createFont = - winCall14 (gdi "CreateFontA") (cInt, cInt, cInt, cInt, cInt (* FONTWEIGHT *), cDWORDw, cDWORDw, cDWORDw, - cDWORDw (*CHARACTERSET *), cDWORDw (* OUTPUTPRECISION *), cDWORDw (* CLIPPINGPRECISION *), - cDWORDw (* OUTPUTQUALITY *), cDWORDw (* FONTPITCHANDFAMILY *), cString) cHFONT - fun bToch false = 0w0 | bToch true = 0w1 - val w8ToW32 = Word32.fromLargeWord o Word8.toLargeWord - in - fun CreateFont({height: int, width: int, escapement: int, orientation: int, - weight: FontWeight, italic: bool, underline: bool, strikeOut: bool, - charSet: CharacterSet, outputPrecision: OutputPrecision, - clipPrecision: ClippingPrecision list, quality: OutputQuality, - pitch: FontPitch, family: FontFamily, faceName: string}: LOGFONT) = - createFont(height, width, escapement, orientation, weight, bToch italic, bToch underline, - bToch strikeOut, w8ToW32(charsetToW8 charSet), w8ToW32(outPrecToW8 outputPrecision), - clipPrecSetToW32 clipPrecision, w8ToW32(outQualToW8 quality), - w8ToW32(pitchAndFamilyToW8 (pitch, family)), - if size faceName > 31 then String.substring(faceName, 0, 31) else faceName) - end - - (* CreateFont and CreateFontIndirect take the same arguments in ML. *) - val CreateFontIndirect = - winCall1 (gdi "CreateFontIndirectA") (cConstStar cLOGFONT) cHFONT - - datatype ExtendedTextMode = ETO_OPAQUE | ETO_CLIPPED | ETO_GLYPH_INDEX | - ETO_RTLREADING | ETO_IGNORELANGUAGE - local - val tab = [ - (ETO_OPAQUE, 0wx0002), - (ETO_CLIPPED, 0wx0004), - (ETO_GLYPH_INDEX, 0wx0010), - (ETO_RTLREADING, 0wx0080), - (ETO_IGNORELANGUAGE, 0wx1000) - ] - in - val EXTENDEDTEXTOUT = tableSetConversion(tab, NONE) - end - - local - val extTextOut = - winCall8 (gdi "ExtTextOutA") - (cHDC,cInt,cInt, EXTENDEDTEXTOUT, cOptionPtr (cConstStar cRect), cString, cUint, cPointer) - (successState "ExtTextOut") - val l2Vec = list2Vector cInt - in - fun ExtTextOut (h,({x,y}:POINT), option, rect, text, gapl) = - let - val slen = String.size text - val (gaps, _) = - case gapl of - [] => (Memory.null, 0) - | _ => l2Vec gapl - (* The Rect is optional but really depends on the ETO_OPAQUE or ETO_CLIPPED - options. *) - in - extTextOut(h, x, y, option, rect, text, slen, gaps) - handle ex => (Memory.free gaps; raise ex); - Memory.free gaps - end - end - - local - val ABC = cStruct3(cInt, cUint, cInt) - val getCharABCWidths = - winCall4 (gdi "GetCharABCWidthsA") - (cHDC, cUint, cUint, cPointer) (successState "GetCharABCWidths") - val getVec = getVectorResult ABC - in - fun GetCharABCWidths (h, c1: char, c2: char) = - let - fun getCharABC(abcarr, count) = - (getCharABCWidths(h, ord c1, ord c2, abcarr); count) - in - getVec getCharABC (ord c2 - ord c1 + 1) - end - end - - local - val ABC = cStruct3(cFloat, cFloat, cFloat) - val getCharABCWidthsFloat = - winCall4 (gdi "GetCharABCWidthsFloatA") - (cHDC, cUint, cUint, cPointer) (successState "GetCharABCWidthsFloat") - val getVec = getVectorResult ABC - in - fun GetCharABCWidthsFloat (h,c1,c2) = - let - fun getCharABC(abcarr, count) = - (getCharABCWidthsFloat(h, ord c1, ord c2, abcarr); count) - in - getVec getCharABC (ord c2 - ord c1 + 1) - end - end - - local - val getCharWidth32 = - winCall4 (gdi "GetCharWidth32A") - (cHDC, cUint, cUint, cPointer) (successState "GetCharWidth32") - val getVec = getVectorResult cInt - in - fun GetCharWidth32 (h,c1,c2) = - let - fun getCharW(vec, count) = - (getCharWidth32(h, ord c1, ord c2, vec); count) - in - getVec getCharW (ord c2 - ord c1 + 1) - end - end - - local - val getCharWidthFloat = - winCall4 (gdi "GetCharWidthFloatA") - (cHDC,cUint, cUint, cPointer) (successState "GetCharWidthFloat") - val getVec = getVectorResult cFloat - in - fun GetCharWidthFloat (h,c1,c2) = - let - fun getCharW(vec, count) = - (getCharWidthFloat(h, ord c1, ord c2, vec); count) - in - getVec getCharW (ord c2 - ord c1 + 1) - end - end - - local - val getTextExtentPoint32 = - winCall4 (gdi "GetTextExtentPoint32A") - (cHDC, cString, cInt, cStar cSize) (successState "GetTextExtentPoint32") - in - fun GetTextExtentPoint32 (h, s) = - let - val r = ref {cx=0, cy=0} - val () = getTextExtentPoint32(h, s, size s, r) - in - !r - end - end - - local - val textOut = - winCall5 (gdi "TextOutA") - (cHDC,cInt,cInt,cString,cInt) (successState "TextOut") - in - fun TextOut (h,({x,y}:POINT),s) = textOut(h, x, y, s, size s) - end - - - datatype TextMetricPitch = TMPF_FIXED_PITCH | TMPF_VECTOR | TMPF_TRUETYPE | TMPF_DEVICE - - (* N.B. TMPF_FIXED_PITCH is included if the font is NOT fixed pitch!! *) - type TEXTMETRIC = - { height: int, ascent: int, descent: int, internalLeading: int, externalLeading: int, - aveCharWidth: int, maxCharWidth: int, weight: int, overhang: int, - digitizedAspectX: int, digitizedAspectY: int, firstChar: char, lastChar: char, - defaultChar: char, breakChar: char, italic: bool, underlined: bool, struckOut: bool, - pitch: TextMetricPitch list, family: FontFamily, charSet : CharacterSet } - local - val TEXTMETRIC = - cStruct20(cLong, cLong, cLong, cLong, cLong, cLong, cLong, cLong, cLong, cLong, - cLong, cChar, cChar, cChar, cChar, cUint8w, cUint8w, cUint8w, cUint8w, cUint8w) - val getTextMetrics = - winCall2 (gdi "GetTextMetricsA") (cHDC, cStar TEXTMETRIC) (successState "GetTextMetrics") - val tmpfTab = [ - (TMPF_FIXED_PITCH, 0wx1), (* N.B. This is the opposite *) - (TMPF_VECTOR, 0wx2), - (TMPF_TRUETYPE, 0wx4), - (TMPF_DEVICE, 0wx8) - ] - val (_, tmpfFromW32) = tableSetLookup(tmpfTab, NONE) - in - - fun GetTextMetrics hdc : TEXTMETRIC = - let - val r = ref (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, #" ", #" ", #" ", #" ", 0w0, 0w0, 0w0, 0w0, 0w0) - val () = getTextMetrics (hdc, r) - val (height, ascent, descent, internalLeading, externalLeading, - aveCharWidth, maxCharWidth, weight, overhang, - digitizedAspectX, digitizedAspectY, firstChar, lastChar, - defaultChar, breakChar, italic, underlined, struckOut, - pitchAndFamily, charSet) = !r - (*val (fromChs, _, _) = breakConversion CHARACTERSET*) - val family = toFamily(Word8.andb(pitchAndFamily, 0wxf0)) - val pitch = tmpfFromW32(Word32.fromLargeWord(Word8.toLargeWord(Word8.andb(pitchAndFamily, 0wxf)))) - in - { - height = height, ascent = ascent, descent = descent, internalLeading = internalLeading, - externalLeading = externalLeading, aveCharWidth = aveCharWidth, maxCharWidth = maxCharWidth, - weight = weight, overhang = overhang, digitizedAspectX = digitizedAspectX, - digitizedAspectY = digitizedAspectY, firstChar = firstChar, lastChar = lastChar, - defaultChar = defaultChar, breakChar = breakChar, italic = italic <> 0w0, - underlined = underlined <> 0w0, struckOut = struckOut <> 0w0, - family = family, pitch = pitch, charSet = charsetFromW8 charSet - } - end - end - - local - val getFaceCall = winCall3(gdi "GetTextFaceA") (cHDC, cInt, cPointer) cInt - in - fun GetTextFace hdc : string = - getStringWithNullIsLength(fn(vec, len) => getFaceCall(hdc, len, vec)) - end - - local - val getTextExtentExPoint = - winCall7(gdi "GetTextExtentExPointA") - (cHDC, cString, cInt, cInt, cPointer, cPointer, cStar cSize) (successState "GetTextExtentExPoint") - val {load=loadInt, ctype={size=sizeInt, ...}, ...} = breakConversion cInt - in - fun GetTextExtentExPoint(hdc: HDC, s: string, maxWidth: int option) : - {fit: int option, extents: int list, size: SIZE} = - let - val count = size s - open Memory - infix 6 ++ - val vec = malloc(Word.fromInt count * sizeInt) - (* The lpnFit argument controls whether we get the maximum no. of chars. *) - val lpnFit = - case maxWidth of - NONE => null - | SOME _ => malloc sizeInt - val sizeVec = ref {cx=0, cy=0} - val () = - getTextExtentExPoint - (hdc, s, count, getOpt(maxWidth, 0), lpnFit, vec, sizeVec) - handle ex => (free vec; free lpnFit; raise ex) - val fit = case maxWidth of NONE => NONE | _ => SOME(loadInt lpnFit) - fun loadExt i = loadInt(vec ++ Word.fromInt i * sizeInt) - val extents = List.tabulate(getOpt(fit, count), loadExt) - val () = free vec - val () = free lpnFit - in - {fit = fit, extents = extents, size = ! sizeVec} - end - end - - local - val tabbedTextOut = - winCall8 (user "TabbedTextOutA") (cHDC, cInt, cInt, cString, cInt, cInt, cPointer, cInt) cDWORDw - val list2vec = list2Vector cInt - in - fun TabbedTextOut(hdc, {x, y}: POINT, str, tabs, origin): SIZE = - let - val (tabVec, nTabs) = - case tabs of - [] => (Memory.null, 0) (* Make the vector null. *) - | _ => list2vec tabs - val res = - tabbedTextOut(hdc, x, y, str, size str, nTabs, tabVec, origin) - handle ex => (Memory.free tabVec; raise ex) - val () = Memory.free tabVec - val () = checkResult(res <> 0w0) - in - (* Zero represents an error. But it's also possible to return zero if - the string is empty. *) - {cx = Word.toInt(LOWORD res), cy = Word.toInt(HIWORD res)} - end - end - - local - val tabbedTextExtent = - winCall5 (user "GetTabbedTextExtentA") (cHDC, cString, cInt, cInt, cPointer) cDWORDw - (*(POSINT "GetTabbedTextExtent")*) - in - fun GetTabbedTextExtent(hdc, str, tabs): SIZE = - let - val (tabVec, nTabs) = - case tabs of - [] => (Memory.null, 0) (* Make the vector null. *) - | _ => list2Vector cInt tabs - val res = - tabbedTextExtent(hdc, str, size str, nTabs, tabVec) - handle ex => (Memory.free tabVec; raise ex) - val () = Memory.free tabVec - val () = checkResult(res <> 0w0) - in - {cx = Word.toInt(LOWORD res), cy = Word.toInt(HIWORD res)} - end - end - - (* - Other Font and Text functions: - DrawTextEx - EnumFontFamiliesEx - EnumFontFamExProc - GetCharacterPlacement - GetFontData - GetFontLanguageInfo - GetFontUnicodeRanges - GetGlyphIndices - GetGlyphOutline - GetKerningPairs - GetOutlineTextMetrics - GetRasterizerCaps - GetTabbedTextExtent - PolyTextOut - *) - end -end; diff --git a/mlsource/extra/Win/FontBase.sml b/mlsource/extra/Win/FontBase.sml deleted file mode 100644 index 016b0308..00000000 --- a/mlsource/extra/Win/FontBase.sml +++ /dev/null @@ -1,217 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure FontBase = -struct - local - open Foreign Base - in - datatype OutputQuality = - DEFAULT_QUALITY | DRAFT_QUALITY | PROOF_QUALITY | ANTIALIASED_QUALITY | CLEARTYPE_QUALITY | NONANTIALIASED_QUALITY - local - val tab = [ - (DEFAULT_QUALITY, 0w0: Word8.word), - (DRAFT_QUALITY, 0w1), - (PROOF_QUALITY, 0w2), - (NONANTIALIASED_QUALITY, 0w3), - (ANTIALIASED_QUALITY, 0w4), - (CLEARTYPE_QUALITY, 0w5) - ] - in - val (outQualToW8, outQualFromW8) = tableLookup(tab, NONE) - end - - datatype CharacterSet = ANSI_CHARSET | DEFAULT_CHARSET | SYMBOL_CHARSET | MAC_CHARSET | - SHIFTJIS_CHARSET | HANGEUL_CHARSET | JOHAB_CHARSET | GB2312_CHARSET | - CHINESEBIG5_CHARSET | GREEK_CHARSET | TURKISH_CHARSET | VIETNAMESE_CHARSET | - HEBREW_CHARSET | ARABIC_CHARSET | BALTIC_CHARSET | RUSSIAN_CHARSET | - THAI_CHARSET | EASTEUROPE_CHARSET | OEM_CHARSET - - local - val tab = [ - (ANSI_CHARSET, 0wx00: Word8.word), - (DEFAULT_CHARSET, 0wx01), - (SYMBOL_CHARSET, 0wx02), - (MAC_CHARSET, 0wx4D), - (SHIFTJIS_CHARSET, 0wx80), - (HANGEUL_CHARSET, 0wx81), - (JOHAB_CHARSET, 0wx82), - (GB2312_CHARSET, 0wx86), - (CHINESEBIG5_CHARSET, 0wx88), - (GREEK_CHARSET, 0wxA1), - (TURKISH_CHARSET, 0wxA2), - (VIETNAMESE_CHARSET, 0wxA3), - (HEBREW_CHARSET, 0wxB1), - (ARABIC_CHARSET, 0wxB2), - (BALTIC_CHARSET, 0wxBA), - (RUSSIAN_CHARSET, 0wxCC), - (THAI_CHARSET, 0wxDE), - (EASTEUROPE_CHARSET, 0wxEE), - (OEM_CHARSET, 0wxff) - ] - in - val (charsetToW8, charsetFromW8) = tableLookup(tab, NONE) - end - - (* In the underlying CreateFont call the pitch and family are ORed together. *) - (*TYPE: FontFamily *) - datatype FontFamily = FF_DONTCARE | FF_ROMAN | FF_SWISS | FF_MODERN | - FF_SCRIPT| FF_DECORATIVE - - and FontPitch = DEFAULT_PITCH | FIXED_PITCH | VARIABLE_PITCH - - local - open Word8 - val tab1 = [ - (DEFAULT_PITCH, 0w0), - (FIXED_PITCH, 0w1), - (VARIABLE_PITCH, 0w2)] - and tab2 = [ - (FF_DONTCARE, 0wx00 (* (0<<4) Don't care or don't know. *)), - (FF_ROMAN, 0wx10 (* (1<<4) Variable stroke width, serifed. *)), - (FF_SWISS, 0wx20 (* (2<<4) Variable stroke width, sans~serifed. *)), - (FF_MODERN, 0wx30 (* (3<<4) Constant stroke width, serifed or sans~serifed. *)), - (FF_SCRIPT, 0wx40 (* (4<<4) Cursive, etc. *)), - (FF_DECORATIVE, 0wx50 (* (5<<4) Old English, etc. *))] - val (fromPitch, toPitch) = tableLookup(tab1, NONE) - and (fromFamily, toFamily) = tableLookup(tab2, NONE) - in - val toFamily = toFamily (* This is used in GetTextMetrics. *) - fun pitchAndFamilyToW8 (pitch, family) = orb(fromPitch pitch, fromFamily family) - fun pitchAndFamilyFromW8 i = (toPitch(andb(i, 0w3)), toFamily(andb(i, 0wxf0))) - end - - (*TYPE: FontWeight - This type is really int, not an abstract type. *) - type FontWeight = int - (* Values between 0 and 1000 *) - (*val FONTWEIGHT = cLong*) (* It's int for CreateFont but LONG for LONGFONT. *) - - val FW_DONTCARE = 0 - val FW_THIN = 100 - val FW_EXTRALIGHT = 200 - val FW_LIGHT = 300 - val FW_NORMAL = 400 - val FW_MEDIUM = 500 - val FW_SEMIBOLD = 600 - val FW_BOLD = 700 - val FW_EXTRABOLD = 800 - val FW_HEAVY = 900 - val FW_ULTRALIGHT = FW_EXTRALIGHT - val FW_REGULAR = FW_NORMAL - val FW_DEMIBOLD = FW_SEMIBOLD - val FW_ULTRABOLD = FW_EXTRABOLD - val FW_BLACK = FW_HEAVY - - datatype OutputPrecision = OUT_DEFAULT_PRECIS | OUT_STRING_PRECIS | - OUT_CHARACTER_PRECIS | OUT_STROKE_PRECIS | OUT_TT_PRECIS | OUT_DEVICE_PRECIS | - OUT_RASTER_PRECIS | OUT_TT_ONLY_PRECIS | OUT_OUTLINE_PRECIS | - OUT_SCREEN_OUTLINE_PRECIS - - local - val tab = [ - (OUT_DEFAULT_PRECIS, 0w0: Word8.word), - (OUT_STRING_PRECIS, 0w1), - (OUT_CHARACTER_PRECIS, 0w2), - (OUT_STROKE_PRECIS, 0w3), - (OUT_TT_PRECIS, 0w4), - (OUT_DEVICE_PRECIS, 0w5), - (OUT_RASTER_PRECIS, 0w6), - (OUT_TT_ONLY_PRECIS, 0w7), - (OUT_OUTLINE_PRECIS, 0w8), - (OUT_SCREEN_OUTLINE_PRECIS, 0w9) - ] - in - val (outPrecToW8, outPrecFromW8) = tableLookup(tab, NONE) - end - - (* TODO: This is a bit set. *) - datatype ClippingPrecision = - CLIP_DEFAULT_PRECIS | CLIP_STROKE_PRECIS | CLIP_LH_ANGLES | CLIP_DFA_DISABLE | CLIP_EMBEDDED - (* CLIP_CHARACTER_PRECIS and CLIP_TT_ALWAYS "should not be used" - [CLIP_DEFAULT_PRECIS] is the same as [] i.e. zero. *) - local - val tab = [ - (CLIP_DEFAULT_PRECIS, 0wx0), - (CLIP_STROKE_PRECIS, 0wx2), - (CLIP_LH_ANGLES, 0wx10), - (CLIP_DFA_DISABLE, 0w40), - (CLIP_EMBEDDED, 0w80) - ] - in - val (clipPrecSetToW32, clipPrecSetFromW32) = tableSetLookup(tab, NONE) - end - - type LOGFONT = - { - height : int, - width : int, - escapement : int, - orientation : int, - weight : FontWeight, - italic : bool, - underline : bool, - strikeOut : bool, - charSet : CharacterSet, - outputPrecision: OutputPrecision, - clipPrecision : ClippingPrecision list, - quality : OutputQuality, - pitch: FontPitch, - family: FontFamily, - faceName : string - } - - local - val cLogFont = - cStruct14(cLong, cLong, cLong, cLong, cLong, cUint8w, cUint8w, cUint8w, cUint8w, - cUint8w, cUint8w, cUint8w, cUint8w, cCHARARRAY 32) - fun chToB 0w0 = false | chToB _ = true - fun bToch false = 0w0 | bToch true = 0w1 - - fun toLF(height, width, escapement, orientation, weight, italic, underline, - strikeOut, charSet, outputPrecision, clipPrecision, quality, - pitchFamily, faceName) : LOGFONT = - let - val (pitch, family) = pitchAndFamilyFromW8 pitchFamily - in - {height = height, width = width, escapement = escapement, - orientation = orientation, weight = weight, italic = chToB italic, - underline = chToB underline, strikeOut = chToB strikeOut, - charSet = charsetFromW8 charSet, - outputPrecision = outPrecFromW8 outputPrecision, - clipPrecision = clipPrecSetFromW32(Word32.fromLargeWord(Word8.toLargeWord clipPrecision)), - quality = outQualFromW8 quality, pitch = pitch, family = family, - faceName = faceName} - end - - fun fromLF ({height, width, escapement, orientation, weight, italic, underline, - strikeOut, charSet, outputPrecision, clipPrecision, quality, - pitch, family, faceName}: LOGFONT) = - let - val pitchFamily = pitchAndFamilyToW8(pitch, family) - in - (height, width, escapement, orientation, weight, bToch italic, - bToch underline, bToch strikeOut, charsetToW8 charSet, - outPrecToW8 outputPrecision, - Word8.fromLargeWord(Word32.toLargeWord (clipPrecSetToW32 clipPrecision)), - outQualToW8 quality, pitchFamily, faceName) - end - in - val cLOGFONT = absConversion{abs=toLF, rep=fromLF} cLogFont - end - end -end; diff --git a/mlsource/extra/Win/GdiBase.sml b/mlsource/extra/Win/GdiBase.sml deleted file mode 100644 index 70636e47..00000000 --- a/mlsource/extra/Win/GdiBase.sml +++ /dev/null @@ -1,294 +0,0 @@ -(* - Copyright (c) 2001, 2015, 2019 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure GdiBase = -struct - local - open Foreign Base - in - local - datatype RasterOpCode = - W of int - and QuaternaryRop = Y of int - in - type RasterOpCode = RasterOpCode - type QuaternaryRop = QuaternaryRop - val cRASTEROPCODE = absConversion {abs = W, rep = fn W n => n} cDWORD - val cQUATERNARY = absConversion {abs = Y, rep = fn Y n => n} cDWORD - - val SRCCOPY = W (0x00CC0020 (* dest = source *)) - val SRCPAINT = W (0x00EE0086 (* dest = source OR dest *)) - val SRCAND = W (0x008800C6 (* dest = source AND dest *)) - val SRCINVERT = W (0x00660046 (* dest = source XOR dest *)) - val SRCERASE = W (0x00440328 (* dest = source AND (NOT dest ) *)) - val NOTSRCCOPY = W (0x00330008 (* dest = (NOT source) *)) - val NOTSRCERASE = W (0x001100A6 (* dest = (NOT src) AND (NOT dest) *)) - val MERGECOPY = W (0x00C000CA (* dest = (source AND pattern) *)) - val MERGEPAINT = W (0x00BB0226 (* dest = (NOT source) OR dest *)) - val PATCOPY = W (0x00F00021 (* dest = pattern *)) - val PATPAINT = W (0x00FB0A09 (* dest = DPSnoo *)) - val PATINVERT = W (0x005A0049 (* dest = pattern XOR dest *)) - val DSTINVERT = W (0x00550009 (* dest = (NOT dest) *)) - val BLACKNESS = W (0x00000042 (* dest = BLACK *)) - val WHITENESS = W (0x00FF0062 (* dest = WHITE *)) - - fun MAKEROP4{fore = (W fore): RasterOpCode, back = (W back): RasterOpCode} = - Y(Word.toInt(Word.orb(Word.fromInt fore, Word.andb(Word.<<(Word.fromInt back, 0w8), 0wxFF000000)))) - end - - - (* BITMAPS *) - type BITMAP = - { width: int, height: int, widthBytes: int, planes: int, bitsPerPixel: int, - bits: Word8Vector.vector option } - local - val bitmapStruct = cStruct7(cLong, cLong, cLong, cLong, cWORD, cWORD, cPointer) - val {load = fromCStr, store = toCStr, ctype = lpStruct} = breakConversion bitmapStruct - open Memory - - fun storeBmp(v: voidStar, {width, height, widthBytes, planes, bitsPerPixel, bits}: BITMAP) = - let - val m = case bits of NONE => Memory.null | SOME b => toCWord8vec b - in - toCStr(v, (0, width, height, widthBytes, planes, bitsPerPixel, m)); - fn () => Memory.free m - end - - fun loadbmp(v: voidStar): BITMAP = - let - val (_, width, height, widthBytes, planes, bitsPerPixel, bits) = - fromCStr v - val bits = - if bits = Memory.null - then NONE - else SOME (fromCWord8vec (bits, height * widthBytes)) - in - {width = width, height = height, widthBytes = widthBytes, planes = planes, - bitsPerPixel = bitsPerPixel, bits = bits} - end - in - val cBITMAP = makeConversion{store=storeBmp, load=loadbmp, ctype = lpStruct} - end - - (* Line and Path *) - datatype PointType = - PT_MOVETO | PT_LINETO | PT_BEZIERTO | PT_LINETOANDCLOSE | PT_BEZIERTOANDCLOSE - local - val tab = [ - (PT_LINETO, 2), - (PT_BEZIERTO, 4), - (PT_MOVETO, 6), - (PT_LINETOANDCLOSE, 3), - (PT_BEZIERTOANDCLOSE, 5) - ] - val (toInt, fromInt) = tableLookup(tab, NONE) - in - val cPOINTTYPE = - absConversion {abs = fromInt, rep = toInt} cUint8 (* Encoded as single bytes *) - end - - (* COLORREF - this is an RGB encoded into a 32-bit word. *) - abstype COLORREF = C of Word32.word - with - local - open Word32 - infix 7 andb - infix 6 orb - infix 4 << >> - in - fun RGB{red: int, green: int, blue: int} = - C(fromInt red andb 0wxff - orb (fromInt green andb 0wxff << 0w8) - orb (fromInt blue andb 0wxff << 0w16)) - - fun PALETTERGB rgb = let val C r = RGB rgb in C(r orb 0wx02000000) end - - fun toRGB(C p) = - { red = toInt(p andb 0wxff), - green = toInt((p >> 0w8) andb 0wxff), - blue = toInt((p >> 0w16) andb 0wxff) } - end - val cCOLORREF = absConversion {abs=C, rep = fn(C v) => v} cDWORDw - end - - (* Brush *) - - datatype BrushStyle = BS_SOLID | BS_HOLLOW | BS_HATCHED of HatchStyle | BS_PATTERN of HBITMAP - (* | BS_DIBPATTERN of PACKEDDIB *) - and HatchStyle = - HS_HORIZONTAL | HS_VERTICAL | HS_FDIAGONAL | HS_BDIAGONAL | HS_CROSS | HS_DIAGCROSS - - type LOGBRUSH = BrushStyle * COLORREF - local - val cLBRUSH = cStruct3(cUint, cCOLORREF, cULONG_PTR) - val {load=loadStr, store=storeStr, ctype=lbStruct} = breakConversion cLBRUSH - val hbtab = [ - (HS_HORIZONTAL, 0 (* ~~~~~ *)), - (HS_VERTICAL, 1 (* ||||| *)), - (HS_FDIAGONAL, 2 (* \\\\\ *)), - (HS_BDIAGONAL, 3 (* (* /// *) *)), - (HS_CROSS, 4 (* +++++ *)), - (HS_DIAGCROSS, 5 (* xxxxx *)) - ] - val (fromHB, toHB) = tableLookup(hbtab, NONE) - val hgdiAsInt = SysWord.toInt o Memory.voidStar2Sysword o voidStarOfHandle - and intAsHgdi = handleOfVoidStar o Memory.sysWord2VoidStar o SysWord.fromInt - - fun storeLB(m, (BS_SOLID, cr)) = storeStr(m, (0, cr, 0)) - | storeLB(m, (BS_HOLLOW, cr)) = storeStr(m, (1, cr (* actually ignored *), 0)) - | storeLB(m, (BS_HATCHED hs, cr)) = storeStr(m, (2, cr, fromHB hs)) - | storeLB(m, (BS_PATTERN hb, cr)) = - storeStr(m, (3, cr (* actually ignored *), hgdiAsInt hb)) - (* | toLB(BS_DIBPATTERN dp, cr) = toStr(5, cr (* treated specially *), ??? dp) *) - - fun loadLB (v: Memory.voidStar): LOGBRUSH = - let - val (t, cr, i) = loadStr v - in - case t of - 0 => (BS_SOLID, cr) - | 1 => (BS_HOLLOW, cr) - | 2 => (BS_HATCHED(toHB i), cr) - | 3 => (BS_PATTERN(intAsHgdi i), cr) - | _ => raise Fail "Unknown brush type" - end - in - val cHATCHSTYLE = absConversion {abs = toHB, rep = fromHB} cInt - val cLOGBRUSH = makeConversion{load=loadLB, store=storeLB, ctype = lbStruct} - end - - (* Pen *) - - (* This is confused. Many of these are only applicable for ExtCreatePen and most are - mutually exclusive. *) - datatype PenStyle = PS_SOLID | PS_DASH | PS_DOT | PS_DASHDOT | PS_DASHDOTDOT | PS_NULL | - PS_INSIDEFRAME | PS_USERSTYLE | PS_ALTERNATE | PS_ENDCAP_ROUND | PS_ENDCAP_SQUARE | - PS_ENDCAP_FLAT | PS_JOIN_ROUND | PS_JOIN_BEVEL | PS_JOIN_MITER | PS_COSMETIC | PS_GEOMETRIC - - - type LOGPEN = PenStyle * int option * COLORREF - - local - val LPEN = cStruct3(cUintw, cPoint, cCOLORREF) - val {load=loadStr, store=storeStr, ctype=lpStruct} = breakConversion LPEN - val tab = [ - (PS_SOLID, 0w0), - (PS_DASH, 0w1 (* ~~~~~~~ *)), - (PS_DOT, 0w2 (* ....... *)), - (PS_DASHDOT, 0w3 (* _._._._ *)), - (PS_DASHDOTDOT, 0w4 (* _.._.._ *)), - (PS_NULL, 0w5), - (PS_INSIDEFRAME, 0w6), - (PS_USERSTYLE, 0w7), - (PS_ALTERNATE, 0w8), - (PS_ENDCAP_ROUND, 0wx00000000), - (PS_ENDCAP_SQUARE, 0wx00000100), - (PS_ENDCAP_FLAT, 0wx00000200), - (PS_JOIN_ROUND, 0wx00000000), - (PS_JOIN_BEVEL, 0wx00001000), - (PS_JOIN_MITER, 0wx00002000), - (PS_COSMETIC, 0wx00000000), - (PS_GEOMETRIC, 0wx00010000) - ] - val (fromPS, toPS) = tableLookup(tab, NONE) - - fun storeLP(m, (ps, width, cr): LOGPEN) = - storeStr(m, (fromPS ps, {x=getOpt(width, 0), y=0}, cr)) - - fun loadLP v: LOGPEN = - let - val (ps, {x=width, ...}, cr) = loadStr v - in - (toPS ps, case width of 0 => NONE | i => SOME i, cr) - end - in - val cPENSTYLE = tableSetConversion(tab, NONE) - val cLOGPEN = makeConversion{store=storeLP, load=loadLP, ctype=lpStruct} - end - - (* Transform *) - datatype MapMode = MM_TEXT | MM_LOMETRIC | MM_HIMETRIC | MM_LOENGLISH | MM_HIENGLISH | - MM_TWIPS | MM_ISOTROPIC | MM_ANISOTROPIC - val MM_MIN = MM_TEXT - val MM_MAX = MM_ANISOTROPIC - val MM_MAX_FIXEDSCALE = MM_TWIPS - - local - val tab = [ - (MM_TEXT, 1), - (MM_LOMETRIC, 2), - (MM_HIMETRIC, 3), - (MM_LOENGLISH, 4), - (MM_HIENGLISH, 5), - (MM_TWIPS, 6), - (MM_ISOTROPIC, 7), - (MM_ANISOTROPIC, 8) - ] - (* SetMapMode and GetMapMode return 0 in the event of an error. *) - fun toInt _ = raise Match - fun fromInt i = (checkResult(i <> 0); raise Match); - in - val cMAPMODE = tableConversion(tab, SOME(fromInt, toInt)) cInt (* int for Get/SetMapMode *) - end - - (* REGIONS *) - local - datatype RegionOperation = - W of int - in - type RegionOperation = RegionOperation - val REGIONOPERATION = absConversion {abs = W, rep = fn W n => n} cInt - - val RGN_ERROR = W (0) - val RGN_AND = W (1) - val RGN_OR = W (2) - val RGN_XOR = W (3) - val RGN_DIFF = W (4) - val RGN_COPY = W (5) - end - - local - datatype ResultRegion = - W of int - in - type ResultRegion = ResultRegion - val RESULTREGION = absConversion {abs = W, rep = fn W n => n} cInt - - val ERROR = W (0) - val NULLREGION = W (1) - val SIMPLEREGION = W (2) - val COMPLEXREGION = W (3) - end - - - type METAFILEPICT = {mm: MapMode, size: SIZE, hMF: HMETAFILE} - - local - val metaFilePict = cStruct3(cMAPMODE, cSize, cHMETAFILE) - val {store=storeMfp, load=loadMfp, ctype=mfpStruct} = breakConversion metaFilePict - fun storeCMfp(m, ({mm, size, hMF}: METAFILEPICT)) = storeMfp(m, (mm, size, hMF)) - fun loadCMfp v : METAFILEPICT = - let val (mm, size, hMF) = loadMfp v in {mm=mm, size=size, hMF=hMF} end - in - (* This is needed in the Clipboard structure. *) - val cMETAFILEPICT = makeConversion{store=storeCMfp, load=loadCMfp, ctype=mfpStruct} - end - - - end -end; diff --git a/mlsource/extra/Win/Globals.sml b/mlsource/extra/Win/Globals.sml deleted file mode 100644 index e95c7d1a..00000000 --- a/mlsource/extra/Win/Globals.sml +++ /dev/null @@ -1,61 +0,0 @@ -(* - Copyright (c) 2001, 2015, 2019 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) -structure Globals : - sig - eqtype 'a HANDLE - eqtype HINSTANCE - eqtype HWND - val hNull : 'a HANDLE - val isHNull : 'a HANDLE -> bool - - val ApplicationInstance : unit -> HINSTANCE - val GetLastError : unit -> OS.syserror - val MainWindow : unit -> HWND - end - = -struct - local - open Foreign - open Base - in - type 'a HANDLE = 'a HANDLE - val hNull = hNull - and isHNull = isHNull - type HINSTANCE = HINSTANCE - - type HWND = HWND - - val GetLastError = Base.GetLastError - - local - val getModHandle = - winCall1 (kernel "GetModuleHandleA") (cOptionPtr cString) cHINSTANCE - (* The current hInstance is also returned as Foreign.System.loadExecutable. *) - in - fun ApplicationInstance() = getModHandle NONE - end - - local - val FindWindow = - winCall2 (user "FindWindowA") (STRINGOPT, STRINGOPT) cHWND - in - fun MainWindow() = FindWindow(SOME "PolyMLWindowClass", SOME "Poly/ML") - end - - end -end; diff --git a/mlsource/extra/Win/Icon.sml b/mlsource/extra/Win/Icon.sml deleted file mode 100644 index ff95f742..00000000 --- a/mlsource/extra/Win/Icon.sml +++ /dev/null @@ -1,87 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Icon: - sig - type HICON and HINSTANCE and HDC - val CopyIcon : HICON -> HICON - val DestroyIcon : HICON -> unit - val DrawIcon : HDC * int * int * HICON -> unit - val ExtractIcon : HINSTANCE * string * int -> HICON - val IDI_APPLICATION : Resource.RESID - val IDI_ASTERISK : Resource.RESID - val IDI_ERROR : Resource.RESID - val IDI_EXCLAMATION : Resource.RESID - val IDI_HAND : Resource.RESID - val IDI_INFORMATION : Resource.RESID - val IDI_QUESTION : Resource.RESID - val IDI_WARNING : Resource.RESID - val IDI_WINLOGO : Resource.RESID - val LoadIcon : HINSTANCE * Resource.RESID -> HICON - end = -struct - local - open Foreign - open Base - open Resource - in - type HICON = HICON and HINSTANCE = HINSTANCE and HDC = HDC - val isHiconNull = isHgdiObjNull - - fun checkIcon c = (checkResult(not(isHiconNull c)); c) - - val CopyIcon = - checkIcon o winCall1 (user "CopyIcon") (cHICON) cHICON - - val DestroyIcon = - checkResult o winCall1 (user "DestroyIcon") (cHICON) cBool - - val DrawIcon = - checkResult o winCall4 (user "DrawIcon") (cHDC, cInt, cInt, cHICON) cBool - - val ExtractIcon = winCall3 (user "ExtractIcon") (cHINSTANCE, cString, cUint) cHICON - - val LoadIcon = - checkIcon o winCall2 (user "LoadIconA") (cHINSTANCE, cRESID) cHICON - - (* Built-in icons. *) - val IDI_APPLICATION = Resource.IdAsInt 32512 - val IDI_ASTERISK = Resource.IdAsInt 32516 - val IDI_EXCLAMATION = Resource.IdAsInt 32515 - val IDI_HAND = Resource.IdAsInt 32513 - val IDI_ERROR = IDI_HAND - val IDI_INFORMATION = IDI_ASTERISK - val IDI_QUESTION = Resource.IdAsInt 32514 - val IDI_WARNING = IDI_EXCLAMATION - val IDI_WINLOGO = Resource.IdAsInt 32517 - -(* -TODO: -CreateIcon - complicated -CreateIconFromResource - complicated -CreateIconFromResourceEx -CreateIconIndirect -DrawIconEx -ExtractAssociatedIcon -ExtractIconEx -GetIconInfo -LookupIconIdFromDirectory -LookupIconIdFromDirectoryEx -*) - end -end; diff --git a/mlsource/extra/Win/Keyboard.sml b/mlsource/extra/Win/Keyboard.sml deleted file mode 100644 index c64a0036..00000000 --- a/mlsource/extra/Win/Keyboard.sml +++ /dev/null @@ -1,77 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Keyboard: - sig - type HWND - val EnableWindow : HWND * bool -> bool - val GetActiveWindow : unit -> HWND option - val GetFocus : unit -> HWND option - val IsWindowEnabled : HWND -> bool - val SetActiveWindow : HWND -> HWND - val SetFocus : HWND option -> HWND option - end = -struct - local - open Foreign Base - fun checkWindow c = (checkResult(not(isHNull c)); c) - in - type HWND = HWND - val EnableWindow = winCall2 (user "EnableWindow") (cHWND, cBool) cBool - val GetActiveWindow = winCall0 (user "GetActiveWindow") () cHWNDOPT - val GetFocus = winCall0 (user "GetFocus") () cHWNDOPT - val IsWindowEnabled = winCall1 (user "IsWindowEnabled") (cHWND) cBool - val SetActiveWindow = - checkWindow o winCall1 (user "SetActiveWindow") (cHWND) cHWND - - (* The argument to SetFocus is an option because we may ignore input. - The result may be null if there was an error or if no window had focus. *) - val SetFocus = winCall1 (user "SetFocus") (cHWNDOPT) cHWNDOPT - end -end; - -(* -ActivateKeyboardLayout -GetAsyncKeyState -GetKeyboardLayout -GetKeyboardLayoutList -GetKeyboardLayoutName -GetKeyboardState -GetKeyNameText -GetKeyState -keybd_event -LoadKeyboardLayout -MapVirtualKey -MapVirtualKeyEx -OemKeyScan -RegisterHotKey -SendInput -SetKeyboardState -ToAscii -ToAsciiEx -ToUnicode -ToUnicodeEx -UnloadKeyboardLayout -UnregisterHotKey -VkKeyScan -VkKeyScanEx - -Obsolete Functions - -GetKBCodePage -*) diff --git a/mlsource/extra/Win/Line.sml b/mlsource/extra/Win/Line.sml deleted file mode 100644 index b9392535..00000000 --- a/mlsource/extra/Win/Line.sml +++ /dev/null @@ -1,151 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Line : - sig - type HDC - type RECT = { top: int, left: int, bottom: int, right: int } - type POINT = { x: int, y: int } - - datatype PointType = - PT_BEZIERTO - | PT_BEZIERTOANDCLOSE - | PT_LINETO - | PT_LINETOANDCLOSE - | PT_MOVETO - - eqtype ArcDirection - val AD_CLOCKWISE : ArcDirection - val AD_COUNTERCLOCKWISE : ArcDirection - - val AngleArc : HDC * int * int * int * real * real -> unit - val Arc : HDC * int * int * int * int * int * int * int * int -> unit - val ArcTo : HDC * int * int * int * int * int * int * int * int -> unit - val GetArcDirection : HDC -> ArcDirection - val LineTo : HDC * POINT -> unit - val MoveToEx : HDC * POINT -> POINT - val PolyBezier : HDC * POINT list -> unit - val PolyBezierTo : HDC * POINT list -> unit - val PolyDraw : HDC * (PointType * POINT) list -> unit - val Polyline : HDC * POINT list -> unit - val PolylineTo : HDC * POINT list -> unit - val SetArcDirection : HDC * ArcDirection -> ArcDirection - - end = -struct - local - open Foreign Base GdiBase - - val zeroPoint: POINT = {x=0, y=0} - in - type HDC = HDC and POINT = POINT and RECT = RECT - - datatype PointType = datatype PointType - - local - datatype ArcDirection = - W of int - in - type ArcDirection = ArcDirection - val ARCDIRECTION = absConversion {abs = W, rep = fn W n => n} cInt - - val AD_COUNTERCLOCKWISE = W(1) - val AD_CLOCKWISE = W(2) - end; - - val AngleArc = winCall6(gdi "AngleArc") (cHDC,cInt,cInt,cDWORD,cFloat,cFloat) (successState "AngleArc") - val Arc = winCall9(gdi "Arc") (cHDC,cInt,cInt,cInt,cInt,cInt,cInt,cInt,cInt) (successState "Arc") - val ArcTo = winCall9(gdi "ArcTo") (cHDC,cInt,cInt,cInt,cInt,cInt,cInt,cInt,cInt) (successState "ArcTo") - val GetArcDirection = winCall1(gdi "GetArcDirection") (cHDC) ARCDIRECTION - val SetArcDirection = winCall2(gdi "SetArcDirection") (cHDC,ARCDIRECTION) ARCDIRECTION - - local - val lineTo = winCall3 (gdi "LineTo") (cHDC,cInt,cInt) (successState "LineTo") - in - fun LineTo (h,({x,y}:POINT)) = lineTo (h,x,y) - end - - local - val moveToEx = winCall4 (gdi "MoveToEx") (cHDC, cInt, cInt, cStar cPoint) (successState "MoveToEx") - in - fun MoveToEx(h, ({x,y}:POINT)) = - let val p = ref zeroPoint in moveToEx(h, x, y, p); !p end - end - - local - val polyBezier = winCall3 (gdi "PolyBezier") (cHDC,cPointer,cDWORD) (successState "PolyBezier") - and polyBezierTo = winCall3 (gdi "PolyBezierTo") (cHDC,cPointer,cDWORD) (successState "PolyBezierTo") - and polyDraw = winCall4 (gdi "PolyDraw") (cHDC,cPointer,cPointer, cInt) (successState "PolyDraw") - and polyLine = winCall3 (gdi "Polyline") (cHDC,cPointer,cInt) (successState "Polyline") - and polyLineTo = winCall3 (gdi "PolylineTo") (cHDC,cPointer,cDWORD) (successState "PolylineTo") - - val ptList = list2Vector cPoint - val pTypeList = list2Vector cPOINTTYPE - in - fun PolyBezier (h, pts) = - let - val (ptarr, count) = ptList pts - in - polyBezier(h, ptarr, count) handle ex => (Memory.free ptarr; raise ex); - Memory.free ptarr - end - - and PolyBezierTo (h, pts) = - let - val (ptarr, count) = ptList pts - in - polyBezierTo(h, ptarr, count) handle ex => (Memory.free ptarr; raise ex); - Memory.free ptarr - end - - and PolyDraw (h, tplist: (PointType * POINT) list) = - let - val (typeList, pl) = ListPair.unzip tplist - val (ptarr, count) = ptList pl - val (farr, _) = pTypeList typeList - in - polyDraw(h, ptarr, farr,count) handle ex => (Memory.free ptarr; Memory.free farr; raise ex); - Memory.free ptarr; Memory.free farr - end - - and Polyline (h, pts: POINT list) = - let - val (ptarr, count) = ptList pts - in - polyLine(h, ptarr, count) handle ex => (Memory.free ptarr; raise ex); - Memory.free ptarr - end - - and PolylineTo (h, pts: POINT list) = - let - val (ptarr, count) = ptList pts - in - polyLineTo(h, ptarr, count) handle ex => (Memory.free ptarr; raise ex); - Memory.free ptarr - end - end - - (* - Other Line and Curve functions: - LineDDA - LineDDAProc - PolyPolyline - *) - - end -end; diff --git a/mlsource/extra/Win/Listbox.sml b/mlsource/extra/Win/Listbox.sml deleted file mode 100644 index d2533f99..00000000 --- a/mlsource/extra/Win/Listbox.sml +++ /dev/null @@ -1,166 +0,0 @@ -(* - Copyright (c) 2001 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* Listboxes. *) -structure Listbox: -sig - structure Style: - sig - include BIT_FLAGS where type flags = Window.Style.flags - val WS_OVERLAPPED: flags and WS_POPUP: flags and WS_CHILD: flags and WS_MINIMIZE: flags - and WS_VISIBLE: flags and WS_DISABLED:flags and WS_CLIPSIBLINGS:flags - and WS_CLIPCHILDREN:flags and WS_MAXIMIZE:flags and WS_CAPTION:flags - and WS_BORDER:flags and WS_DLGFRAME:flags and WS_VSCROLL:flags and WS_HSCROLL:flags - and WS_SYSMENU:flags and WS_THICKFRAME:flags and WS_GROUP:flags and WS_TABSTOP:flags - and WS_MINIMIZEBOX:flags and WS_MAXIMIZEBOX:flags and WS_TILED:flags and WS_ICONIC:flags - and WS_SIZEBOX:flags and WS_OVERLAPPEDWINDOW:flags and WS_TILEDWINDOW:flags - and WS_POPUPWINDOW: flags and WS_CHILDWINDOW: flags - and LBS_NOTIFY: flags and LBS_SORT: flags and LBS_NOREDRAW: flags and LBS_MULTIPLESEL: flags - and LBS_OWNERDRAWFIXED: flags and LBS_OWNERDRAWVARIABLE: flags and LBS_HASSTRINGS: flags - and LBS_USETABSTOPS: flags and LBS_NOINTEGRALHEIGHT: flags and LBS_MULTICOLUMN: flags - and LBS_WANTKEYBOARDINPUT: flags and LBS_EXTENDEDSEL: flags and LBS_DISABLENOSCROLL: flags - and LBS_NODATA: flags and LBS_NOSEL: flags and LBS_STANDARD: flags - end - - structure Notifications: - sig - val LBN_SELCHANGE: int - val LBN_DBLCLK: int - val LBN_SELCANCEL: int - val LBN_SETFOCUS: int - val LBN_KILLFOCUS: int - end - - datatype LBDirAttr = - DDL_READWRITE | DDL_READONLY | DDL_HIDDEN | DDL_SYSTEM | DDL_DIRECTORY | - DDL_ARCHIVE | DDL_POSTMSGS | DDL_DRIVES | DDL_EXCLUSIVE -end -= -struct - structure Style = - struct - open Window.Style (* Include all the windows styles. *) - - val LBS_NOTIFY = fromWord 0wx0001 - val LBS_SORT = fromWord 0wx0002 - val LBS_NOREDRAW = fromWord 0wx0004 - val LBS_MULTIPLESEL = fromWord 0wx0008 - val LBS_OWNERDRAWFIXED = fromWord 0wx0010 - val LBS_OWNERDRAWVARIABLE = fromWord 0wx0020 - val LBS_HASSTRINGS = fromWord 0wx0040 - val LBS_USETABSTOPS = fromWord 0wx0080 - val LBS_NOINTEGRALHEIGHT = fromWord 0wx0100 - val LBS_MULTICOLUMN = fromWord 0wx0200 - val LBS_WANTKEYBOARDINPUT = fromWord 0wx0400 - val LBS_EXTENDEDSEL = fromWord 0wx0800 - val LBS_DISABLENOSCROLL = fromWord 0wx1000 - val LBS_NODATA = fromWord 0wx2000 - val LBS_NOSEL = fromWord 0wx4000 - val LBS_STANDARD = flags[LBS_NOTIFY, LBS_SORT, WS_VSCROLL, WS_BORDER] - - val all = flags[Window.Style.all, LBS_NOTIFY, LBS_SORT, LBS_NOREDRAW, LBS_MULTIPLESEL, - LBS_OWNERDRAWFIXED, LBS_OWNERDRAWVARIABLE, LBS_HASSTRINGS, - LBS_USETABSTOPS, LBS_NOINTEGRALHEIGHT, LBS_MULTICOLUMN, - LBS_WANTKEYBOARDINPUT, LBS_EXTENDEDSEL, LBS_DISABLENOSCROLL, - LBS_NODATA, LBS_NOSEL] - - val intersect = - List.foldl (fn (a, b) => fromWord(SysWord.andb(toWord a, toWord b))) all - end - - structure Notifications = - struct - val LBN_SELCHANGE = 1 - val LBN_DBLCLK = 2 - val LBN_SELCANCEL = 3 - val LBN_SETFOCUS = 4 - val LBN_KILLFOCUS = 5 - end - - datatype LBDirAttr = datatype ComboBase.CBDirAttr -end; - -(* -let - open Listbox.Style - - val flagTable = - [(LBS_NOTIFY, "LBS_NOTIFY"), - (LBS_SORT, "LBS_SORT"), - (LBS_NOREDRAW, "LBS_NOREDRAW"), - (LBS_MULTIPLESEL, "LBS_MULTIPLESEL"), - (LBS_OWNERDRAWFIXED, "LBS_OWNERDRAWFIXED"), - (LBS_OWNERDRAWVARIABLE, "LBS_OWNERDRAWVARIABLE"), - (LBS_HASSTRINGS, "LBS_HASSTRINGS"), - (LBS_USETABSTOPS, "LBS_USETABSTOPS"), - (LBS_NOINTEGRALHEIGHT, "LBS_NOINTEGRALHEIGHT"), - (LBS_MULTICOLUMN, "LBS_MULTICOLUMN"), - (LBS_WANTKEYBOARDINPUT, "LBS_WANTKEYBOARDINPUT"), - (LBS_EXTENDEDSEL, "LBS_EXTENDEDSEL"), - (LBS_DISABLENOSCROLL, "LBS_DISABLENOSCROLL"), - (LBS_NODATA, "LBS_NODATA"), - (WS_POPUP, "WS_POPUP"), - (WS_CHILD, "WS_CHILD"), - (WS_MINIMIZE, "WS_MINIMIZE"), - (WS_VISIBLE, "WS_VISIBLE"), - (WS_DISABLED, "WS_DISABLED"), - (WS_CLIPSIBLINGS, "WS_CLIPSIBLINGS"), - (WS_CLIPCHILDREN, "WS_CLIPCHILDREN"), - (WS_MAXIMIZE, "WS_MAXIMIZE"), - (WS_CAPTION, "WS_CAPTION"), - (WS_BORDER, "WS_BORDER"), - (WS_DLGFRAME, "WS_DLGFRAME"), - (WS_VSCROLL, "WS_VSCROLL"), - (WS_HSCROLL, "WS_HSCROLL"), - (WS_SYSMENU, "WS_SYSMENU"), - (WS_THICKFRAME, "WS_THICKFRAME"), - (WS_GROUP, "WS_GROUP"), - (WS_TABSTOP, "WS_TABSTOP"), - (WS_MINIMIZEBOX, "WS_MINIMIZEBOX"), - (WS_MAXIMIZEBOX, "WS_MAXIMIZEBOX")] - - fun accumulateFlags f [] = [] - | accumulateFlags f ((w, s)::t) = - if allSet(w, f) then s :: accumulateFlags(clear(w, f)) t - else accumulateFlags f t - - fun printFlags(put, beg, brk, nd) depth _ x = - (* This is just the code to print a list. *) - let - - val stringFlags = accumulateFlags x flagTable - fun plist [] depth = () - | plist _ 0 = put "..." - | plist [h] depth = put h - | plist (h::t) depth = - ( put (h^","); - brk (1, 0); - plist t (depth - 1) - ) - in - beg (3, false); - put "["; - if depth <= 0 then put "..." else plist stringFlags depth; - put "]"; - nd () - end -in - PolyML.install_pp printFlags -end; -*) \ No newline at end of file diff --git a/mlsource/extra/Win/Locale.sml b/mlsource/extra/Win/Locale.sml deleted file mode 100644 index 3143659e..00000000 --- a/mlsource/extra/Win/Locale.sml +++ /dev/null @@ -1,72 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Locale: -sig - datatype PrimaryLanguage = - LANG_AFRIKAANS | LANG_ALBANIAN | LANG_ARABIC | LANG_BASQUE | LANG_BELARUSIAN - | LANG_BULGARIAN | LANG_CATALAN | LANG_CHINESE | LANG_CROATIAN | LANG_CZECH - | LANG_DANISH | LANG_DUTCH | LANG_ENGLISH | LANG_ESTONIAN | LANG_FAEROESE - | LANG_FARSI | LANG_FINNISH | LANG_FRENCH | LANG_GERMAN | LANG_GREEK | LANG_HEBREW - | LANG_HUNGARIAN | LANG_ICELANDIC | LANG_INDONESIAN | LANG_ITALIAN | LANG_JAPANESE - | LANG_KOREAN | LANG_LATVIAN | LANG_LITHUANIAN | LANG_NORWEGIAN | LANG_POLISH - | LANG_PORTUGUESE | LANG_ROMANIAN | LANG_RUSSIAN | LANG_SERBIAN | LANG_SLOVAK - | LANG_SLOVENIAN | LANG_SPANISH | LANG_SWEDISH | LANG_THAI | LANG_TURKISH - | LANG_UKRANIAN | LANG_VIETNAMESE | LANG_NEUTRAL - datatype SubLanguage = - SUBLANG_ARABIC_ALGERIA | SUBLANG_ARABIC_BAHRAIN | SUBLANG_ARABIC_EGYPT - | SUBLANG_ARABIC_IRAQ | SUBLANG_ARABIC_JORDAN | SUBLANG_ARABIC_KUWAIT - | SUBLANG_ARABIC_LEBANON | SUBLANG_ARABIC_LIBYA | SUBLANG_ARABIC_MOROCCO - | SUBLANG_ARABIC_OMAN | SUBLANG_ARABIC_QATAR | SUBLANG_ARABIC_SAUDI_ARABIA - | SUBLANG_ARABIC_SYRIA | SUBLANG_ARABIC_TUNISIA | SUBLANG_ARABIC_UAE - | SUBLANG_ARABIC_YEMEN | SUBLANG_CHINESE_HONGKONG | SUBLANG_CHINESE_SIMPLIFIED - | SUBLANG_CHINESE_SINGAPORE | SUBLANG_CHINESE_TRADITIONAL | SUBLANG_DUTCH - | SUBLANG_DUTCH_BELGIAN | SUBLANG_ENGLISH_AUS | SUBLANG_ENGLISH_BELIZE - | SUBLANG_ENGLISH_CAN | SUBLANG_ENGLISH_CARIBBEAN | SUBLANG_ENGLISH_EIRE - | SUBLANG_ENGLISH_JAMAICA | SUBLANG_ENGLISH_NZ | SUBLANG_ENGLISH_SOUTH_AFRICA - | SUBLANG_ENGLISH_TRINIDAD | SUBLANG_ENGLISH_UK | SUBLANG_ENGLISH_US - | SUBLANG_FRENCH | SUBLANG_FRENCH_BELGIAN | SUBLANG_FRENCH_CANADIAN - | SUBLANG_FRENCH_LUXEMBOURG | SUBLANG_FRENCH_SWISS | SUBLANG_GERMAN - | SUBLANG_GERMAN_AUSTRIAN | SUBLANG_GERMAN_LIECHTENSTEIN - | SUBLANG_GERMAN_LUXEMBOURG | SUBLANG_GERMAN_SWISS | SUBLANG_ITALIAN - | SUBLANG_ITALIAN_SWISS | SUBLANG_KOREAN | SUBLANG_KOREAN_JOHAB - | SUBLANG_NORWEGIAN_BOKMAL | SUBLANG_NORWEGIAN_NYNORSK | SUBLANG_PORTUGUESE - | SUBLANG_PORTUGUESE_BRAZILIAN | SUBLANG_SERBIAN_CYRILLIC | SUBLANG_SERBIAN_LATIN - | SUBLANG_SPANISH | SUBLANG_SPANISH_ARGENTINA | SUBLANG_SPANISH_BOLIVIA - | SUBLANG_SPANISH_CHILE | SUBLANG_SPANISH_COLOMBIA | SUBLANG_SPANISH_COSTA_RICA - | SUBLANG_SPANISH_DOMINICAN_REPUBLIC | SUBLANG_SPANISH_ECUADOR - | SUBLANG_SPANISH_EL_SALVADOR | SUBLANG_SPANISH_GUATEMALA | SUBLANG_SPANISH_HONDURAS - | SUBLANG_SPANISH_MEXICAN | SUBLANG_SPANISH_MODERN | SUBLANG_SPANISH_NICARAGUA - | SUBLANG_SPANISH_PANAMA | SUBLANG_SPANISH_PARAGUAY | SUBLANG_SPANISH_PERU - | SUBLANG_SPANISH_PUERTO_RICO | SUBLANG_SPANISH_URUGUAY | SUBLANG_SPANISH_VENEZUELA - | SUBLANG_SWEDISH | SUBLANG_SWEDISH_FINLAND - | SUBLANG_NEUTRAL | SUBLANG_DEFAULT | SUBLANG_SYS_DEFAULT - - datatype LANGID = MAKELANGID of PrimaryLanguage * SubLanguage - val GetUserDefaultLangID: unit -> LANGID - and GetSystemDefaultLangID: unit -> LANGID -end = -struct - local - open Foreign Base - in - open LocaleBase - val GetUserDefaultLangID = winCall0 (kernel "GetUserDefaultLangID") () LANGID - and GetSystemDefaultLangID = winCall0 (kernel "GetSystemDefaultLangID") () LANGID - end -end; diff --git a/mlsource/extra/Win/LocaleBase.sml b/mlsource/extra/Win/LocaleBase.sml deleted file mode 100644 index 02978e0c..00000000 --- a/mlsource/extra/Win/LocaleBase.sml +++ /dev/null @@ -1,229 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure LocaleBase = -struct - local - open Foreign Base - in - datatype PrimaryLanguage = - LANG_AFRIKAANS | LANG_ICELANDIC | LANG_ALBANIAN | LANG_INDONESIAN - | LANG_ARABIC | LANG_ITALIAN | LANG_BASQUE | LANG_JAPANESE - | LANG_BELARUSIAN | LANG_KOREAN | LANG_BULGARIAN | LANG_LATVIAN - | LANG_CATALAN | LANG_LITHUANIAN | LANG_CHINESE | LANG_NEUTRAL - | LANG_CROATIAN | LANG_NORWEGIAN | LANG_CZECH | LANG_POLISH - | LANG_DANISH | LANG_PORTUGUESE | LANG_DUTCH | LANG_ROMANIAN - | LANG_ENGLISH | LANG_RUSSIAN | LANG_ESTONIAN | LANG_SERBIAN - | LANG_FAEROESE | LANG_SLOVAK | LANG_FARSI | LANG_SLOVENIAN - | LANG_FINNISH | LANG_SPANISH | LANG_FRENCH | LANG_SWEDISH - | LANG_GERMAN | LANG_THAI | LANG_GREEK | LANG_TURKISH - | LANG_HEBREW | LANG_UKRANIAN | LANG_HUNGARIAN | LANG_VIETNAMESE - - datatype SubLanguage = - SUBLANG_ARABIC_SAUDI_ARABIA | SUBLANG_GERMAN - | SUBLANG_ARABIC_IRAQ | SUBLANG_GERMAN_SWISS - | SUBLANG_ARABIC_EGYPT | SUBLANG_GERMAN_AUSTRIAN - | SUBLANG_ARABIC_LIBYA | SUBLANG_GERMAN_LUXEMBOURG - | SUBLANG_ARABIC_ALGERIA | SUBLANG_GERMAN_LIECHTENSTEIN - | SUBLANG_ARABIC_MOROCCO | SUBLANG_ITALIAN - | SUBLANG_ARABIC_TUNISIA | SUBLANG_ITALIAN_SWISS - | SUBLANG_ARABIC_OMAN | SUBLANG_KOREAN - | SUBLANG_ARABIC_YEMEN | SUBLANG_KOREAN_JOHAB - | SUBLANG_ARABIC_SYRIA | SUBLANG_NEUTRAL - | SUBLANG_ARABIC_JORDAN | SUBLANG_NORWEGIAN_BOKMAL - | SUBLANG_ARABIC_LEBANON | SUBLANG_NORWEGIAN_NYNORSK - | SUBLANG_ARABIC_KUWAIT | SUBLANG_PORTUGUESE - | SUBLANG_ARABIC_UAE | SUBLANG_PORTUGUESE_BRAZILIAN - | SUBLANG_ARABIC_BAHRAIN | SUBLANG_SERBIAN_LATIN - | SUBLANG_ARABIC_QATAR | SUBLANG_SERBIAN_CYRILLIC - | SUBLANG_CHINESE_TRADITIONAL | SUBLANG_SPANISH - | SUBLANG_CHINESE_SIMPLIFIED | SUBLANG_SPANISH_MEXICAN - | SUBLANG_CHINESE_HONGKONG | SUBLANG_SPANISH_MODERN - | SUBLANG_CHINESE_SINGAPORE | SUBLANG_SPANISH_GUATEMALA - | SUBLANG_DEFAULT | SUBLANG_SPANISH_COSTA_RICA - | SUBLANG_DUTCH | SUBLANG_SPANISH_PANAMA - | SUBLANG_DUTCH_BELGIAN | SUBLANG_SPANISH_DOMINICAN_REPUBLIC - | SUBLANG_ENGLISH_US | SUBLANG_SPANISH_VENEZUELA - | SUBLANG_ENGLISH_UK | SUBLANG_SPANISH_COLOMBIA - | SUBLANG_ENGLISH_AUS | SUBLANG_SPANISH_PERU - | SUBLANG_ENGLISH_CAN | SUBLANG_SPANISH_ARGENTINA - | SUBLANG_ENGLISH_NZ | SUBLANG_SPANISH_ECUADOR - | SUBLANG_ENGLISH_EIRE | SUBLANG_SPANISH_CHILE - | SUBLANG_ENGLISH_SOUTH_AFRICA | SUBLANG_SPANISH_URUGUAY - | SUBLANG_ENGLISH_JAMAICA | SUBLANG_SPANISH_PARAGUAY - | SUBLANG_ENGLISH_CARIBBEAN | SUBLANG_SPANISH_BOLIVIA - | SUBLANG_ENGLISH_BELIZE | SUBLANG_SPANISH_EL_SALVADOR - | SUBLANG_ENGLISH_TRINIDAD | SUBLANG_SPANISH_HONDURAS - | SUBLANG_FRENCH | SUBLANG_SPANISH_NICARAGUA - | SUBLANG_FRENCH_BELGIAN | SUBLANG_SPANISH_PUERTO_RICO - | SUBLANG_FRENCH_CANADIAN | SUBLANG_SWEDISH - | SUBLANG_FRENCH_SWISS | SUBLANG_SWEDISH_FINLAND - | SUBLANG_FRENCH_LUXEMBOURG | SUBLANG_SYS_DEFAULT - - local - val tab = [ - (LANG_NEUTRAL, 0wx00), - (LANG_AFRIKAANS, 0wx36), - (LANG_ALBANIAN, 0wx1c), - (LANG_ARABIC, 0wx01), - (LANG_BASQUE, 0wx2d), - (LANG_BELARUSIAN, 0wx23), - (LANG_BULGARIAN, 0wx02), - (LANG_CATALAN, 0wx03), - (LANG_CHINESE, 0wx04), - (LANG_CROATIAN, 0wx1a), - (LANG_CZECH, 0wx05), - (LANG_DANISH, 0wx06), - (LANG_DUTCH, 0wx13), - (LANG_ENGLISH, 0wx09), - (LANG_ESTONIAN, 0wx25), - (LANG_FAEROESE, 0wx38), - (LANG_FARSI, 0wx29), - (LANG_FINNISH, 0wx0b), - (LANG_FRENCH, 0wx0c), - (LANG_GERMAN, 0wx07), - (LANG_GREEK, 0wx08), - (LANG_HEBREW, 0wx0d), - (LANG_HUNGARIAN, 0wx0e), - (LANG_ICELANDIC, 0wx0f), - (LANG_INDONESIAN, 0wx21), - (LANG_ITALIAN, 0wx10), - (LANG_JAPANESE, 0wx11), - (LANG_KOREAN, 0wx12), - (LANG_LATVIAN, 0wx26), - (LANG_LITHUANIAN, 0wx27), - (LANG_NORWEGIAN, 0wx14), - (LANG_POLISH, 0wx15), - (LANG_PORTUGUESE, 0wx16), - (LANG_ROMANIAN, 0wx18), - (LANG_RUSSIAN, 0wx19), - (LANG_SERBIAN, 0wx1a), - (LANG_SLOVAK, 0wx1b), - (LANG_SLOVENIAN, 0wx24), - (LANG_SPANISH, 0wx0a), - (LANG_SWEDISH, 0wx1d), - (LANG_THAI, 0wx1e), - (LANG_TURKISH, 0wx1f), - (LANG_UKRANIAN, 0wx22), - (LANG_VIETNAMESE, 0wx2a)] - in - val (fromPrim, toPrim) = tableLookup(tab, NONE) - end - - local - val tab = [ - (SUBLANG_NEUTRAL, 0wx00), - (SUBLANG_DEFAULT, 0wx01), - (SUBLANG_SYS_DEFAULT, 0wx02), - (SUBLANG_ARABIC_SAUDI_ARABIA, 0wx01), - (SUBLANG_ARABIC_IRAQ, 0wx02), - (SUBLANG_ARABIC_EGYPT, 0wx03), - (SUBLANG_ARABIC_LIBYA, 0wx04), - (SUBLANG_ARABIC_ALGERIA, 0wx05), - (SUBLANG_ARABIC_MOROCCO, 0wx06), - (SUBLANG_ARABIC_TUNISIA, 0wx07), - (SUBLANG_ARABIC_OMAN, 0wx08), - (SUBLANG_ARABIC_YEMEN, 0wx09), - (SUBLANG_ARABIC_SYRIA, 0wx0a), - (SUBLANG_ARABIC_JORDAN, 0wx0b), - (SUBLANG_ARABIC_LEBANON, 0wx0c), - (SUBLANG_ARABIC_KUWAIT, 0wx0d), - (SUBLANG_ARABIC_UAE, 0wx0e), - (SUBLANG_ARABIC_BAHRAIN, 0wx0f), - (SUBLANG_ARABIC_QATAR, 0wx10), - (SUBLANG_CHINESE_TRADITIONAL, 0wx01), - (SUBLANG_CHINESE_SIMPLIFIED, 0wx02), - (SUBLANG_CHINESE_HONGKONG, 0wx03), - (SUBLANG_CHINESE_SINGAPORE, 0wx04), - (SUBLANG_DUTCH, 0wx01), - (SUBLANG_DUTCH_BELGIAN, 0wx02), - (SUBLANG_ENGLISH_US, 0wx01), - (SUBLANG_ENGLISH_UK, 0wx02), - (SUBLANG_ENGLISH_AUS, 0wx03), - (SUBLANG_ENGLISH_CAN, 0wx04), - (SUBLANG_ENGLISH_NZ, 0wx05), - (SUBLANG_ENGLISH_EIRE, 0wx06), - (SUBLANG_ENGLISH_SOUTH_AFRICA, 0wx07), - (SUBLANG_ENGLISH_JAMAICA, 0wx08), - (SUBLANG_ENGLISH_CARIBBEAN, 0wx09), - (SUBLANG_ENGLISH_BELIZE, 0wx0a), - (SUBLANG_ENGLISH_TRINIDAD, 0wx0b), - (SUBLANG_FRENCH, 0wx01), - (SUBLANG_FRENCH_BELGIAN, 0wx02), - (SUBLANG_FRENCH_CANADIAN, 0wx03), - (SUBLANG_FRENCH_SWISS, 0wx04), - (SUBLANG_FRENCH_LUXEMBOURG, 0wx05), - (SUBLANG_GERMAN, 0wx01), - (SUBLANG_GERMAN_SWISS, 0wx02), - (SUBLANG_GERMAN_AUSTRIAN, 0wx03), - (SUBLANG_GERMAN_LUXEMBOURG, 0wx04), - (SUBLANG_GERMAN_LIECHTENSTEIN, 0wx05), - (SUBLANG_ITALIAN, 0wx01), - (SUBLANG_ITALIAN_SWISS, 0wx02), - (SUBLANG_KOREAN, 0wx01), - (SUBLANG_KOREAN_JOHAB, 0wx02), - (SUBLANG_NORWEGIAN_BOKMAL, 0wx01), - (SUBLANG_NORWEGIAN_NYNORSK, 0wx02), - (SUBLANG_PORTUGUESE, 0wx02), - (SUBLANG_PORTUGUESE_BRAZILIAN, 0wx01), - (SUBLANG_SERBIAN_LATIN, 0wx02), - (SUBLANG_SERBIAN_CYRILLIC, 0wx03), - (SUBLANG_SPANISH, 0wx01), - (SUBLANG_SPANISH_MEXICAN, 0wx02), - (SUBLANG_SPANISH_MODERN, 0wx03), - (SUBLANG_SPANISH_GUATEMALA, 0wx04), - (SUBLANG_SPANISH_COSTA_RICA, 0wx05), - (SUBLANG_SPANISH_PANAMA, 0wx06), - (SUBLANG_SPANISH_DOMINICAN_REPUBLIC, 0wx07), - (SUBLANG_SPANISH_VENEZUELA, 0wx08), - (SUBLANG_SPANISH_COLOMBIA, 0wx09), - (SUBLANG_SPANISH_PERU, 0wx0a), - (SUBLANG_SPANISH_ARGENTINA, 0wx0b), - (SUBLANG_SPANISH_ECUADOR, 0wx0c), - (SUBLANG_SPANISH_CHILE, 0wx0d), - (SUBLANG_SPANISH_URUGUAY, 0wx0e), - (SUBLANG_SPANISH_PARAGUAY, 0wx0f), - (SUBLANG_SPANISH_BOLIVIA, 0wx10), - (SUBLANG_SPANISH_EL_SALVADOR, 0wx11), - (SUBLANG_SPANISH_HONDURAS, 0wx12), - (SUBLANG_SPANISH_NICARAGUA, 0wx13), - (SUBLANG_SPANISH_PUERTO_RICO, 0wx14), - (SUBLANG_SWEDISH, 0wx01), - (SUBLANG_SWEDISH_FINLAND, 0wx02)] - in - val (fromSub, toSub) = tableLookup(tab, NONE) - end - - datatype LANGID = MAKELANGID of PrimaryLanguage * SubLanguage - - local - fun fromLANGID(MAKELANGID(prim, sub)) = - Word.toInt(Word.orb(fromPrim prim, Word.<<(fromSub sub, 0w10))) - (* It seems that GetUserDefaultLangID at least sets the top word - to something odd so we mask both parts. *) - fun toLANGID l = - MAKELANGID( - toPrim(Word.andb(Word.fromInt l, 0wx3ff)), - toSub(Word.andb(Word.~>>(Word.fromInt l, 0w10), 0wx3f)) - ) - - in - val LANGID: LANGID conversion = absConversion {abs = toLANGID, rep = fromLANGID} cUshort - end - end -end; diff --git a/mlsource/extra/Win/MESSAGE.signature.sml b/mlsource/extra/Win/MESSAGE.signature.sml deleted file mode 100644 index c258fc2c..00000000 --- a/mlsource/extra/Win/MESSAGE.signature.sml +++ /dev/null @@ -1,1019 +0,0 @@ -(* - Copyright (c) 2001-7, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -signature MESSAGE = -sig - datatype ControlType = - ODT_BUTTON - | ODT_COMBOBOX - | ODT_LISTBOX - | ODT_MENU - | ODT_STATIC - datatype ImageType = - IMAGE_BITMAP - | IMAGE_CURSOR - | IMAGE_ENHMETAFILE - | IMAGE_ICON - - type HGDIOBJ and HWND and HMENU and HICON and HINSTANCE and HDC - and HFONT and HRGN and HDROP - type RECT = { left: int, top: int, right: int, bottom: int } - type POINT = { x: int, y: int } - - datatype HitTest = - HTBORDER - | HTBOTTOM - | HTBOTTOMLEFT - | HTBOTTOMRIGHT - | HTCAPTION - | HTCLIENT - | HTCLOSE - | HTERROR - | HTGROWBOX - | HTHELP - | HTHSCROLL - | HTLEFT - | HTMENU - | HTMAXBUTTON - | HTMINBUTTON - | HTNOWHERE - | HTREDUCE - | HTRIGHT - | HTSIZE - | HTSYSMENU - | HTTOP - | HTTOPLEFT - | HTTOPRIGHT - | HTTRANSPARENT - | HTVSCROLL - | HTZOOM - - datatype LRESULT = - LRESINT of int - | LRESHANDLE of HGDIOBJ - - type KeyData - type windowFlags and findReplaceFlags - datatype ScrollDirection = - SB_BOTTOM - | SB_ENDSCROLL - | SB_LEFT - | SB_LINEDOWN - | SB_LINELEFT - | SB_LINERIGHT - | SB_LINEUP - | SB_PAGEDOWN - | SB_PAGELEFT - | SB_PAGERIGHT - | SB_PAGEUP - | SB_RIGHT - | SB_THUMBPOSITION - | SB_THUMBTRACK - | SB_TOP - - type WindowPositionStyle - - datatype MouseKeyFlags = MK_LBUTTON | MK_RBUTTON | MK_SHIFT | MK_CONTROL | MK_MBUTTON - - type ClipboardFormat and ClassType - - datatype MarginSettings = - UseFontInfo | Margins of {left: int option, right: int option } - - datatype MDITileFlags = MDITILE_VERTICAL | MDITILE_HORIZONTAL | MDITILE_SKIPDISABLED - - datatype EMCharFromPos = - EMcfpEdit of POINT - | EMcfpRichEdit of POINT - | EMcfpUnknown of SysWord.word - - datatype SystemCommand = - SC_ARRANGE - | SC_CLOSE - | SC_CONTEXTHELP - | SC_DEFAULT - | SC_HOTKEY - | SC_HSCROLL - | SC_KEYMENU - | SC_MAXIMIZE - | SC_MINIMIZE - | SC_MONITORPOWER - | SC_MOUSEMENU - | SC_MOVE - | SC_NEXTWINDOW - | SC_PREVWINDOW - | SC_RESTORE - | SC_SCREENSAVE - | SC_SEPARATOR - | SC_SIZE - | SC_TASKLIST - | SC_VSCROLL - - datatype WMActivateOptions = WA_ACTIVE | WA_CLICKACTIVE | WA_INACTIVE - - datatype - WMPrintOption = - PRF_CHECKVISIBLE - | PRF_CHILDREN - | PRF_CLIENT - | PRF_ERASEBKGND - | PRF_NONCLIENT - | PRF_OWNED - - datatype WMSizeOptions = - SIZE_MAXHIDE | SIZE_MAXIMIZED | SIZE_MAXSHOW | SIZE_MINIMIZED | SIZE_RESTORED - datatype HelpHandle = MenuHandle of HMENU | WindowHandle of HWND - - (* Passed in the lpParam argument of a WM_NOTIFY message. - TODO: Many of these have additional information. *) - datatype Notification = - NM_OUTOFMEMORY - | NM_CLICK - | NM_DBLCLK - | NM_RETURN - | NM_RCLICK - | NM_RDBLCLK - | NM_SETFOCUS - | NM_KILLFOCUS - | NM_CUSTOMDRAW - | NM_HOVER - | NM_NCHITTEST - | NM_KEYDOWN - | NM_RELEASEDCAPTURE - | NM_SETCURSOR - | NM_CHAR - | NM_TOOLTIPSCREATED - | NM_LDOWN - | NM_RDOWN - | NM_THEMECHANGED - | LVN_ITEMCHANGING - | LVN_ITEMCHANGED - | LVN_INSERTITEM - | LVN_DELETEITEM - | LVN_DELETEALLITEMS - | LVN_BEGINLABELEDIT - | LVN_ENDLABELEDIT - | LVN_COLUMNCLICK - | LVN_BEGINDRAG - | LVN_BEGINRDRAG - | LVN_GETDISPINFO - | LVN_SETDISPINFO - | LVN_KEYDOWN - | LVN_GETINFOTIP - | HDN_ITEMCHANGING - | HDN_ITEMCHANGED - | HDN_ITEMCLICK - | HDN_ITEMDBLCLICK - | HDN_DIVIDERDBLCLICK - | HDN_BEGINTRACK - | HDN_ENDTRACK - | HDN_TRACK - | HDN_ENDDRAG - | HDN_BEGINDRAG - | HDN_GETDISPINFO - | TVN_SELCHANGING - | TVN_SELCHANGED - | TVN_GETDISPINFO - | TVN_SETDISPINFO - | TVN_ITEMEXPANDING - | TVN_ITEMEXPANDED - | TVN_BEGINDRAG - | TVN_BEGINRDRAG - | TVN_DELETEITEM - | TVN_BEGINLABELEDIT - | TVN_ENDLABELEDIT - | TVN_KEYDOWN - | TVN_GETINFOTIP - | TVN_SINGLEEXPAND - | TTN_GETDISPINFO of string ref - | TTN_SHOW - | TTN_POP - | TCN_KEYDOWN - | TCN_SELCHANGE - | TCN_SELCHANGING - | TBN_GETBUTTONINFO - | TBN_BEGINDRAG - | TBN_ENDDRAG - | TBN_BEGINADJUST - | TBN_ENDADJUST - | TBN_RESET - | TBN_QUERYINSERT - | TBN_QUERYDELETE - | TBN_TOOLBARCHANGE - | TBN_CUSTHELP - | TBN_DROPDOWN - | TBN_HOTITEMCHANGE - | TBN_DRAGOUT - | TBN_DELETINGBUTTON - | TBN_GETDISPINFO - | TBN_GETINFOTIP - | UDN_DELTAPOS - | RBN_GETOBJECT - | RBN_LAYOUTCHANGED - | RBN_AUTOSIZE - | RBN_BEGINDRAG - | RBN_ENDDRAG - | RBN_DELETINGBAND - | RBN_DELETEDBAND - | RBN_CHILDSIZE - | CBEN_GETDISPINFO - | CBEN_DRAGBEGIN - | IPN_FIELDCHANGED - | SBN_SIMPLEMODECHANGE - | PGN_SCROLL - | PGN_CALCSIZE - | NM_OTHER of int (* Catch-all for other cases. *) - - datatype Message = - WM_NULL - - | WM_ACTIVATE of {active: WMActivateOptions, minimize: bool } - (* Indicates a change in activation state *) - - | WM_ACTIVATEAPP of {active: bool, threadid: int } - (* Notifies applications when a new task activates *) - - | WM_ASKCBFORMATNAME of { length: int, formatName: string ref} - (* Retrieves the name of the clipboard format *) - - | WM_CANCELJOURNAL - (* Notifies application when user cancels journaling *) - - | WM_CANCELMODE - (* Notifies a Window to cancel internal modes *) - - | WM_CHANGECBCHAIN of { removed: HWND, next: HWND } - (* Notifies clipboard viewer of removal from chain *) - - | WM_CHAR of {charCode: char, data: KeyData } - (* Indicates the user pressed a character key *) - - | WM_CHARTOITEM of {key: int, caretpos: int, listbox: HWND } - (* Provides list-box keystrokes to owner Window *) - - | WM_CHILDACTIVATE - (* Notifies a child Window of activation *) - - (* This is WM_USER+1. It's only used in a GetFont dialogue box. - | WM_CHOOSEFONT_GETLOGFONT of LOGFONT ref *) - (* Retrieves LOGFONT structure for Font dialog box *) - - | WM_CLEAR - (* Clears an edit control *) - - | WM_CLOSE - (* System Close menu command was chosen *) - - | WM_COMMAND of {notifyCode: int, wId: int, control: HWND } - (* Specifies a command message *) - - | WM_COMPAREITEM of (* Determines position of combo- or list-box item *) - { - controlid: int, ctlType: ControlType, ctlID: int, hItem: HWND, - itemID1: int, itemData1: SysWord.word, itemID2: int, itemData2: SysWord.word - } - - | WM_COPY (* Copies a selection to the clipboard *) - - | WM_CREATE of - { instance: HINSTANCE, creation: Foreign.Memory.voidStar, menu: HMENU, parent: HWND, cy: int, cx: int, - y: int, x: int, style: windowFlags, name: string, (* The class may be a string or an atom. *) - class: ClassType, extendedstyle: int } - (* Indicates a Window is being created *) - - | WM_CTLCOLORBTN of { displaycontext: HDC, button: HWND } - (* Button is about to be drawn *) - - | WM_CTLCOLORDLG of { displaycontext: HDC, dialogbox: HWND } - (* Dialog box is about to be drawn *) - - | WM_CTLCOLOREDIT of { displaycontext: HDC, editcontrol: HWND } - (* Control is about to be drawn *) - - | WM_CTLCOLORLISTBOX of { displaycontext: HDC, listbox: HWND } - (* List box is about to be drawn *) - - | WM_CTLCOLORMSGBOX of { displaycontext: HDC, messagebox: HWND } - (* Message box is about to be drawn *) - - | WM_CTLCOLORSCROLLBAR of { displaycontext: HDC, scrollbar: HWND } - (* Indicates scroll bar is about to be drawn *) - - | WM_CTLCOLORSTATIC of { displaycontext: HDC, staticcontrol: HWND } - (* Control is about to be drawn *) - (* Note the return value is an HBRUSH *) - - | WM_CUT - (* Deletes a selection and copies it to the clipboard *) - - | WM_DEADCHAR of { charCode: char, data: KeyData } - (* Indicates the user pressed a dead key *) - - | WM_DELETEITEM of { senderId: int, ctlType: ControlType, ctlID: int, itemID: int, item: HWND, itemData: int } - (* Indicates owner-draw item or control was altered *) - - | WM_DESTROY - (* Indicates Window is about to be destroyed *) - - | WM_DESTROYCLIPBOARD - (* Notifies owner that the clipboard was emptied *) - - | WM_DEVMODECHANGE of { devicename: string } - (* Indicates the device-mode settings have changed *) - - | WM_DRAWCLIPBOARD - (* Indicates the clipboard's contents have changed *) - - | WM_DRAWITEM of - { senderId: int, ctlType: ControlType, ctlID: int, itemID: int, itemAction: int, - itemState: int, hItem: HWND , hDC: HDC, rcItem: RECT, itemData: int } - (* Indicates owner-draw control/menu needs redrawing *) - - | WM_DROPFILES of { hDrop: HDROP } - (* Indicates that a file has been dropped *) - - | WM_ENABLE of { enabled: bool } - (* Indicates a Window's enable state is changing *) - - | WM_ENDSESSION of { endsession: bool } - (* Indicates whether the Windows session is ending *) - - | WM_ENTERIDLE of { flag: int, window: HWND } - (* Indicates a modal dialog box or menu is idle *) - - | WM_ENTERMENULOOP of { istrack: bool } - (* Indicates entry into menu modal loop *) - - | WM_EXITMENULOOP of { istrack: bool } - (* Indicates exit from menu modal loop *) - - | WM_ERASEBKGND of { devicecontext: HDC } - (* Indicates a Window's background need erasing *) - - | WM_FONTCHANGE - (* Indicates a change in the font-resource pool *) - - | WM_GETDLGCODE - (* Allows dialog procedure to process control input - TODO: This has parameters! *) - - | WM_GETFONT - (* Retrieves the font that a control is using *) - - | WM_GETHOTKEY - (* Gets the virtual-key code of a Window's hot key *) - - | WM_GETMINMAXINFO of - { maxSize: POINT ref, maxPosition: POINT ref, - minTrackSize: POINT ref, maxTrackSize: POINT ref } - (* Gets minimum and maximum sizing information *) - - | WM_GETTEXT of { length: int, text: string ref } - (* Gets the text that corresponds to a Window *) - - | WM_GETTEXTLENGTH - (* Gets length of text associated with a Window *) - - | WM_HOTKEY of { id: int } - (* Hot key has been detected *) - - | WM_HSCROLL of { value: ScrollDirection, position: int, scrollbar: HWND } - (* Indicates a click in a horizontal scroll bar *) - - | WM_HSCROLLCLIPBOARD of { viewer: HWND, code: int, position: int } - (* Prompts owner to scroll clipboard contents *) - - | WM_ICONERASEBKGND of { devicecontext: HDC } - (* Notifies minimized Window to fill icon background *) - - | WM_INITDIALOG of { dialog: HWND, initdata: int } - (* Initializes a dialog box *) - - | WM_INITMENU of { menu: HMENU } - (* Indicates a menu is about to become active *) - - | WM_INITMENUPOPUP of { menupopup: HMENU, itemposition: int, isSystemMenu: bool } - (* Indicates a pop-up menu is being created *) - - | WM_KEYDOWN of { virtualKey: int, data: KeyData } - (* Indicates a nonsystem key was pressed *) - - | WM_KEYUP of { virtualKey: int, data: KeyData } - (* Indicates a nonsystem key was released *) - - | WM_KILLFOCUS of { receivefocus: HWND } - (* Indicates the Window is losing keyboard focus *) - - | WM_LBUTTONDBLCLK of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates double-click of left button *) - - | WM_LBUTTONDOWN of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates when left mouse button is pressed *) - - | WM_LBUTTONUP of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates when left mouse button is released *) - - | WM_MBUTTONDBLCLK of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates double-click of middle mouse button *) - - | WM_MBUTTONDOWN of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates when middle mouse button is pressed *) - - | WM_MBUTTONUP of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates when middle mouse button is released *) - - | WM_MDICASCADE of { skipDisabled: bool } - (* Arranges MDI child Windows in cascade format *) - - | WM_MDICREATE of - { class: ClassType, title: string, instance: HINSTANCE, x: int, y: int, - cx: int, cy: int, style: int, cdata: int } - (* Prompts MDI client to create a child Window *) - - | WM_MDIDESTROY of { child: HWND } - (* Closes an MDI child Window *) - - | WM_MDIGETACTIVE - (* Retrieves data about the active MDI child Window *) - - | WM_MDIICONARRANGE - (* Arranges minimized MDI child Windows *) - - | WM_MDIMAXIMIZE of { child: HWND } - (* Maximizes an MDI child Window *) - - | WM_MDINEXT of { child: HWND, flagnext: bool } - (* Activates the next MDI child Window *) - - | WM_MDIREFRESHMENU - (* Refreshes an MDI frame Window's menu *) - - | WM_MDIRESTORE of { child: HWND } - (* Prompts MDI client to restore a child Window *) - - | WM_MDISETMENU of { frameMenu: HMENU, windowMenu: HMENU } - (* Replaces an MDI frame Window's menu *) - - | WM_MDITILE of { tilingflag: MDITileFlags list } - (* Arranges MDI child Windows in tiled format *) - - | WM_MEASUREITEM of - { senderId: int, ctlType: ControlType, ctlID: int, itemID: int, itemWidth: int ref, itemHeight: int ref, itemData: int } - (* Requests dimensions of owner-draw control or item *) - - | WM_MENUCHAR of { ch: char, menuflag: MenuBase.MenuFlag, menu: HMENU } - (* Indicates an unknown menu mnemonic was pressed *) - - | WM_MENUSELECT of { menuitem: int, menuflags: MenuBase.MenuFlag list, menu: HMENU } - (* Indicates that the user selected a menu item *) - - | WM_MOUSEACTIVATE of { parent: HWND, hitTest: HitTest, message: int } - (* Indicates a mouse click in an inactive Window *) - - | WM_MOUSEMOVE of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates mouse-cursor movement *) - - | WM_MOUSEHOVER of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates the mouse hovering in the client area *) - - | WM_MOUSELEAVE - (* Indicates the mouse leaving the client area *) - - | WM_MOVE of { x: int, y: int } - (* Indicates a Window's position has changed *) - - | WM_NCACTIVATE of { active: bool } - (* Changes the active state of nonclient area *) - - | WM_NCCALCSIZE of - { validarea: bool, newrect: RECT ref, oldrect: RECT, oldclientarea: RECT, - hwnd: HWND, insertAfter: HWND, x: int, y: int, cx: int, cy: int, style: WindowPositionStyle list} - (* Calculates the size of a Window's client area *) - - | WM_NCCREATE of - { instance: HINSTANCE, creation: Foreign.Memory.voidStar, menu: HMENU, parent: HWND, cy: int, cx: int, - y: int, x: int, style: windowFlags, name: string, class: ClassType, extendedstyle: int } - (* Indicates a Window's nonclient area being created *) - - | WM_NCDESTROY - (* Indicates Window's nonclient area being destroyed *) - - | WM_NCHITTEST of { x: int, y: int } - (* Indicates mouse-cursor movement *) - - | WM_NCLBUTTONDBLCLK of { hitTest: HitTest, x: int, y: int } - (* Indicates nonclient left button double-click *) - - | WM_NCLBUTTONDOWN of { hitTest: HitTest, x: int, y: int } - (* Indicates left button pressed in nonclient area *) - - | WM_NCLBUTTONUP of { hitTest: HitTest, x: int, y: int } - (* Indicates left button released in nonclient area *) - - | WM_NCMBUTTONDBLCLK of { hitTest: HitTest, x: int, y: int } - (* Indicates nonclient middle button double-click *) - - | WM_NCMBUTTONDOWN of { hitTest: HitTest, x: int, y: int } - (* Indicates middle button pressed in nonclient area *) - - | WM_NCMBUTTONUP of { hitTest: HitTest, x: int, y: int } - (* Indicates middle button released in nonclient area *) - - | WM_NCMOUSEMOVE of { hitTest: HitTest, x: int, y: int } - (* Indicates mouse-cursor movement in nonclient area *) - - | WM_NCMOUSEHOVER of { hitTest: HitTest, x: int, y: int } - (* Indicates the mouse hovering in the nonclient area *) - - | WM_NCMOUSELEAVE - (* Indicates the mouse leaving the nonclient area *) - - | WM_NCPAINT of { region: HRGN } - (* Indicates a Window's frame needs painting *) - - | WM_NCRBUTTONDBLCLK of { hitTest: HitTest, x: int, y: int } - (* Indicates nonclient right button double-click *) - - | WM_NCRBUTTONDOWN of { hitTest: HitTest, x: int, y: int } - (* Indicates right button pressed in nonclient area *) - - | WM_NCRBUTTONUP of { hitTest: HitTest, x: int, y: int } - (* Indicates right button released in nonclient area *) - - | WM_NEXTDLGCTL of { control: int, handleflag: bool } - (* Sets focus to different dialog box control *) - - | WM_PAINT - (* Indicates a Window's client area need painting *) - - | WM_PAINTCLIPBOARD of { clipboard: HWND } - (* Prompts owner to display clipboard contents *) - - | WM_PAINTICON - (* Icon is about to be painted *) - - | WM_PALETTECHANGED of { palChg: HWND } - (* Indicates the focus-Window realized its palette *) - - | WM_PALETTEISCHANGING of { realize: HWND } - (* Informs Windows that palette is changing *) - - | WM_PARENTNOTIFY of { eventflag: int, idchild: int, value: int } - (* Notifies parent of child-Window activity *) - - | WM_PASTE - (* Inserts clipboard data into an edit control *) - - | WM_POWER of { powerevent: int } - (* Indicates the system is entering suspended mode *) - - | WM_QUERYDRAGICON - (* Requests a cursor handle for a minimized Window *) - - | WM_QUERYENDSESSION of { source: int } - (* Requests that the Windows session be ended *) - - | WM_QUERYNEWPALETTE - (* Allows a Window to realize its logical palette *) - - | WM_QUERYOPEN - (* Requests that a minimized Window be restored *) - - | WM_QUEUESYNC - (* Delimits CBT messages *) - - | WM_QUIT of { exitcode: int } - (* Requests that an application be terminated *) - - | WM_RBUTTONDBLCLK of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates double-click of right mouse button *) - - | WM_RBUTTONDOWN of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates when right mouse button is pressed *) - - | WM_RBUTTONUP of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates when right mouse button is released *) - - | WM_RENDERALLFORMATS - (* Notifies owner to render all clipboard formats *) - - | WM_RENDERFORMAT of { format: ClipboardFormat } - (* Notifies owner to render clipboard data *) - - | WM_SETCURSOR of { cursorwindow: HWND, hitTest: HitTest, mousemessage: int } - (* Prompts a Window to set the cursor shape *) - - | WM_SETFOCUS of { losing: HWND } - - | WM_SETFONT of {font: HFONT, redrawflag: bool } - - | WM_SETHOTKEY of { virtualKey: int } - - | WM_SETREDRAW of { redrawflag: bool } - - | WM_SETTEXT of { text: string } - - | WM_SHOWWINDOW of { showflag: bool, statusflag: int } - - | WM_SIZE of { flag: WMSizeOptions, width: int, height: int } - - | WM_SIZECLIPBOARD of { viewer: HWND} - - | WM_SYSCHAR of { charCode: char, data: KeyData } - - | WM_SYSCOLORCHANGE - - | WM_SYSCOMMAND of { commandvalue: SystemCommand, sysBits: int, p: POINT } - - | WM_SYSDEADCHAR of { charCode: char, data: KeyData } - - | WM_SYSKEYDOWN of { virtualKey: int, data: KeyData } - - | WM_SYSKEYUP of { virtualKey: int, data: KeyData } - - | WM_TIMECHANGE - (* Indicates the system time has been set *) - - | WM_TIMER of { timerid: int } - - | WM_UNDO - - | WM_SYSTEM_OTHER of { uMsg: int, wParam: SysWord.word, lParam: SysWord.word } - | WM_USER of { uMsg: int, wParam: SysWord.word, lParam: SysWord.word } - | WM_APP of { uMsg: int, wParam: SysWord.word, lParam: SysWord.word } - | WM_REGISTERED of { uMsg: int, wParam: SysWord.word, lParam: SysWord.word } - - | WM_VKEYTOITEM of { virtualKey: int, - caretpos: int, - listbox: HWND } - - | WM_VSCROLL of { value: ScrollDirection, - position: int, - scrollbar: HWND } - - | WM_VSCROLLCLIPBOARD of { viewer: HWND, - code: int, - position: int } - - | WM_WINDOWPOSCHANGED of - { hwnd: HWND, front: HWND, x: int, y: int, width: int, height: int, flags: WindowPositionStyle list } - - | WM_WINDOWPOSCHANGING of - { - hwnd: HWND, front: HWND ref, x: int ref, y: int ref, - width: int ref, height: int ref, flags: WindowPositionStyle list ref - } - - | WM_NOTIFY of {from: HWND, idCtrl: int, idFrom: int, notification: Notification } - - | WM_CAPTURECHANGED of { newCapture: HWND } - - | WM_ENTERSIZEMOVE - - | WM_EXITSIZEMOVE - - | WM_PRINT of {hdc: HDC, flags: WMPrintOption list } - - | WM_PRINTCLIENT of {hdc: HDC, flags: WMPrintOption list } - - | WM_HELP of { ctrlId: int, itemHandle: HelpHandle, contextId: int, mousePos: POINT } - - | WM_GETICON of { big: bool } - - | WM_SETICON of { big: bool, icon: HICON } - - | WM_CONTEXTMENU of { hwnd: HWND, xPos: int, yPos: int } - - | WM_DISPLAYCHANGE of { bitsPerPixel: int, xScreen: int, yScreen: int } - - | EM_CANUNDO - - | EM_CHARFROMPOS of EMCharFromPos - - | EM_EMPTYUNDOBUFFER - - | EM_FMTLINES of {addEOL: bool} - - | EM_GETFIRSTVISIBLELINE - - | EM_GETLIMITTEXT - - | EM_GETLINE of { lineNo: int, size: int, result: string ref } - - | EM_GETLINECOUNT - - | EM_GETMARGINS - - | EM_GETMODIFY - - | EM_GETPASSWORDCHAR - - | EM_GETRECT of {rect: RECT ref} - - | EM_GETSEL of {startPos: int ref, endPos: int ref} - - | EM_GETTHUMB - - | EM_LIMITTEXT of {limit: int} - - | EM_LINEFROMCHAR of {index: int} - - | EM_LINEINDEX of {line: int} - - | EM_LINELENGTH of {index: int} - - | EM_LINESCROLL of {xScroll: int, yScroll: int} - - | EM_POSFROMCHAR of {index: int} - - | EM_REPLACESEL of {canUndo: bool, text: string} - - | EM_SCROLL of {action: ScrollDirection} - - | EM_SCROLLCARET - - | EM_SETMARGINS of {margins: MarginSettings} - - | EM_SETMODIFY of { modified: bool } - - | EM_SETPASSWORDCHAR of { ch: char } - - | EM_SETREADONLY of { readOnly: bool } - - | EM_SETRECT of {rect: RECT} - - | EM_SETRECTNP of {rect: RECT} - - | EM_SETSEL of {startPos: int, endPos: int} - - | EM_SETTABSTOPS of {tabs: IntVector.vector} - - | EM_UNDO - - | BM_CLICK - - | BM_GETCHECK - - | BM_GETIMAGE of {imageType: ImageType} - - | BM_GETSTATE - - | BM_SETCHECK of {state: int} - - | BM_SETIMAGE of {image: HGDIOBJ, imageType: ImageType} - - | BM_SETSTATE of {highlight: bool } - - | BM_SETSTYLE of {redraw: bool, style: windowFlags} - - | CB_GETEDITSEL of {startPos: int ref, endPos: int ref} - - | CB_LIMITTEXT of {limit: int} - - | CB_SETEDITSEL of {startPos: int, endPos: int} - - | CB_ADDSTRING of { text: string } - - | CB_DELETESTRING of { index: int } - - | CB_GETCOUNT - - | CB_GETCURSEL - - | CB_DIR of { attrs: ComboBase.CBDirAttr list, fileSpec: string } - - | CB_GETLBTEXT of { index: int, length: int, text: string ref } - - | CB_GETLBTEXTLEN of { index: int } - - | CB_INSERTSTRING of { index: int, text: string } - - | CB_RESETCONTENT - - | CB_FINDSTRING of { indexStart: int, text: string } - - | CB_SELECTSTRING of { indexStart: int, text: string } - - | CB_SETCURSEL of { index: int } - - | CB_SHOWDROPDOWN of { show: bool } - - | CB_GETITEMDATA of { index: int } - - | CB_SETITEMDATA of { index: int, data: int } - - | CB_GETDROPPEDCONTROLRECT of { rect: RECT ref } - - | CB_SETITEMHEIGHT of { index: int, height: int } - - | CB_GETITEMHEIGHT of { index: int } - - | CB_SETEXTENDEDUI of { extended: bool } - - | CB_GETEXTENDEDUI - - | CB_GETDROPPEDSTATE - - | CB_FINDSTRINGEXACT of { indexStart: int, text: string } - - | CB_SETLOCALE of { locale: int } - - | CB_GETLOCALE - - | CB_GETTOPINDEX - - | CB_SETTOPINDEX of { index: int } - - | CB_GETHORIZONTALEXTENT - - | CB_SETHORIZONTALEXTENT of { extent: int } - - | CB_GETDROPPEDWIDTH - - | CB_SETDROPPEDWIDTH of { width: int } - - | CB_INITSTORAGE of { items: int, bytes: int } - - | LB_ADDSTRING of { text: string } - - | LB_INSERTSTRING of { index: int, text: string } - - | LB_DELETESTRING of { index: int } - - | LB_SELITEMRANGEEX of { first: int, last: int } - - | LB_RESETCONTENT - - | LB_SETSEL of { select: bool, index: int } - - | LB_SETCURSEL of { index: int } - - | LB_GETSEL of { index: int } - - | LB_GETCURSEL - - | LB_GETTEXT of { index: int, length: int, text: string ref } - - | LB_GETTEXTLEN of { index: int } - - | LB_GETCOUNT - - | LB_SELECTSTRING of { indexStart: int, text: string } - - | LB_DIR of { attrs: ComboBase.CBDirAttr list, fileSpec: string } - - | LB_GETTOPINDEX - - | LB_FINDSTRING of { indexStart: int, text: string } - - | LB_GETSELCOUNT - - | LB_GETSELITEMS of { items: IntArray.array } - - | LB_SETTABSTOPS of { tabs: IntVector.vector } - - | LB_GETHORIZONTALEXTENT - - | LB_SETHORIZONTALEXTENT of { extent: int } - - | LB_SETCOLUMNWIDTH of { column: int } - - | LB_ADDFILE of { fileName: string } - - | LB_SETTOPINDEX of { index: int } - - | LB_GETITEMRECT of { rect: RECT ref, index: int } - - | LB_GETITEMDATA of { index: int } - - | LB_SETITEMDATA of { index: int, data: int } - - | LB_SELITEMRANGE of { select: bool, first: int, last: int } - - | LB_SETANCHORINDEX of { index: int } - - | LB_GETANCHORINDEX - - | LB_SETCARETINDEX of { index: int, scroll: bool } - - | LB_GETCARETINDEX - - | LB_SETITEMHEIGHT of { index: int, height: int } - - | LB_GETITEMHEIGHT of { index: int } - - | LB_FINDSTRINGEXACT of { indexStart: int, text: string } - - | LB_SETLOCALE of { locale: int } (* Should be an abstract type? *) - - | LB_GETLOCALE (* Result will be the type used above. *) - - | LB_SETCOUNT of { items: int } - - | LB_INITSTORAGE of { items: int, bytes: int } - - | LB_ITEMFROMPOINT of { point: POINT } - - | STM_GETICON - - | STM_GETIMAGE of {imageType: ImageType} - - | STM_SETICON of {icon: HICON} - - | STM_SETIMAGE of {image: HGDIOBJ, imageType: ImageType} - - | SBM_SETPOS of { pos: int, redraw: bool } - - | SBM_GETPOS - - | SBM_SETRANGE of { minPos: int, maxPos: int } - - | SBM_SETRANGEREDRAW of { minPos: int, maxPos: int } - - | SBM_GETRANGE of { minPos: int ref, maxPos: int ref } - - | SBM_ENABLE_ARROWS of ScrollBase.enableArrows - - | SBM_SETSCROLLINFO of - { info: ScrollBase.SCROLLINFO, options: ScrollBase.ScrollInfoOption list } - - | SBM_GETSCROLLINFO of - { info: ScrollBase.SCROLLINFO ref, options: ScrollBase.ScrollInfoOption list } - - | FINDMSGSTRING of - { flags: findReplaceFlags, findWhat: string, replaceWith: string } - - - type MSG = { - msg: Message, - hwnd: HWND, - time: Time.time, - pt: {x: int, y: int} - } - - val GetInputState: unit -> bool - val GetMessage: HWND option * int * int -> MSG - val GetMessagePos: unit -> POINT - val GetMessageTime: unit -> Time.time - - datatype - QueueStatus = - QS_ALLPOSTMESSAGE - | QS_HOTKEY - | QS_KEY - | QS_MOUSEBUTTON - | QS_MOUSEMOVE - | QS_PAINT - | QS_POSTMESSAGE - | QS_SENDMESSAGE - | QS_TIMER - val QS_ALLEVENTS: QueueStatus list - val QS_ALLINPUT: QueueStatus list - val QS_INPUT: QueueStatus list - val QS_MOUSE: QueueStatus list - val GetQueueStatus: QueueStatus list -> QueueStatus list - - val InSendMessage: unit -> bool - - datatype PeekMessageOptions = PM_NOREMOVE | PM_REMOVE - val PeekMessage: HWND option * int * int * PeekMessageOptions -> MSG option - val PostQuitMessage: int -> unit - val RegisterWindowMessage: string -> int - val RunApplication: unit -> int - val SendMessage: HWND * Message -> LRESULT - val PostMessage: HWND * Message -> unit - val HWND_BROADCAST: HWND - val WaitMessage: unit -> bool - - (* These last few are just used internally. *) - val subclass: - HWND * (HWND * Message * 'a -> LRESULT * 'a) * 'a -> - (HWND * Message -> LRESULT) - - val setCallback: (HWND * Message * 'a -> LRESULT * 'a) * 'a -> unit - val addModelessDialogue: HWND * (unit->unit) option -> unit - val removeCallback: HWND -> unit - (*val updateWindowHandle: HWND -> unit*) - val compileMessage: Message -> int * SysWord.word * SysWord.word * (unit->unit) - val decompileMessage: int * SysWord.word * SysWord.word -> Message - val messageReturnFromParams: - Message * SysWord.word * SysWord.word * SysWord.word -> LRESULT - val updateParamsFromMessage: Message * SysWord.word * SysWord.word -> unit - val LPMSG: MSG Foreign.conversion - val mainWinProc: (HWND * int * SysWord.word * SysWord.word -> SysWord.word) Foreign.closure -end; diff --git a/mlsource/extra/Win/Menu.sml b/mlsource/extra/Win/Menu.sml deleted file mode 100644 index 40f5716c..00000000 --- a/mlsource/extra/Win/Menu.sml +++ /dev/null @@ -1,586 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Menu: - sig - type HMENU and HBITMAP and HWND and HINSTANCE - type RECT = { left: int, top: int, right: int, bottom: int } - - datatype MenuFlag = - MF_BYCOMMAND | MF_BYPOSITION | MF_SEPARATOR | MF_ENABLED | MF_GRAYED | - MF_DISABLED | MF_UNCHECKED | MF_CHECKED | MF_USECHECKBITMAPS | MF_STRING | - MF_BITMAP | MF_OWNERDRAW | MF_POPUP | MF_MENUBARBREAK | MF_MENUBREAK | - MF_UNHILITE | MF_HILITE | MF_DEFAULT | MF_SYSMENU | MF_HELP | - MF_RIGHTJUSTIFY | MF_MOUSESELECT - - datatype MenuIdOrHandle = MenuHandle of HMENU | MenuId of int - - datatype MenuItemOptions = - MFT_MENUBARBREAK - | MFT_MENUBREAK - | MFT_RADIOCHECK - | MFT_RIGHTJUSTIFY - | MFT_RIGHTORDER - - datatype MenuItemType = - MFT_BITMAP of HBITMAP - | MFT_OWNERDRAW of SysWord.word - | MFT_SEPARATOR - | MFT_STRING of string - - datatype MenuState = - MFS_CHECKED - | MFS_DEFAULT - | MFS_DISABLED - | MFS_ENABLED - | MFS_GRAYED - | MFS_HILITE - | MFS_UNCHECKED - | MFS_UNHILITE - - type MenuItemInfo = - { - menuType: MenuItemType, - menuOptions: MenuItemOptions list, - state: MenuState list, - wID: int, - hSubMenu: HMENU option, - hbmpChecked: HBITMAP option, - hbmpUnchecked: HBITMAP option, - itemData: int - } - - val AppendMenu : HMENU * MenuFlag list * MenuIdOrHandle * MenuItemType -> unit - val CheckMenuRadioItem : HMENU * int * int * int * MenuFlag -> unit - val CreateMenu : unit -> HMENU - val CreatePopupMenu : unit -> HMENU - val DeleteMenu : HMENU * int * MenuFlag -> unit - val DestroyMenu : HMENU -> unit - val DrawMenuBar : HWND -> unit - val EnableMenuItem : HMENU * int * MenuFlag -> MenuFlag list - val GetMenu : HWND -> HMENU - - datatype GMDIFlags = GMDI_GOINTOPOPUPS | GMDI_USEDISABLED - val GetMenuDefaultItem : HMENU * bool * GMDIFlags list -> int - - val GetMenuItemCount : HMENU -> int - val GetMenuItemID : HMENU -> int - val GetMenuItemInfo : HMENU * int * bool -> MenuItemInfo - val GetMenuItemRect : HWND * HMENU * int -> RECT - val GetMenuState : HMENU * int * MenuFlag -> MenuFlag list * int - val GetMenuString : HMENU * int * MenuFlag -> string - val GetSubMenu : HMENU * int -> HMENU - val GetSystemMenu : HWND * bool -> HMENU - val HiliteMenuItem : HWND * HMENU * int * MenuFlag list -> unit - val InsertMenu : HMENU * int * MenuFlag list * MenuIdOrHandle * MenuItemType -> unit - val IsMenu : HMENU -> bool - val LoadMenu : HINSTANCE * Resource.RESID -> HMENU - val ModifyMenu : HMENU * int * MenuFlag list * MenuIdOrHandle * MenuItemType -> unit - val RemoveMenu : HMENU * int * MenuFlag -> unit - val SetMenu : HWND * HMENU option -> unit - val SetMenuItemInfo : HMENU * int * bool * MenuItemInfo -> unit - val InsertMenuItem : HMENU * int * bool * MenuItemInfo -> unit - - datatype TrackPopupMenuOptions = - TPM_LEFTBUTTON | TPM_RIGHTBUTTON | TPM_LEFTALIGN | TPM_CENTERALIGN | TPM_RIGHTALIGN | - TPM_TOPALIGN | TPM_VCENTERALIGN | TPM_BOTTOMALIGN | (*TPM_HORIZONTAL | TPM_VERTICAL |*) - TPM_NONOTIFY | TPM_RETURNCMD - val TrackPopupMenu : HMENU * TrackPopupMenuOptions list * int * int * HWND -> int - - val SetMenuContextHelpId: HMENU * int -> unit - val GetMenuContextHelpId: HMENU -> int - end = -struct - local - open Foreign - open Base - in - open MenuBase - - type HMENU = HMENU and HBITMAP = HBITMAP and RECT = RECT and HWND = HWND - and HINSTANCE = HINSTANCE - - val isHmenuNull = isHmenuNull - - fun checkMenu c = (checkResult(not(isHmenuNull c)); c) - - (* Check here means "make active", the opposite of uncheck *) - val CheckMenuRadioItem = - checkResult o - winCall5 (user "CheckMenuRadioItem") (cHMENU, cUint, cUint, cUint, cMENUFLAG) cBool - - val CreateMenu = - checkMenu o winCall0 (user "CreateMenu") () cHMENU - - val CreatePopupMenu = - checkMenu o winCall0 (user "CreatePopupMenu") () cHMENU - - val DeleteMenu = - checkResult o - winCall3 (user "DeleteMenu") (cHMENU, cUint, cMENUFLAG) cBool - - val DestroyMenu = - checkResult o winCall1 (user "DestroyMenu") (cHMENU) cBool - - val DrawMenuBar = - checkResult o winCall1 (user "DrawMenuBar") (cHWND) cBool - - local - val enableCall = winCall3(user "EnableMenuItem") (cHMENU, cUint, cMENUFLAG) cUintw - in - fun EnableMenuItem(hMenu: HMENU, id: int, flags: MenuFlag): MenuFlag list = - let - val res = enableCall(hMenu, id, flags) - in - checkResult(res <> ~ 0w1); - toMenuFlagSet res - end - end - - val GetMenu = winCall1 (user "GetMenu") (cHWND) cHMENU - - datatype GMDIFlags = GMDI_GOINTOPOPUPS | GMDI_USEDISABLED - local - val tab = [ - (GMDI_USEDISABLED, 0wx0001), - (GMDI_GOINTOPOPUPS, 0wx0002) ] - in - val GMDIFLAGS = tableSetConversion(tab, NONE) - end - - local - val callGMDI = winCall3 (user "GetMenuDefaultItem") (cHMENU, cBool, GMDIFLAGS) cUint - in - fun GetMenuDefaultItem(hMenu: HMENU, m: bool, opts: GMDIFlags list): int = - let - - val res = callGMDI(hMenu, m, opts) - in - checkResult(res <> ~1); - res - end - end - - local - val getMenuItemCount = winCall1 (user "GetMenuItemCount") (cHMENU) cInt - in - fun GetMenuItemCount hMenu = - case getMenuItemCount hMenu of - ~1 => raiseSysErr() - | n => n - end - - val GetMenuItemID = winCall1 (user "GetMenuItemID") (cHMENU) cUint - - local - val getMenuString = winCall5 (user "GetMenuStringA") - (cHMENU,cUint,cPointer,cInt,cMENUFLAG) (cPOSINT "GetMenuString") - in - (* We can get the length by passing null first, then get the actual string. *) - fun GetMenuString(h,i,f): string = - getStringWithNullIsLength(fn (buff, n) => getMenuString(h,i,buff,n,f)) - end - - - datatype MenuItemType = - MFT_BITMAP of HBITMAP - | MFT_SEPARATOR - | MFT_STRING of string - | MFT_OWNERDRAW of SysWord.word - - val mft_STRING = 0wx00000000 (* Replaced by MIIM_STRING *) - val mft_BITMAP = 0wx00000004 (* Replaced by MIIM_BITMAP and hbmpItem *) - val mft_OWNERDRAW = 0wx00000100 - val mft_SEPARATOR = 0wx00000800 - val mft_POPUP = 0wx00000010 - val typeBits = 0wx914 - - datatype MenuItemOptions = - MFT_MENUBARBREAK - | MFT_MENUBREAK - | MFT_RADIOCHECK - | MFT_RIGHTJUSTIFY - | MFT_RIGHTORDER - - local - val tab = [ - (MFT_MENUBARBREAK, 0wx00000020: Word32.word), - (MFT_MENUBREAK, 0wx00000040), - (MFT_RADIOCHECK, 0wx00000200), - (MFT_RIGHTORDER, 0wx00002000), - (MFT_RIGHTJUSTIFY, 0wx00004000)] - in - val (fromMFT, toMFT) = tableSetLookup(tab, NONE) - end - - datatype MenuState = - MFS_GRAYED - | MFS_DISABLED - | MFS_CHECKED - | MFS_DEFAULT - | MFS_HILITE - | MFS_ENABLED - | MFS_UNCHECKED - | MFS_UNHILITE - - local - val tab = [ - (MFS_DISABLED, 0wx00000002), - (MFS_ENABLED, 0wx00000000), - (MFS_GRAYED, 0wx00000003), - (MFS_CHECKED, 0wx00000008), - (MFS_UNCHECKED, 0wx00000000), - (MFS_HILITE, 0wx00000080), - (MFS_UNHILITE, 0wx00000000), - (MFS_DEFAULT, 0wx00001000)] - in - val cMENUSTATE = tableSetConversion(tab, NONE) - end - - type MenuItemInfo = - { - (*mask: int,*) (* Datatype? *) - menuType: MenuItemType, - menuOptions: MenuItemOptions list, - state: MenuState list, - wID: int, - hSubMenu: HMENU option, - hbmpChecked: HBITMAP option, - hbmpUnchecked: HBITMAP option, - itemData: int - } - - (* Although we can selectively return information it's probably simpler to - return the lot. It's only in SetMenuItemInfo where we might want to - update only some of the information. - To find out if we've got all the string we will have to loop until - the value of cch we get back is less than the buffer we passed. *) - local - (* Flags used in GetItemInfo and SetItemInfo. *) - (*val MIIM_STATE = 0x00000001 - val MIIM_ID = 0x00000002 - val MIIM_SUBMENU = 0x00000004 - val MIIM_CHECKMARKS = 0x00000008 - (*val MIIM_TYPE = 0x00000010 *) (* Replaced by new fields. *) - val MIIM_DATA = 0x00000020 - val MIIM_STRING = 0x00000040 (* Added *) - val MIIM_BITMAP = 0x00000080 (* Added *) - val MIIM_FTYPE = 0x00000100*) - val allInfo = 0x1ef - - val cMENUITEMINFO = - cStruct12(cUintw,cUint,cUintw,cMENUSTATE,cUint,cHMENUOPT,cHGDIOBJOPT, - cHGDIOBJOPT,cULONG_PTR,cPointer,cUint, cHGDIOBJ) - val {ctype={size=sizeMenuItemStruct, ...}, ...} = breakConversion cMENUITEMINFO - val sizeMenuItemStruct = Word32.fromLargeWord(Word.toLargeWord sizeMenuItemStruct) - (*val (fromCmenuiteminfo, toCmenuiteminfo, menuItemStruct) = breakConversion MENUITEMINFO*) - val getMenuItemInfo = - winCall4 (user "GetMenuItemInfoA") (cHMENU, cUint, cBool, cStar cMENUITEMINFO) - (successState "GetMenuItemInfo") - val setMenuItemInfo = - winCall4 (user "SetMenuItemInfoA") (cHMENU, cUint, cBool, cConstStar cMENUITEMINFO) - (successState "SetMenuItemInfo") - val insertMenuItem = - winCall4 (user "InsertMenuItemA") (cHMENU, cUint, cBool, cConstStar cMENUITEMINFO) - (successState "InsertMenuItem") - in - fun GetMenuItemInfo(hMenu: HMENU, uItem: int, fByPosition): MenuItemInfo = - let - (* First request allInfo. Look at the returned type and cch. If cch is - non-zero allocate memory of cch+1 and pass memory pointer and cch+1 to - get the string. *) - val r = ref (sizeMenuItemStruct, allInfo, 0w0, [], 0, NONE, NONE, NONE, 0, Memory.null, 0, hNull) - val () = getMenuItemInfo(hMenu, uItem, fByPosition, r) - val cch = #11(!r) - val str = - if cch = 0 then "" - else - let - open Memory - val v = malloc (Word.fromInt cch + 0w1) - val () = - r := (sizeMenuItemStruct, allInfo, 0w0, [], 0, NONE, NONE, NONE, 0, v, cch+1, hNull) - in - (* Get the string. Updates r *) - getMenuItemInfo(hMenu, uItem, fByPosition, r) - handle ex => (free v; raise ex); - fromCstring v before free v - end - val (_, _, mtype, state, wID, hSubMenu, hbmpChecked, hbmpUnchecked, - itemData, typeData, _, hbmp) = ! r - val menuType = - if Word32.andb(mtype, mft_BITMAP) <> 0w0 - then MFT_BITMAP hbmp - else if Word32.andb(mtype, mft_OWNERDRAW) <> 0w0 - then MFT_OWNERDRAW(Memory.voidStar2Sysword typeData) - else if Word32.andb(mtype, mft_SEPARATOR) <> 0w0 - then MFT_SEPARATOR - else (* String *) MFT_STRING str - (* The options are the other bits in the type field. *) - val menuOptions = - toMFT(Word32.andb(Word32.notb typeBits, mtype)) - in - { menuType = menuType, menuOptions = menuOptions, wID = wID, - hSubMenu = hSubMenu, hbmpChecked = hbmpChecked, - hbmpUnchecked = hbmpUnchecked, itemData = itemData, - state = state } - end - - (* It's simplest to set everything. *) - fun SetMenuItemInfo(hMenu: HMENU, uItem: int, fByPosition, - ({menuType, menuOptions, wID, hSubMenu, hbmpChecked, hbmpUnchecked, - itemData, state }: MenuItemInfo)) = - let - open Memory - val (bits, typeData, cch, bmp) = - case menuType of - MFT_BITMAP b => (mft_BITMAP, null, 0, b) - | MFT_OWNERDRAW i => (mft_OWNERDRAW, sysWord2VoidStar i, 0, hNull) - | MFT_SEPARATOR => (mft_SEPARATOR, null, 0, hNull) - | MFT_STRING s => (mft_STRING, toCstring s, size s + 1, hNull) - - val mtype = Word32.orb(fromMFT menuOptions, bits) - val r = (sizeMenuItemStruct, allInfo, mtype, state, wID, - hSubMenu, hbmpChecked, hbmpUnchecked, itemData, typeData, cch, bmp) - in - setMenuItemInfo(hMenu, uItem, fByPosition, r) - handle ex => (free typeData; raise ex); - free typeData - end - - fun InsertMenuItem(hMenu: HMENU, uItem: int, fByPosition, - ({menuType, menuOptions, wID, hSubMenu, hbmpChecked, hbmpUnchecked, - itemData, state }: MenuItemInfo)) = - let - open Memory - val (bits, typeData, cch, bmp) = - case menuType of - MFT_BITMAP b => (mft_BITMAP, null, 0, b) - | MFT_OWNERDRAW i => (mft_OWNERDRAW, sysWord2VoidStar i, 0, hNull) - | MFT_SEPARATOR => (mft_SEPARATOR, null, 0, hNull) - | MFT_STRING s => (mft_STRING, toCstring s, size s + 1, hNull) - - val mtype = Word32.orb(fromMFT menuOptions, bits) - val r = (sizeMenuItemStruct, allInfo, mtype, state, wID, - hSubMenu, hbmpChecked, hbmpUnchecked, itemData, typeData, cch, bmp) - in - insertMenuItem(hMenu, uItem, fByPosition, r) - handle ex => (free typeData; raise ex); - free typeData - end - end - - local - val getMenuState = winCall3 (user "GetMenuState") (cHMENU,cUint,cMENUFLAG) cUintw - in - (* If the menu opens a submenu the high order word is the number of - items. The low order word is the state. *) - fun GetMenuState (hm, i, mf): MenuFlag list * int = - let - val res = getMenuState(hm, i, mf) - in - checkResult(res <> ~ 0w1); - (toMenuFlagSet(Word32.fromLargeWord(Word.toLargeWord(LOWORD res))), Word.toInt(HIWORD res)) - end - end - - val GetSubMenu = winCall2 (user "GetSubMenu") (cHMENU,cInt) cHMENU - - val GetSystemMenu = winCall2 (user "GetSystemMenu") (cHWND,cBool) cHMENU - - val HiliteMenuItem = - winCall4 (user "HiliteMenuItem") (cHWND,cHMENU,cUint,cMENUFLAGSET) (successState "HiliteMenuItem") - - val IsMenu = winCall1 (user "IsMenu") (cHMENU) cBool - - (* InsertMenu can insert a string item or a submenu. *) - datatype MenuIdOrHandle = - MenuId of int - | MenuHandle of HMENU - - local - open Memory - (* Get the menu item. If this is a string we have to free the memory afterwards. *) - fun getDisplay (MFT_BITMAP hb) = (mft_BITMAP, voidStarOfHandle hb, null) - | getDisplay MFT_SEPARATOR = (mft_SEPARATOR, null, null) - | getDisplay (MFT_STRING (s: string)) = let val v = toCstring s in (mft_STRING, v, v) end - | getDisplay (MFT_OWNERDRAW i) = (mft_OWNERDRAW, sysWord2VoidStar i, null) - - fun InsertOrModifyMenu (functionName: string) = - let - val docall = - winCall5 (user functionName) (cHMENU,cUint,cUintw,cPointer,cPointer) (successState functionName) - in - fn(hMenu: HMENU, pos: int, flags: MenuFlag list, - new: MenuIdOrHandle, disp: MenuItemType) => - let - (* Flags - mask out the ones we set by other means. *) - val f1 = Word32.andb(fromMenuFlagSet flags, Word32.notb typeBits) - (* The C call incorporates various options within the flags. It's better, - in ML, to pull these out and treat them as part of the datatype. *) - (* The "new" argument indicates whether the item is a sub-menu or - should send a message containing the id when the menu item is - selected. *) - val (f2, id) = - case new of - MenuId i => (0w0, sysWord2VoidStar (SysWord.fromInt i)) - | MenuHandle m => (mft_POPUP, voidStarOfHandle m) - (* The "disp" argument describes how the item is displayed. *) - val (f3, str, toFree) = getDisplay disp - val flags = List.foldl Word32.orb 0w0 [f1,f2,f3] - in - docall(hMenu, pos, flags, id, str) - handle ex => (free toFree; raise ex); - free toFree - end - end - - val appendMenu = - winCall4 (user "AppendMenuA") (cHMENU,cUintw,cPointer,cPointer) (successState "AppendMenuA") - in - val InsertMenu = InsertOrModifyMenu "InsertMenuA" - and ModifyMenu = InsertOrModifyMenu "ModifyMenuA" - - fun AppendMenu(hMenu: HMENU, flags: MenuFlag list, new: MenuIdOrHandle, disp: MenuItemType) = - let - val f1 = Word32.andb(fromMenuFlagSet flags, Word32.notb typeBits) - val (f2, id) = - case new of - MenuId i => (0w0, sysWord2VoidStar (SysWord.fromInt i)) - | MenuHandle m => (mft_POPUP, voidStarOfHandle m) - val (f3, str, toFree) = getDisplay disp - val flags = List.foldl Word32.orb 0w0 [f1,f2,f3] - in - appendMenu (hMenu, flags, id, str) - handle ex => (free toFree; raise ex); - free toFree - end - end - - val RemoveMenu = winCall3(user "RemoveMenu") (cHMENU, cUint, cMENUFLAG) (successState "RemoveMenu") - - datatype TrackPopupMenuOptions = - TPM_LEFTBUTTON | TPM_RIGHTBUTTON | TPM_LEFTALIGN | TPM_CENTERALIGN | TPM_RIGHTALIGN | - TPM_TOPALIGN | TPM_VCENTERALIGN | TPM_BOTTOMALIGN | (*TPM_HORIZONTAL | TPM_VERTICAL |*) - TPM_NONOTIFY | TPM_RETURNCMD - - local - val tab = [ - (TPM_LEFTBUTTON, 0wx0000), - (TPM_RIGHTBUTTON, 0wx0002), - (TPM_LEFTALIGN, 0wx0000), - (TPM_CENTERALIGN, 0wx0004), - (TPM_RIGHTALIGN, 0wx0008), - (TPM_TOPALIGN, 0wx0000), - (TPM_VCENTERALIGN, 0wx0010), - (TPM_BOTTOMALIGN, 0wx0020), - (*(TPM_HORIZONTAL, 0wx0000), - (TPM_VERTICAL, 0wx0040),*) - (TPM_NONOTIFY, 0wx0080), - (TPM_RETURNCMD, 0wx0100) - ] - in - val TRACKPOPUPOPTIONS = tableSetConversion(tab, NONE) - end - - local - val trackPopupMenu = - winCall7 (user "TrackPopupMenu") - (cHMENU, TRACKPOPUPOPTIONS, cInt, cInt, cInt, cHWND, cPointer) cInt - in - fun TrackPopupMenu(menu, flags, x, y, owner) = - trackPopupMenu(menu, flags, x, y, 0, owner, Memory.null) - end - - local - val getMenuItemRect = - winCall4 (user "GetMenuItemRect") (cHWND, cHMENU, cUint, cStar cRect) (successState "GetMenuItemRect") - in - fun GetMenuItemRect(hWnd, hMenu, item): RECT = - let - val r = ref { top = 0, bottom=0, left=0, right=0} - val () = getMenuItemRect(hWnd, hMenu, item, r) - in - ! r - end - end - - val LoadMenu = winCall2 (user "LoadMenuA") (cHINSTANCE, cRESID) cHMENU - val SetMenu = winCall2 (user "SetMenu") (cHWND, cHMENUOPT) (successState "SetMenu") - - val SetMenuContextHelpId = - winCall2 (user "SetMenuContextHelpId") (cHMENU, cDWORD) - (successState "SetWindowContextHelpId") - - val GetMenuContextHelpId = winCall1 (user "GetMenuContextHelpId") (cHMENU) cDWORD - - (* *) - (*fun LoadMenuIndirect (mlist: (MenuFlag list * int * string) list list) = - let - val count = List.length mlist - val menu = *) -(* -TODO: -GetMenuCheckMarkDimensions - use GetSystemMetrics -LoadMenuIndirect -MenuItemFromPoint -SetMenuDefaultItem -SetMenuItemBitmaps -TrackPopupMenuEx - -Obsolete Functions -CheckMenuItem -GetMenuCheckMarkDimensions -ModifyMenu -*) - end -end; -(* -struct - - datatype MenuItemData = MID of {option: Style.flag, id:MenuItem, display:string} - - (* I don't think this will work. The strings have to be Unicode. *) - fun LoadMenuIndirect (mlist) = - let val count = List.length mlist - - val menu = alloc count (Cstruct [Cshort,Cshort,Cpointer Cchar]) - - fun pl2a v n [] = () - | pl2a v n (MID {option=flag, - id= MenuID id, - display=s} :: rest) = - let - val item = make_struct [(Cshort,toCshort (repE MenuFlagE flag)), - (Cshort,toCshort id ), - (Cpointer Cchar,toCstring s) ] - in - ( assign (Cstruct [Cshort,Cshort,Cpointer Cchar]) - (offset n (Cstruct [Cshort,Cshort,Cpointer Cchar]) v) item ; - pl2a v (n+1) rest ) - end - - val u = pl2a menu 0 mlist - - in - winCall1 (getuser "LoadMenuIndirectA") - (POINTER) (cHMENU) - (address menu) - end -end; -*) diff --git a/mlsource/extra/Win/MenuBase.sml b/mlsource/extra/Win/MenuBase.sml deleted file mode 100644 index 3d75cf69..00000000 --- a/mlsource/extra/Win/MenuBase.sml +++ /dev/null @@ -1,73 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure MenuBase = -struct - local - open Foreign Base - in - (* TODO: This duplicates some of the other datatypes. *) - datatype MenuFlag = - (*MF_INSERT | MF_CHANGE | MF_APPEND | MF_DELETE | MF_REMOVE | *) - MF_BYCOMMAND | MF_BYPOSITION | MF_SEPARATOR | MF_ENABLED | MF_GRAYED | - MF_DISABLED | MF_UNCHECKED | MF_CHECKED | MF_USECHECKBITMAPS | MF_STRING | - MF_BITMAP | MF_OWNERDRAW | MF_POPUP | MF_MENUBARBREAK | MF_MENUBREAK | - MF_UNHILITE | MF_HILITE | MF_DEFAULT | MF_SYSMENU | MF_HELP | - MF_RIGHTJUSTIFY | MF_MOUSESELECT - - local - val tab = [ - (*(MF_INSERT, 0wx00000000), - (MF_CHANGE, 0wx00000080), - (MF_APPEND, 0wx00000100), - (MF_DELETE, 0wx00000200), - (MF_REMOVE, 0wx00001000),*) - (MF_BYCOMMAND, 0wx00000000), - (MF_BYPOSITION, 0wx00000400), - (MF_SEPARATOR, 0wx00000800), - (MF_ENABLED, 0wx00000000), - (MF_GRAYED, 0wx00000001), - (MF_DISABLED, 0wx00000002), - (MF_UNCHECKED, 0wx00000000), - (MF_CHECKED, 0wx00000008), - (MF_USECHECKBITMAPS, 0wx00000200), - (MF_STRING, 0wx00000000), - (MF_BITMAP, 0wx00000004), - (MF_OWNERDRAW, 0wx00000100), - (MF_POPUP, 0wx00000010), - (MF_MENUBARBREAK, 0wx00000020), - (MF_MENUBREAK, 0wx00000040), - (MF_UNHILITE, 0wx00000000), - (MF_HILITE, 0wx00000080), - (MF_DEFAULT, 0wx00001000), - (MF_SYSMENU, 0wx00002000), - (MF_HELP, 0wx00004000), - (MF_RIGHTJUSTIFY, 0wx00004000), - (MF_MOUSESELECT, 0wx00008000) - ] - in - val (fromMenuFlagSet, toMenuFlagSet) = tableSetLookup(tab, NONE) - val cMENUFLAGSET = absConversion {abs=toMenuFlagSet, rep=fromMenuFlagSet} cUintw - (* Sometimes we just want a single flag - either MF_BYCOMMAND or MF_BYPOSITION - or, for WM_MENUCHAR, MF_POPUP or MF_SYSMENU. *) - val (fromMenuFlag, toMenuFlag) = tableLookup(tab, NONE) - val cMENUFLAG = tableConversion(tab, NONE) cUintw - end - - end -end; diff --git a/mlsource/extra/Win/Message.sml b/mlsource/extra/Win/Message.sml deleted file mode 100644 index be08ca3e..00000000 --- a/mlsource/extra/Win/Message.sml +++ /dev/null @@ -1,3867 +0,0 @@ -(* - Copyright (c) 2001-7, 2015, 2019, 2021 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Message: MESSAGE = -struct - local - open Foreign - open Memory - open Base - open Globals - open WinBase - fun user name = getSymbol(loadLibrary "user32.dll") name - - val toAddr = Memory.sysWord2VoidStar - and fromAddr = Memory.voidStar2Sysword - - val RegisterMessage = winCall1 (user "RegisterWindowMessageA") cString cUint - - (* Used in WM_WINDOWPOSXXX and also WM_NCCALCSIZE *) - val WINDOWPOS = cStruct7(cHWND, cHWND, cInt, cInt, cInt, cInt, cWINDOWPOSITIONSTYLE) - - local (* WM_WINDOWPOSCHANGING and WM_WINDOWPOSCHANGED. The C structure is the same - but WM_WINDOWPOSCHANGING has refs in the ML to allow the call-back to - change the position. *) - val {load=fromCwindowpos, store=toCwindowpos, ctype={size=sizeCwp, ...}, ...} = breakConversion WINDOWPOS - type wmWINDOWPOSCHANGED = - { hwnd: HWND, front: HWND, x: int, y: int, width: int, height: int, flags: WindowPositionStyle list } - and wmWINDOWPOSCHANGING = - { - hwnd: HWND, front: HWND ref, x: int ref, y: int ref, - width: int ref, height: int ref, flags: WindowPositionStyle list ref - } - in - fun cToMLWindowPosChanging{wp=_, lp}: wmWINDOWPOSCHANGING = - let - val (wh,front,x,y,width,height,flags) = fromCwindowpos(toAddr lp) - in - {hwnd = wh, front = ref front, x = ref x, y = ref y, - width = ref width, height = ref height, flags = ref flags} - end - and cToMLWindowPosChanged{wp=_, lp}: wmWINDOWPOSCHANGED = - let - val (wh,front,x,y,width,height,flags) = fromCwindowpos(toAddr lp) - in - {hwnd = wh, front = front, x = x, y = y, width = width, height = height, flags = flags} - end - - fun mlToCWindowPosChanging(msgNo, {hwnd, front=ref front, x=ref x, y=ref y, - width=ref width, height=ref height, flags=ref flags}: wmWINDOWPOSCHANGING) = - let - open Memory - val mem = malloc sizeCwp - val freeCwp = toCwindowpos(mem, (hwnd, front, x, y, width, height, flags)) - in - (msgNo, 0w0, fromAddr mem, fn() => (freeCwp(); free mem)) - end - and mlToCWindowPosChanged(msgNo, {hwnd, front, x, y, width, height, flags}: wmWINDOWPOSCHANGED) = - let - open Memory - val mem = malloc sizeCwp - val freeCwp = toCwindowpos(mem, (hwnd, front, x, y, width, height, flags)) - in - (msgNo, 0w0, fromAddr mem, fn() => (freeCwp(); free mem)) - end - - fun updateCfromMLwmWindowPosChanging( - {wp=_, lp}, { front, x, y, width, height, flags, ...}:wmWINDOWPOSCHANGING) = - let - val (_,newfront,newx,newy,newwidth,newheight,newflags) = fromCwindowpos(toAddr lp) - in - front := newfront; - x := newx; - y := newy; - width := newwidth; - height := newheight; - flags := newflags - end - and updateWindowPosChangingParms({wp=_, lp}, { hwnd, front=ref front, x=ref x, y=ref y, - width=ref width, height=ref height, flags=ref flags}) = - ignore(toCwindowpos(toAddr lp, (hwnd, front, x, y, width, height, flags))) - end - - datatype ControlType = ODT_MENU | ODT_LISTBOX | ODT_COMBOBOX | ODT_BUTTON | ODT_STATIC - local - val - tab = [ - (ODT_MENU, 1), - (ODT_LISTBOX, 2), - (ODT_COMBOBOX, 3), - (ODT_BUTTON, 4), - (ODT_STATIC, 5) - ] - in - val cCONTROLTYPE = tableConversion(tab, NONE) cUint - end - - fun structAsAddr strConv = - let - val {load, store, ctype={size, ...}, ...} = breakConversion strConv - - fun make v = - let - open Memory - val mem = malloc size - val freeS = store(mem, v) - in - (fromAddr mem, fn () => (freeS(); free mem)) - end - in - (load o toAddr, make) - end - - val (_, makePointStructAddr) = structAsAddr cPoint - - local - val MDICREATESTRUCT = cStruct9(cCLASS,cString,cHINSTANCE,cInt,cInt,cInt,cInt,cDWORD,cLPARAM) - in - val (toMdiCreate, fromMdiCreate) = structAsAddr MDICREATESTRUCT - end - - local (* WM_COMPAREITEM *) - val COMPAREITEMSTRUCT = cStruct8(cCONTROLTYPE,cUint,cHWND,cUint,cUINT_PTRw,cUint,cUINT_PTRw, cDWORD) - val MEASUREITEMSTRUCT = cStruct6(cCONTROLTYPE,cUint,cUint,cUint,cUint,cULONG_PTR) - val DELETEITEMSTRUCT = cStruct5(cCONTROLTYPE,cUint,cUint,cHWND,cULONG_PTR) - val {store=toMeasureItem, ...} = breakConversion MEASUREITEMSTRUCT - in - val (toMLCompareItem, fromMLCompareItem) = structAsAddr COMPAREITEMSTRUCT - and (toMLMeasureItem, fromMLMeasureItem) = structAsAddr MEASUREITEMSTRUCT - and (toMLDeleteItem, fromMLDeleteItem) = structAsAddr DELETEITEMSTRUCT - - fun updateMeasureItemFromWpLp({itemWidth, itemHeight, ...}, {wp=_, lp}) = - let - val (_, _, _, iWidth, iHeight, _) = toMLMeasureItem lp - in - itemWidth := iWidth; - itemHeight := iHeight - end - and updateMeasureItemParms({wp=_, lp}, {itemWidth=ref itemWidth, itemHeight=ref itemHeight, ...}) = - let - val (ctlType, ctlID, itemID, _, _, itemData) = toMLMeasureItem lp - in - ignore(toMeasureItem(toAddr lp, (ctlType, ctlID, itemID, itemWidth, itemHeight, itemData))) - end - end - - local (* WM_CREATE and WM_NCCREATE *) - val CREATESTRUCT = cStruct12(cPointer,cHINSTANCE,cHMENU,cHWND,cInt,cInt,cInt,cInt,cUlongw,cString,cCLASS,cDWORD) - val (toMLCreate, fromMLCreate) = structAsAddr CREATESTRUCT - in - fun decompileCreate{wp=_, lp} = - let - val (cp,inst,menu,parent, cy,cx,y,x, style, name,class, extendedstyle) = toMLCreate lp - in - { instance = inst, creation = cp, menu = menu, parent = parent, cy = cy, cx = cx, - y = y, x = x, style = Style.fromWord(Word32.toLargeWord style), name = name, - class = class, extendedstyle = extendedstyle } - end - - and compileCreate(code, { instance, creation, menu, parent, cy, cx, - y, x, style, name, class, extendedstyle}) = - let - val (addr, free) = - fromMLCreate(creation, instance, menu, parent, - cy, cx, y, x, Word32.fromLargeWord(Style.toWord style), name, class, - extendedstyle) - in - (code, 0w0, addr, free) - end - - end - - local - val MINMAXINFO = cStruct5(cPoint,cPoint,cPoint,cPoint,cPoint) - val {store=toCminmaxinfo, ...} = breakConversion MINMAXINFO - val (toMLMinMax, fromMLMinMax) = structAsAddr MINMAXINFO - in - fun decompileMinMax{wp=_, lp} = - let - val (_, ptms, ptmp, ptts, ptmts) = toMLMinMax lp - in - { maxSize = ref ptms, maxPosition = ref ptmp, - minTrackSize = ref ptts, maxTrackSize = ref ptmts} - end - and compileMinMax(code, { maxSize=ref maxSize, maxPosition=ref maxPosition, - minTrackSize=ref minTrackSize, maxTrackSize=ref maxTrackSize}) = - let - val (addr, free) = fromMLMinMax({x=0,y=0}, maxSize, maxPosition, minTrackSize, maxTrackSize) - in - (code, 0w0, addr, free) - end - - fun updateMinMaxFromWpLp({maxSize, maxPosition, minTrackSize, maxTrackSize}, {wp=_, lp}) = - let - val (_, ptms, ptmp, ptts, ptmts) = toMLMinMax lp - in - maxSize := ptms; - maxPosition := ptmp; - minTrackSize := ptts; - maxTrackSize := ptmts - end - and updateMinMaxParms({wp=_, lp}, {maxSize=ref maxSize, maxPosition=ref maxPosition, - minTrackSize=ref minTrackSize, maxTrackSize=ref maxTrackSize}) = - let - val (ptres, _, _, _, _) = toMLMinMax lp - in - ignore(toCminmaxinfo(toAddr lp, (ptres, maxSize, maxPosition, minTrackSize, maxTrackSize))) - end - end - - local - val DRAWITEMSTRUCT = cStruct9(cCONTROLTYPE,cUint,cUint,cUint,cUint,cHWND,cHDC,cRect,cULONG_PTR) - in - val (toMLDrawItem, fromMLDrawItem) = structAsAddr DRAWITEMSTRUCT - end - - local (* WM_NCCALCSIZE *) - val NCCALCSIZE_PARAMS = cStruct4(cRect,cRect,cRect, cConstStar WINDOWPOS) - val {load=loadStruct, store=storeStruct, ctype={size=sizeStr, ...}, ...} = breakConversion NCCALCSIZE_PARAMS - val {load=loadRect, store=storeRect, ctype={size=sizeRect, ...}, ...} = breakConversion cRect - in - fun decompileNCCalcSize{wp=0w1, lp} = - let - val (newrect,oldrect,oldclientarea,winpos) = loadStruct (toAddr lp) - val (wh,front,x,y,cx,cy,style) = winpos - in - { validarea = true, newrect = ref newrect, oldrect = oldrect, - oldclientarea = oldclientarea, hwnd = wh, insertAfter = front, - x = x, y = y, cx = cx, cy = cy, style = style } - end - - | decompileNCCalcSize{wp=_, lp} = - let - val newrect = loadRect (toAddr lp) - val zeroRect = {left=0, top=0, right=0, bottom=0} - in - { validarea = false, newrect = ref newrect, oldrect = zeroRect, - oldclientarea = zeroRect, insertAfter = hwndNull, hwnd = hwndNull, - x = 0, y = 0, cx = 0, cy = 0, style = [] } - end - - and compileNCCalcSize{validarea=true, newrect=ref newrect, oldrect, oldclientarea, - hwnd, insertAfter, x, y, cx, cy, style} = - let - open Memory - val mem = malloc sizeStr - val freeRect = - storeStruct(mem, (newrect,oldrect,oldclientarea, - (hwnd,insertAfter,x,y,cx,cy, style))) - in - (0x0083, 0w1, fromAddr mem, fn () => (freeRect(); free mem)) - end - | compileNCCalcSize{validarea=false, newrect=ref newrect, ...} = - let - open Memory - val mem = malloc sizeRect - val () = ignore(storeRect(mem, newrect)) - in - (0x0083, 0w0, fromAddr mem, fn () => free mem) - end - end - - local - val HELPINFO = cStruct6(cUint, cInt, cInt, cPointer (* HANDLE *), cDWORD, cPoint) - val {ctype={size=sizeHelpInfo, ...}, ...} = breakConversion HELPINFO - val (toHelpInfo, fromHelpInfo) = structAsAddr HELPINFO - in - datatype HelpHandle = MenuHandle of HMENU | WindowHandle of HWND - - fun compileHelpInfo(code, {ctrlId, itemHandle, contextId, mousePos}) = - let - val (ctype, handl) = - case itemHandle of - MenuHandle m => (2, voidStarOfHandle m) - | WindowHandle w => (1, voidStarOfHandle w) - val (addr, free) = - fromHelpInfo(Word.toInt sizeHelpInfo, ctype, ctrlId, handl, contextId, mousePos) - in - (code, 0w0, addr, free) - end - - and decompileHelpInfo{wp=_, lp} = - let - val (_, ctype, ctrlId, itemHandle, contextId, mousePos) = toHelpInfo lp - val hndl = - if ctype = 2 then MenuHandle(handleOfVoidStar itemHandle) - else WindowHandle(handleOfVoidStar itemHandle) - in - { ctrlId = ctrlId, itemHandle = hndl, contextId = contextId, mousePos = mousePos} - end - end - - local - val {store=storeScrollInfo, ctype = {size=sizeStruct, ...}, ...} = - breakConversion ScrollBase.cSCROLLINFOSTRUCT - val (toScrollInfoStruct, fromScrollInfoStruct) = structAsAddr ScrollBase.cSCROLLINFOSTRUCT - in - fun toScrollInfo lp = - let - val (_, options, minPos, maxPos, pageSize, pos, trackPos) = toScrollInfoStruct lp - val info = { minPos = minPos, maxPos = maxPos, pageSize = pageSize, pos = pos, trackPos = trackPos } - in - (info, options) - end - and fromScrollInfo({minPos, maxPos, pageSize, pos, trackPos}, options) = - fromScrollInfoStruct(Word.toInt sizeStruct, options, minPos, maxPos, pageSize, pos, trackPos) - and updateScrollInfo({wp=_, lp=lp}, {info=ref {minPos, maxPos, pageSize, pos, trackPos}, options}) = - ignore(storeScrollInfo(toAddr lp, (Word.toInt sizeStruct, options, minPos, maxPos, pageSize, pos, trackPos))) - end - - local - val {store=storeWord, load=loadWord, ctype={size=sizeWord, ...}, ...} = breakConversion cWORD - in - (* We have to allocate a buffer big enough to receive the text and - set the first word to the length of the buffer. *) - fun compileGetLine {lineNo, size, ...} = - let - open Memory - (* Allocate one extra byte so there's space for a null terminator. *) - val vec = malloc (Word.max(Word.fromInt(size+1), sizeWord)) - in - ignore(storeWord(vec, size+1)); - (0x00C5, SysWord.fromInt lineNo, fromAddr vec, fn () => free vec) - end - - and decompileGetLine{wp, lp} = - let - (* The first word is supposed to contain the length *) - val size = loadWord(toAddr lp) - in - { lineNo = SysWord.toInt wp, size = size(*-1 ? *), result = ref "" } - end - end - - val {load=loadInt, store=storeInt, ctype={size=sizeInt, ...}, ...} = breakConversion cInt - - local (* EM_SETTABSTOPS and LB_SETTABSTOPS *) - open Memory - infix 6 ++ - in - fun decompileTabStops{wp, lp} = - let - val v = toAddr lp - fun getTab i = loadInt(v ++ Word.fromInt i * sizeInt) - in - IntVector.tabulate(SysWord.toInt wp, getTab) - end - and compileTabStops(code, tabs) = - let - val cTabs = IntVector.length tabs - val vec = malloc(Word.fromInt cTabs * sizeInt) - fun setVec(tab, addr) = (ignore(storeInt(addr, tab)); addr ++ sizeInt) - val _ = IntVector.foldl setVec vec tabs - in - (code, SysWord.fromInt cTabs, fromAddr vec, fn () => free vec) - end - end - - local - open Memory IntArray - infix 6 ++ - in - fun compileGetSelItems(code, {items}) = - (* Allocate a buffer to receive the items. Set each element of the buffer - to ~1 so that the values are defined if not all of them are set. *) - let - open Memory IntArray - val itemCount = length items - infix 6 ++ - val v = malloc(Word.fromInt itemCount * sizeInt) - in - appi(fn (i, s) => ignore(storeInt(v ++ Word.fromInt i * sizeInt, s))) items; - (code, SysWord.fromInt itemCount, fromAddr v, fn () => free v) - end - - fun updateGetSelItemsParms({wp=_, lp=lp}, {items}) = - let - val v = toAddr lp - in - appi(fn (i, s) => ignore(storeInt(v ++ Word.fromInt i * sizeInt, s))) items - end - and updateGetSelItemsFromWpLp({items}, {wp=_, lp, reply}) = - let - (* The return value is the actual number of items copied *) - val nItems = SysWord.toIntX reply - val b = toAddr lp - open Memory - infix 6 ++ - fun newValue (i, old) = if i < nItems then loadInt(b ++ sizeInt * Word.fromInt i) else old - in - IntArray.modifyi newValue items - end - end - - (* Passed in the lpParam argument of a WM_NOTIFY message. - TODO: Many of these have additional information. *) - datatype Notification = - NM_OUTOFMEMORY - | NM_CLICK - | NM_DBLCLK - | NM_RETURN - | NM_RCLICK - | NM_RDBLCLK - | NM_SETFOCUS - | NM_KILLFOCUS - | NM_CUSTOMDRAW - | NM_HOVER - | NM_NCHITTEST - | NM_KEYDOWN - | NM_RELEASEDCAPTURE - | NM_SETCURSOR - | NM_CHAR - | NM_TOOLTIPSCREATED - | NM_LDOWN - | NM_RDOWN - | NM_THEMECHANGED - | LVN_ITEMCHANGING - | LVN_ITEMCHANGED - | LVN_INSERTITEM - | LVN_DELETEITEM - | LVN_DELETEALLITEMS - | LVN_BEGINLABELEDIT - | LVN_ENDLABELEDIT - | LVN_COLUMNCLICK - | LVN_BEGINDRAG - | LVN_BEGINRDRAG - | LVN_GETDISPINFO - | LVN_SETDISPINFO - | LVN_KEYDOWN - | LVN_GETINFOTIP - | HDN_ITEMCHANGING - | HDN_ITEMCHANGED - | HDN_ITEMCLICK - | HDN_ITEMDBLCLICK - | HDN_DIVIDERDBLCLICK - | HDN_BEGINTRACK - | HDN_ENDTRACK - | HDN_TRACK - | HDN_ENDDRAG - | HDN_BEGINDRAG - | HDN_GETDISPINFO - | TVN_SELCHANGING - | TVN_SELCHANGED - | TVN_GETDISPINFO - | TVN_SETDISPINFO - | TVN_ITEMEXPANDING - | TVN_ITEMEXPANDED - | TVN_BEGINDRAG - | TVN_BEGINRDRAG - | TVN_DELETEITEM - | TVN_BEGINLABELEDIT - | TVN_ENDLABELEDIT - | TVN_KEYDOWN - | TVN_GETINFOTIP - | TVN_SINGLEEXPAND - | TTN_GETDISPINFO of string ref - | TTN_SHOW - | TTN_POP - | TCN_KEYDOWN - | TCN_SELCHANGE - | TCN_SELCHANGING - | TBN_GETBUTTONINFO - | TBN_BEGINDRAG - | TBN_ENDDRAG - | TBN_BEGINADJUST - | TBN_ENDADJUST - | TBN_RESET - | TBN_QUERYINSERT - | TBN_QUERYDELETE - | TBN_TOOLBARCHANGE - | TBN_CUSTHELP - | TBN_DROPDOWN - | TBN_HOTITEMCHANGE - | TBN_DRAGOUT - | TBN_DELETINGBUTTON - | TBN_GETDISPINFO - | TBN_GETINFOTIP - | UDN_DELTAPOS - | RBN_GETOBJECT - | RBN_LAYOUTCHANGED - | RBN_AUTOSIZE - | RBN_BEGINDRAG - | RBN_ENDDRAG - | RBN_DELETINGBAND - | RBN_DELETEDBAND - | RBN_CHILDSIZE - | CBEN_GETDISPINFO - | CBEN_DRAGBEGIN - | IPN_FIELDCHANGED - | SBN_SIMPLEMODECHANGE - | PGN_SCROLL - | PGN_CALCSIZE - | NM_OTHER of int (* Catch-all for other cases. *) - - local - (* Notification structures *) - val NMHDR = cStruct3(cHWND, cUINT_PTR, cUint) - val (toMLNmhdr, fromMLNmhdr) = structAsAddr NMHDR - val CHARARRAY80 = cCHARARRAY 80 - val NMTTDISPINFO = - cStruct6(NMHDR, cPointer (* String or resource id *), CHARARRAY80, cHINSTANCE, cUint, cLPARAM); - val (toMLNMTTDISPINFO, fromMLNMTTDISPINFO) = structAsAddr NMTTDISPINFO - in - fun compileNotification (from, idFrom, NM_OUTOFMEMORY) = fromMLNmhdr(from, idFrom, ~1) - | compileNotification (from, idFrom, NM_CLICK) = fromMLNmhdr(from, idFrom, ~2) - | compileNotification (from, idFrom, NM_DBLCLK) = fromMLNmhdr(from, idFrom, ~3) - | compileNotification (from, idFrom, NM_RETURN) = fromMLNmhdr(from, idFrom, ~4) - | compileNotification (from, idFrom, NM_RCLICK) = fromMLNmhdr(from, idFrom, ~5) - | compileNotification (from, idFrom, NM_RDBLCLK) = fromMLNmhdr(from, idFrom, ~6) - | compileNotification (from, idFrom, NM_SETFOCUS) = fromMLNmhdr(from, idFrom, ~7) - | compileNotification (from, idFrom, NM_KILLFOCUS) = fromMLNmhdr(from, idFrom, ~8) - | compileNotification (from, idFrom, NM_CUSTOMDRAW) = fromMLNmhdr(from, idFrom, ~12) - | compileNotification (from, idFrom, NM_HOVER) = fromMLNmhdr(from, idFrom, ~13) - | compileNotification (from, idFrom, NM_NCHITTEST) = fromMLNmhdr(from, idFrom, ~14) - | compileNotification (from, idFrom, NM_KEYDOWN) = fromMLNmhdr(from, idFrom, ~15) - | compileNotification (from, idFrom, NM_RELEASEDCAPTURE) = fromMLNmhdr(from, idFrom, ~16) - | compileNotification (from, idFrom, NM_SETCURSOR) = fromMLNmhdr(from, idFrom, ~17) - | compileNotification (from, idFrom, NM_CHAR) = fromMLNmhdr(from, idFrom, ~18) - | compileNotification (from, idFrom, NM_TOOLTIPSCREATED) = fromMLNmhdr(from, idFrom, ~19) - | compileNotification (from, idFrom, NM_LDOWN) = fromMLNmhdr(from, idFrom, ~20) - | compileNotification (from, idFrom, NM_RDOWN) = fromMLNmhdr(from, idFrom, ~21) - | compileNotification (from, idFrom, NM_THEMECHANGED) = fromMLNmhdr(from, idFrom, ~22) - | compileNotification (from, idFrom, LVN_ITEMCHANGING) = fromMLNmhdr(from, idFrom, ~100) - | compileNotification (from, idFrom, LVN_ITEMCHANGED) = fromMLNmhdr(from, idFrom, ~101) - | compileNotification (from, idFrom, LVN_INSERTITEM) = fromMLNmhdr(from, idFrom, ~102) - | compileNotification (from, idFrom, LVN_DELETEITEM) = fromMLNmhdr(from, idFrom, ~103) - | compileNotification (from, idFrom, LVN_DELETEALLITEMS) = fromMLNmhdr(from, idFrom, ~104) - | compileNotification (from, idFrom, LVN_BEGINLABELEDIT) = fromMLNmhdr(from, idFrom, ~105) - | compileNotification (from, idFrom, LVN_ENDLABELEDIT) = fromMLNmhdr(from, idFrom, ~106) - | compileNotification (from, idFrom, LVN_COLUMNCLICK) = fromMLNmhdr(from, idFrom, ~108) - | compileNotification (from, idFrom, LVN_BEGINDRAG) = fromMLNmhdr(from, idFrom, ~109) - | compileNotification (from, idFrom, LVN_BEGINRDRAG) = fromMLNmhdr(from, idFrom, ~111) - | compileNotification (from, idFrom, LVN_GETDISPINFO) = fromMLNmhdr(from, idFrom, ~150) - | compileNotification (from, idFrom, LVN_SETDISPINFO) = fromMLNmhdr(from, idFrom, ~151) - | compileNotification (from, idFrom, LVN_KEYDOWN) = fromMLNmhdr(from, idFrom, ~155) - | compileNotification (from, idFrom, LVN_GETINFOTIP) = fromMLNmhdr(from, idFrom, ~157) - | compileNotification (from, idFrom, HDN_ITEMCHANGING) = fromMLNmhdr(from, idFrom, ~300) - | compileNotification (from, idFrom, HDN_ITEMCHANGED) = fromMLNmhdr(from, idFrom, ~301) - | compileNotification (from, idFrom, HDN_ITEMCLICK) = fromMLNmhdr(from, idFrom, ~302) - | compileNotification (from, idFrom, HDN_ITEMDBLCLICK) = fromMLNmhdr(from, idFrom, ~303) - | compileNotification (from, idFrom, HDN_DIVIDERDBLCLICK) = fromMLNmhdr(from, idFrom, ~305) - | compileNotification (from, idFrom, HDN_BEGINTRACK) = fromMLNmhdr(from, idFrom, ~306) - | compileNotification (from, idFrom, HDN_ENDTRACK) = fromMLNmhdr(from, idFrom, ~307) - | compileNotification (from, idFrom, HDN_TRACK) = fromMLNmhdr(from, idFrom, ~308) - | compileNotification (from, idFrom, HDN_ENDDRAG) = fromMLNmhdr(from, idFrom, ~311) - | compileNotification (from, idFrom, HDN_BEGINDRAG) = fromMLNmhdr(from, idFrom, ~310) - | compileNotification (from, idFrom, HDN_GETDISPINFO) = fromMLNmhdr(from, idFrom, ~309) - | compileNotification (from, idFrom, TVN_SELCHANGING) = fromMLNmhdr(from, idFrom, ~401) - | compileNotification (from, idFrom, TVN_SELCHANGED) = fromMLNmhdr(from, idFrom, ~402) - | compileNotification (from, idFrom, TVN_GETDISPINFO) = fromMLNmhdr(from, idFrom, ~403) - | compileNotification (from, idFrom, TVN_SETDISPINFO) = fromMLNmhdr(from, idFrom, ~404) - | compileNotification (from, idFrom, TVN_ITEMEXPANDING) = fromMLNmhdr(from, idFrom, ~405) - | compileNotification (from, idFrom, TVN_ITEMEXPANDED) = fromMLNmhdr(from, idFrom, ~406) - | compileNotification (from, idFrom, TVN_BEGINDRAG) = fromMLNmhdr(from, idFrom, ~407) - | compileNotification (from, idFrom, TVN_BEGINRDRAG) = fromMLNmhdr(from, idFrom, ~408) - | compileNotification (from, idFrom, TVN_DELETEITEM) = fromMLNmhdr(from, idFrom, ~409) - | compileNotification (from, idFrom, TVN_BEGINLABELEDIT) = fromMLNmhdr(from, idFrom, ~410) - | compileNotification (from, idFrom, TVN_ENDLABELEDIT) = fromMLNmhdr(from, idFrom, ~411) - | compileNotification (from, idFrom, TVN_KEYDOWN) = fromMLNmhdr(from, idFrom, ~412) - | compileNotification (from, idFrom, TVN_GETINFOTIP) = fromMLNmhdr(from, idFrom, ~413) - | compileNotification (from, idFrom, TVN_SINGLEEXPAND) = fromMLNmhdr(from, idFrom, ~415) - | compileNotification (from, idFrom, TTN_GETDISPINFO(ref s)) = - fromMLNMTTDISPINFO((from, idFrom, ~520), Memory.null, s, Globals.hNull, 0, 0) - | compileNotification (from, idFrom, TTN_SHOW) = fromMLNmhdr(from, idFrom, ~521) - | compileNotification (from, idFrom, TTN_POP) = fromMLNmhdr(from, idFrom, ~522) - | compileNotification (from, idFrom, TCN_KEYDOWN) = fromMLNmhdr(from, idFrom, ~550) - | compileNotification (from, idFrom, TCN_SELCHANGE) = fromMLNmhdr(from, idFrom, ~551) - | compileNotification (from, idFrom, TCN_SELCHANGING) = fromMLNmhdr(from, idFrom, ~552) - | compileNotification (from, idFrom, TBN_GETBUTTONINFO) = fromMLNmhdr(from, idFrom, ~700) - | compileNotification (from, idFrom, TBN_BEGINDRAG) = fromMLNmhdr(from, idFrom, ~701) - | compileNotification (from, idFrom, TBN_ENDDRAG) = fromMLNmhdr(from, idFrom, ~702) - | compileNotification (from, idFrom, TBN_BEGINADJUST) = fromMLNmhdr(from, idFrom, ~703) - | compileNotification (from, idFrom, TBN_ENDADJUST) = fromMLNmhdr(from, idFrom, ~704) - | compileNotification (from, idFrom, TBN_RESET) = fromMLNmhdr(from, idFrom, ~705) - | compileNotification (from, idFrom, TBN_QUERYINSERT) = fromMLNmhdr(from, idFrom, ~706) - | compileNotification (from, idFrom, TBN_QUERYDELETE) = fromMLNmhdr(from, idFrom, ~707) - | compileNotification (from, idFrom, TBN_TOOLBARCHANGE) = fromMLNmhdr(from, idFrom, ~708) - | compileNotification (from, idFrom, TBN_CUSTHELP) = fromMLNmhdr(from, idFrom, ~709) - | compileNotification (from, idFrom, TBN_DROPDOWN) = fromMLNmhdr(from, idFrom, ~710) - | compileNotification (from, idFrom, TBN_HOTITEMCHANGE) = fromMLNmhdr(from, idFrom, ~713) - | compileNotification (from, idFrom, TBN_DRAGOUT) = fromMLNmhdr(from, idFrom, ~714) - | compileNotification (from, idFrom, TBN_DELETINGBUTTON) = fromMLNmhdr(from, idFrom, ~715) - | compileNotification (from, idFrom, TBN_GETDISPINFO) = fromMLNmhdr(from, idFrom, ~716) - | compileNotification (from, idFrom, TBN_GETINFOTIP) = fromMLNmhdr(from, idFrom, ~718) - | compileNotification (from, idFrom, UDN_DELTAPOS) = fromMLNmhdr(from, idFrom, ~722) - | compileNotification (from, idFrom, RBN_GETOBJECT) = fromMLNmhdr(from, idFrom, ~832) - | compileNotification (from, idFrom, RBN_LAYOUTCHANGED) = fromMLNmhdr(from, idFrom, ~833) - | compileNotification (from, idFrom, RBN_AUTOSIZE) = fromMLNmhdr(from, idFrom, ~834) - | compileNotification (from, idFrom, RBN_BEGINDRAG) = fromMLNmhdr(from, idFrom, ~835) - | compileNotification (from, idFrom, RBN_ENDDRAG) = fromMLNmhdr(from, idFrom, ~836) - | compileNotification (from, idFrom, RBN_DELETINGBAND) = fromMLNmhdr(from, idFrom, ~837) - | compileNotification (from, idFrom, RBN_DELETEDBAND) = fromMLNmhdr(from, idFrom, ~838) - | compileNotification (from, idFrom, RBN_CHILDSIZE) = fromMLNmhdr(from, idFrom, ~839) - | compileNotification (from, idFrom, CBEN_GETDISPINFO) = fromMLNmhdr(from, idFrom, ~800) - | compileNotification (from, idFrom, CBEN_DRAGBEGIN) = fromMLNmhdr(from, idFrom, ~808) - | compileNotification (from, idFrom, IPN_FIELDCHANGED) = fromMLNmhdr(from, idFrom, ~860) - | compileNotification (from, idFrom, SBN_SIMPLEMODECHANGE) = fromMLNmhdr(from, idFrom, ~880) - | compileNotification (from, idFrom, PGN_SCROLL) = fromMLNmhdr(from, idFrom, ~901) - | compileNotification (from, idFrom, PGN_CALCSIZE) = fromMLNmhdr(from, idFrom, ~902) - - | compileNotification (from, idFrom, NM_OTHER code) = fromMLNmhdr(from, idFrom, code) - - local - fun decompileNotifyArg (_, ~1) = NM_OUTOFMEMORY - | decompileNotifyArg (_, ~2) = NM_CLICK - | decompileNotifyArg (_, ~3) = NM_DBLCLK - | decompileNotifyArg (_, ~4) = NM_RETURN - | decompileNotifyArg (_, ~5) = NM_RCLICK - | decompileNotifyArg (_, ~6) = NM_RDBLCLK - | decompileNotifyArg (_, ~7) = NM_SETFOCUS - | decompileNotifyArg (_, ~8) = NM_KILLFOCUS - | decompileNotifyArg (_, ~12) = NM_CUSTOMDRAW - | decompileNotifyArg (_, ~13) = NM_HOVER - | decompileNotifyArg (_, ~14) = NM_NCHITTEST - | decompileNotifyArg (_, ~15) = NM_KEYDOWN - | decompileNotifyArg (_, ~16) = NM_RELEASEDCAPTURE - | decompileNotifyArg (_, ~17) = NM_SETCURSOR - | decompileNotifyArg (_, ~18) = NM_CHAR - | decompileNotifyArg (_, ~19) = NM_TOOLTIPSCREATED - | decompileNotifyArg (_, ~20) = NM_LDOWN - | decompileNotifyArg (_, ~21) = NM_RDOWN - | decompileNotifyArg (_, ~22) = NM_THEMECHANGED - | decompileNotifyArg (_, ~100) = LVN_ITEMCHANGING - | decompileNotifyArg (_, ~101) = LVN_ITEMCHANGED - | decompileNotifyArg (_, ~102) = LVN_INSERTITEM - | decompileNotifyArg (_, ~103) = LVN_DELETEITEM - | decompileNotifyArg (_, ~104) = LVN_DELETEALLITEMS - | decompileNotifyArg (_, ~105) = LVN_BEGINLABELEDIT - | decompileNotifyArg (_, ~106) = LVN_ENDLABELEDIT - | decompileNotifyArg (_, ~108) = LVN_COLUMNCLICK - | decompileNotifyArg (_, ~109) = LVN_BEGINDRAG - | decompileNotifyArg (_, ~111) = LVN_BEGINRDRAG - | decompileNotifyArg (_, ~150) = LVN_GETDISPINFO - | decompileNotifyArg (_, ~151) = LVN_SETDISPINFO - | decompileNotifyArg (_, ~155) = LVN_KEYDOWN - | decompileNotifyArg (_, ~157) = LVN_GETINFOTIP - | decompileNotifyArg (_, ~300) = HDN_ITEMCHANGING - | decompileNotifyArg (_, ~301) = HDN_ITEMCHANGED - | decompileNotifyArg (_, ~302) = HDN_ITEMCLICK - | decompileNotifyArg (_, ~303) = HDN_ITEMDBLCLICK - | decompileNotifyArg (_, ~305) = HDN_DIVIDERDBLCLICK - | decompileNotifyArg (_, ~306) = HDN_BEGINTRACK - | decompileNotifyArg (_, ~307) = HDN_ENDTRACK - | decompileNotifyArg (_, ~308) = HDN_TRACK - | decompileNotifyArg (_, ~311) = HDN_ENDDRAG - | decompileNotifyArg (_, ~310) = HDN_BEGINDRAG - | decompileNotifyArg (_, ~309) = HDN_GETDISPINFO - | decompileNotifyArg (_, ~401) = TVN_SELCHANGING - | decompileNotifyArg (_, ~402) = TVN_SELCHANGED - | decompileNotifyArg (_, ~403) = TVN_GETDISPINFO - | decompileNotifyArg (_, ~404) = TVN_SETDISPINFO - | decompileNotifyArg (_, ~405) = TVN_ITEMEXPANDING - | decompileNotifyArg (_, ~406) = TVN_ITEMEXPANDED - | decompileNotifyArg (_, ~407) = TVN_BEGINDRAG - | decompileNotifyArg (_, ~408) = TVN_BEGINRDRAG - | decompileNotifyArg (_, ~409) = TVN_DELETEITEM - | decompileNotifyArg (_, ~410) = TVN_BEGINLABELEDIT - | decompileNotifyArg (_, ~411) = TVN_ENDLABELEDIT - | decompileNotifyArg (_, ~412) = TVN_KEYDOWN - | decompileNotifyArg (_, ~413) = TVN_GETINFOTIP - | decompileNotifyArg (_, ~415) = TVN_SINGLEEXPAND - | decompileNotifyArg (lp, ~520) = - let - val nmt = toMLNMTTDISPINFO lp - (* Just look at the byte data at the moment. *) - in - TTN_GETDISPINFO(ref(#3 nmt)) - end - | decompileNotifyArg (_, ~521) = TTN_SHOW - | decompileNotifyArg (_, ~522) = TTN_POP - | decompileNotifyArg (_, ~550) = TCN_KEYDOWN - | decompileNotifyArg (_, ~551) = TCN_SELCHANGE - | decompileNotifyArg (_, ~552) = TCN_SELCHANGING - | decompileNotifyArg (_, ~700) = TBN_GETBUTTONINFO - | decompileNotifyArg (_, ~701) = TBN_BEGINDRAG - | decompileNotifyArg (_, ~702) = TBN_ENDDRAG - | decompileNotifyArg (_, ~703) = TBN_BEGINADJUST - | decompileNotifyArg (_, ~704) = TBN_ENDADJUST - | decompileNotifyArg (_, ~705) = TBN_RESET - | decompileNotifyArg (_, ~706) = TBN_QUERYINSERT - | decompileNotifyArg (_, ~707) = TBN_QUERYDELETE - | decompileNotifyArg (_, ~708) = TBN_TOOLBARCHANGE - | decompileNotifyArg (_, ~709) = TBN_CUSTHELP - | decompileNotifyArg (_, ~710) = TBN_DROPDOWN - | decompileNotifyArg (_, ~713) = TBN_HOTITEMCHANGE - | decompileNotifyArg (_, ~714) = TBN_DRAGOUT - | decompileNotifyArg (_, ~715) = TBN_DELETINGBUTTON - | decompileNotifyArg (_, ~716) = TBN_GETDISPINFO - | decompileNotifyArg (_, ~718) = TBN_GETINFOTIP (*<<<*) - | decompileNotifyArg (_, ~722) = UDN_DELTAPOS - | decompileNotifyArg (_, ~832) = RBN_GETOBJECT - | decompileNotifyArg (_, ~833) = RBN_LAYOUTCHANGED - | decompileNotifyArg (_, ~834) = RBN_AUTOSIZE - | decompileNotifyArg (_, ~835) = RBN_BEGINDRAG - | decompileNotifyArg (_, ~836) = RBN_ENDDRAG - | decompileNotifyArg (_, ~837) = RBN_DELETINGBAND - | decompileNotifyArg (_, ~838) = RBN_DELETEDBAND - | decompileNotifyArg (_, ~839) = RBN_CHILDSIZE - | decompileNotifyArg (_, ~800) = CBEN_GETDISPINFO - | decompileNotifyArg (_, ~808) = CBEN_DRAGBEGIN - | decompileNotifyArg (_, ~860) = IPN_FIELDCHANGED - | decompileNotifyArg (_, ~880) = SBN_SIMPLEMODECHANGE - | decompileNotifyArg (_, ~901) = PGN_SCROLL - | decompileNotifyArg (_, ~902) = PGN_CALCSIZE - | decompileNotifyArg (_, code) = NM_OTHER code - in - fun decompileNotify {wp, lp} = - let - val (hwndFrom, idFrom, code) = toMLNmhdr lp - val notification = decompileNotifyArg (lp, code) - in - { idCtrl = SysWord.toInt wp, from = hwndFrom, idFrom = idFrom, notification = notification} - end - end - - end - - local - val cFINDREPLACE = - cStruct11(cDWORD, cHWND, cHINSTANCE, FindReplaceFlags.cFindReplaceFlags, cString, cString, - cWORD, cWORD, cPointer, cPointer, cPointer) - val {load=loadFindReplace, store=storeFindReplace, ctype={size=sizeFindReplace, ...}, ...} = - breakConversion cFINDREPLACE - type findMsg = { flags: FindReplaceFlags.flags, findWhat: string, replaceWith: string } - in - fun compileFindMsg({flags, findWhat, replaceWith}: findMsg) = - let - open Memory - val vec = malloc sizeFindReplace - (* Is this right? It's supposed to create a buffer to store the result. *) - val freeFR = - storeFindReplace(vec, - (Word.toInt sizeFindReplace, hNull, hNull, flags, - findWhat, replaceWith, 0, 0, null, null, null)) - in - (RegisterMessage "commdlg_FindReplace", 0w0, fromAddr vec, fn() => (freeFR(); free vec)) - end - - fun decompileFindMsg{wp=_, lp}: findMsg = - let - val (_, _, _, flags, findwhat, replace, _, _, _, _, _) = - loadFindReplace(toAddr lp) - (* The argument is really a FINDREPLACE struct. *) - in - {flags=flags, findWhat=findwhat, replaceWith=replace} - end - end - - val toHMENU: SysWord.word -> HMENU = handleOfVoidStar o Memory.sysWord2VoidStar - and fromHMENU: HMENU -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle - val toHWND: SysWord.word -> HWND = handleOfVoidStar o Memory.sysWord2VoidStar - and fromHWND: HWND -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle - val toHDC: SysWord.word -> HDC = handleOfVoidStar o Memory.sysWord2VoidStar - and fromHDC: HDC -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle - val toHFONT: SysWord.word -> HFONT = handleOfVoidStar o Memory.sysWord2VoidStar - and fromHFONT: HFONT -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle - val toHRGN: SysWord.word -> HRGN = handleOfVoidStar o Memory.sysWord2VoidStar - and fromHRGN: HRGN -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle - val toHDROP: SysWord.word -> HDROP = handleOfVoidStar o Memory.sysWord2VoidStar - and fromHDROP: HDROP -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle - val toHICON: SysWord.word -> HICON = handleOfVoidStar o Memory.sysWord2VoidStar - and fromHICON: HICON -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle - val toHGDIOBJ: SysWord.word -> HGDIOBJ = handleOfVoidStar o Memory.sysWord2VoidStar - and fromHGDIOBJ: HGDIOBJ -> SysWord.word = Memory.voidStar2Sysword o voidStarOfHandle - - (* Maybe we should have two different types for horizontal and vertical. *) - datatype ScrollDirection = - SB_BOTTOM | SB_ENDSCROLL | SB_LINEDOWN | SB_LINEUP | SB_PAGEDOWN | SB_PAGEUP | - SB_THUMBPOSITION | SB_THUMBTRACK | SB_TOP | SB_LEFT | SB_RIGHT | SB_LINELEFT | - SB_LINERIGHT | SB_PAGELEFT | SB_PAGERIGHT - local - val tab = [ - (SB_LINEUP, 0w0: word), - (SB_LINELEFT, 0w0), - (SB_LINEDOWN, 0w1), - (SB_LINERIGHT, 0w1), - (SB_PAGEUP, 0w2), - (SB_PAGELEFT, 0w2), - (SB_PAGEDOWN, 0w3), - (SB_PAGERIGHT, 0w3), - (SB_THUMBPOSITION, 0w4), - (SB_THUMBTRACK, 0w5), - (SB_TOP, 0w6), - (SB_LEFT, 0w6), - (SB_BOTTOM, 0w7), - (SB_RIGHT, 0w7), - (SB_ENDSCROLL, 0w8) - ] - in - val (toCsd, fromCsd) = tableLookup(tab, NONE) - end - - (* This is a bit of a mess. Various operations take or return handles to - these types of image and also take this value as a parameter. *) - datatype ImageType = IMAGE_BITMAP | IMAGE_CURSOR | IMAGE_ENHMETAFILE | IMAGE_ICON - - local - val tab = [ - (IMAGE_BITMAP, 0), - (IMAGE_ICON, 1), - (IMAGE_CURSOR, 2), - (IMAGE_ENHMETAFILE, 3) - ] - in - val (toCit, fromCit) = tableLookup(tab, NONE) - end - - val (toCcbf, fromCcbf) = clipLookup - datatype MouseKeyFlags = MK_LBUTTON | MK_RBUTTON | MK_SHIFT | MK_CONTROL | MK_MBUTTON - - local - val tab = [ - (MK_LBUTTON, 0wx0001), - (MK_RBUTTON, 0wx0002), - (MK_SHIFT, 0wx0004), - (MK_CONTROL, 0wx0008), - (MK_MBUTTON, 0wx0010) - ] - in - val (toCmkf, fromCmkf) = tableSetLookup(tab, NONE) - end - - - datatype MDITileFlags = MDITILE_VERTICAL | MDITILE_HORIZONTAL | MDITILE_SKIPDISABLED - - local - val tab = [ - (MDITILE_VERTICAL, 0wx0000), - (MDITILE_HORIZONTAL, 0wx0001), - (MDITILE_SKIPDISABLED, 0wx0002) - ] - in - val (toCmdif, fromCmdif) = tableSetLookup(tab, NONE) - end - - datatype WMPrintOption = - PRF_CHECKVISIBLE | PRF_NONCLIENT | PRF_CLIENT | PRF_ERASEBKGND | - PRF_CHILDREN | PRF_OWNED - - local - val tab = [ - (PRF_CHECKVISIBLE, 0wx00000001), - (PRF_NONCLIENT, 0wx00000002), - (PRF_CLIENT, 0wx00000004), - (PRF_ERASEBKGND, 0wx00000008), - (PRF_CHILDREN, 0wx00000010), - (PRF_OWNED, 0wx00000020) - ] - in - val (toCwmpl, fromCwmpl) = tableSetLookup(tab, NONE) - end - - val (toCcbal, fromCcbal) = ComboBase.CBDIRATTRS - val (toCesbf, fromCesbf) = ScrollBase.ENABLESCROLLBARFLAG - - (*fun itob i = i <> 0*) - - (* These deal with signed quantities. LOWORD/HIWORD deal with words *) - local - val shift32 = Word.fromInt(SysWord.wordSize-32) - and shift16 = Word.fromInt(SysWord.wordSize-16) - open SysWord - infix 5 << ~>> - infix 7 andb - infix 6 orb - (* Y is the high order word, X is the low order word. *) - in - fun getYLParam (i: SysWord.word) = toIntX((i << shift32) ~>> shift16) - and getXLParam (i: SysWord.word) = toIntX((i << shift16) ~>> shift16) - - fun makeXYParam (x, y) = ((fromInt y andb 0wxffff) << 0w16) orb (fromInt x andb 0wxffff) - end - in - type flags = WinBase.Style.flags - and WindowPositionStyle = WinBase.WindowPositionStyle - - datatype ControlType = datatype ControlType - datatype ScrollDirection = datatype ScrollDirection - - datatype HitTest = - HTBORDER - | HTBOTTOM - | HTBOTTOMLEFT - | HTBOTTOMRIGHT - | HTCAPTION - | HTCLIENT - | HTCLOSE - | HTERROR - | HTGROWBOX - | HTHELP - | HTHSCROLL - | HTLEFT - | HTMENU - | HTMAXBUTTON - | HTMINBUTTON - | HTNOWHERE - | HTREDUCE - | HTRIGHT - | HTSIZE - | HTSYSMENU - | HTTOP - | HTTOPLEFT - | HTTOPRIGHT - | HTTRANSPARENT - | HTVSCROLL - | HTZOOM - - datatype LRESULT = - LRESINT of int - | LRESHANDLE of HGDIOBJ - - datatype ImageType = datatype ImageType - - (* WM_SIZE options. *) - datatype WMSizeOptions = - SIZE_RESTORED | SIZE_MINIMIZED | SIZE_MAXIMIZED | SIZE_MAXSHOW | SIZE_MAXHIDE - local - val tab = [ - (SIZE_RESTORED, 0w0: SysWord.word), - (SIZE_MINIMIZED, 0w1), - (SIZE_MAXIMIZED, 0w2), - (SIZE_MAXSHOW, 0w3), - (SIZE_MAXHIDE, 0w4) - ] - in - val (fromWMSizeOpt, toWMSizeOpt) = tableLookup(tab, NONE) - end - - (* WM_ACTIVATE options *) - datatype WMActivateOptions = WA_INACTIVE | WA_ACTIVE | WA_CLICKACTIVE - local - val - tab = [ - (WA_INACTIVE, 0w0: word), - (WA_ACTIVE, 0w1), - (WA_CLICKACTIVE, 0w2) - ] - in - val (fromWMactive, toWMactive) = tableLookup(tab, NONE) - end - - datatype SystemCommand = - SC_SIZE | SC_MOVE | SC_MINIMIZE | SC_MAXIMIZE | SC_NEXTWINDOW | SC_PREVWINDOW | - SC_CLOSE | SC_VSCROLL | SC_HSCROLL | SC_MOUSEMENU | SC_KEYMENU | SC_ARRANGE | - SC_RESTORE | SC_TASKLIST | SC_SCREENSAVE | SC_HOTKEY | SC_DEFAULT | - SC_MONITORPOWER | SC_CONTEXTHELP | SC_SEPARATOR - local - val tab = [ - (SC_SIZE, 0xF000), - (SC_MOVE, 0xF010), - (SC_MINIMIZE, 0xF020), - (SC_MAXIMIZE, 0xF030), - (SC_NEXTWINDOW, 0xF040), - (SC_PREVWINDOW, 0xF050), - (SC_CLOSE, 0xF060), - (SC_VSCROLL, 0xF070), - (SC_HSCROLL, 0xF080), - (SC_MOUSEMENU, 0xF090), - (SC_KEYMENU, 0xF100), - (SC_ARRANGE, 0xF110), - (SC_RESTORE, 0xF120), - (SC_TASKLIST, 0xF130), - (SC_SCREENSAVE, 0xF140), - (SC_HOTKEY, 0xF150), - (SC_DEFAULT, 0xF160), - (SC_MONITORPOWER, 0xF170), - (SC_CONTEXTHELP, 0xF180)] - in - val (fromSysCommand, toSysCommand) = tableLookup(tab, NONE) - end - - datatype EMCharFromPos = - EMcfpEdit of POINT - | EMcfpRichEdit of POINT - | EMcfpUnknown of SysWord.word - - datatype WMPrintOption = datatype WMPrintOption - - (* Parameters to EM_SETMARGINS. *) - datatype MarginSettings = - UseFontInfo | Margins of {left: int option, right: int option } - - datatype MouseKeyFlags = datatype MouseKeyFlags - datatype MDITileFlags = datatype MDITileFlags - - (* TODO: Perhaps use a record for this. It's always possible to use - functions from Word32 though. *) - type KeyData = Word32.word - datatype Notification = datatype Notification - datatype HelpHandle = datatype HelpHandle - - local - val tab = - [ - (HTBORDER, 18), - (HTBOTTOM, 15), - (HTBOTTOMLEFT, 16), - (HTBOTTOMRIGHT, 17), - (HTCAPTION, 2), - (HTCLIENT, 1), - (HTCLOSE, 20), - (HTERROR, ~2), - (HTGROWBOX, 4), - (HTHELP, 21), - (HTHSCROLL, 6), - (HTLEFT, 10), - (HTMENU, 5), - (HTMAXBUTTON, 9), - (HTMINBUTTON, 8), - (HTNOWHERE, 0), - (HTREDUCE, 8), - (HTRIGHT, 11), - (HTSIZE, 4), - (HTSYSMENU, 3), - (HTTOP, 12), - (HTTOPLEFT, 13), - (HTTOPRIGHT, 14), - (HTTRANSPARENT, ~1), - (HTVSCROLL, 7), - (HTZOOM, 9) - ] - in - val (fromHitTest, toHitTest) = - tableLookup(tab, SOME(fn _ => HTERROR, fn _ => ~2)) - (* Include default just in case a new value is added some time *) - end - - - type findReplaceFlags = FindReplaceFlags.flags - type windowFlags = flags - - datatype Message = - WM_NULL - - | WM_ACTIVATE of {active: WMActivateOptions, minimize: bool } - (* Indicates a change in activation state *) - - | WM_ACTIVATEAPP of {active: bool, threadid: int } - (* Notifies applications when a new task activates *) - - | WM_ASKCBFORMATNAME of { length: int, formatName: string ref} - (* Retrieves the name of the clipboard format *) - - | WM_CANCELJOURNAL - (* Notifies application when user cancels journaling *) - - | WM_CANCELMODE - (* Notifies a Window to cancel internal modes *) - - | WM_CHANGECBCHAIN of { removed: HWND, next: HWND } - (* Notifies clipboard viewer of removal from chain *) - - | WM_CHAR of {charCode: char, data: KeyData } - (* Indicates the user pressed a character key *) - - | WM_CHARTOITEM of {key: int, caretpos: int, listbox: HWND } - (* Provides list-box keystrokes to owner Window *) - - | WM_CHILDACTIVATE - (* Notifies a child Window of activation *) - - (* This is WM_USER+1. It's only used in a GetFont dialogue box. - | WM_CHOOSEFONT_GETLOGFONT of LOGFONT ref *) - (* Retrieves LOGFONT structure for Font dialog box *) - - | WM_CLEAR - (* Clears an edit control *) - - | WM_CLOSE - (* System Close menu command was chosen *) - - | WM_COMMAND of {notifyCode: int, wId: int, control: HWND } - (* Specifies a command message *) - - | WM_COMPAREITEM of (* Determines position of combo- or list-box item *) - { - controlid: int, ctlType: ControlType, ctlID: int, hItem: HWND, - itemID1: int, itemData1: SysWord.word, itemID2: int, itemData2: SysWord.word - } - - | WM_COPY (* Copies a selection to the clipboard *) - - | WM_CREATE of - { instance: HINSTANCE, creation: Foreign.Memory.voidStar, menu: HMENU, parent: HWND, cy: int, cx: int, - y: int, x: int, style: windowFlags, name: string, (* The class may be a string or an atom. *) - class: ClassType, extendedstyle: int } - (* Indicates a Window is being created *) - - | WM_CTLCOLORBTN of { displaycontext: HDC, button: HWND } - (* Button is about to be drawn *) - - | WM_CTLCOLORDLG of { displaycontext: HDC, dialogbox: HWND } - (* Dialog box is about to be drawn *) - - | WM_CTLCOLOREDIT of { displaycontext: HDC, editcontrol: HWND } - (* Control is about to be drawn *) - - | WM_CTLCOLORLISTBOX of { displaycontext: HDC, listbox: HWND } - (* List box is about to be drawn *) - - | WM_CTLCOLORMSGBOX of { displaycontext: HDC, messagebox: HWND } - (* Message box is about to be drawn *) - - | WM_CTLCOLORSCROLLBAR of { displaycontext: HDC, scrollbar: HWND } - (* Indicates scroll bar is about to be drawn *) - - | WM_CTLCOLORSTATIC of { displaycontext: HDC, staticcontrol: HWND } - (* Control is about to be drawn *) - (* Note the return value is an HBRUSH *) - - | WM_CUT - (* Deletes a selection and copies it to the clipboard *) - - | WM_DEADCHAR of { charCode: char, data: KeyData } - (* Indicates the user pressed a dead key *) - - | WM_DELETEITEM of { senderId: int, ctlType: ControlType, ctlID: int, itemID: int, item: HWND, itemData: int } - (* Indicates owner-draw item or control was altered *) - - | WM_DESTROY - (* Indicates Window is about to be destroyed *) - - | WM_DESTROYCLIPBOARD - (* Notifies owner that the clipboard was emptied *) - - | WM_DEVMODECHANGE of { devicename: string } - (* Indicates the device-mode settings have changed *) - - | WM_DRAWCLIPBOARD - (* Indicates the clipboard's contents have changed *) - - | WM_DRAWITEM of - { senderId: int, ctlType: ControlType, ctlID: int, itemID: int, itemAction: int, - itemState: int, hItem: HWND , hDC: HDC, rcItem: RECT, itemData: int } - (* Indicates owner-draw control/menu needs redrawing *) - - | WM_DROPFILES of { hDrop: HDROP } - (* Indicates that a file has been dropped *) - - | WM_ENABLE of { enabled: bool } - (* Indicates a Window's enable state is changing *) - - | WM_ENDSESSION of { endsession: bool } - (* Indicates whether the Windows session is ending *) - - | WM_ENTERIDLE of { flag: int, window: HWND } - (* Indicates a modal dialog box or menu is idle *) - - | WM_ENTERMENULOOP of { istrack: bool } - (* Indicates entry into menu modal loop *) - - | WM_EXITMENULOOP of { istrack: bool } - (* Indicates exit from menu modal loop *) - - | WM_ERASEBKGND of { devicecontext: HDC } - (* Indicates a Window's background need erasing *) - - | WM_FONTCHANGE - (* Indicates a change in the font-resource pool *) - - | WM_GETDLGCODE - (* Allows dialog procedure to process control input - TODO: This has parameters! *) - - | WM_GETFONT - (* Retrieves the font that a control is using *) - - | WM_GETHOTKEY - (* Gets the virtual-key code of a Window's hot key *) - - | WM_GETMINMAXINFO of - { maxSize: POINT ref, maxPosition: POINT ref, - minTrackSize: POINT ref, maxTrackSize: POINT ref } - (* Gets minimum and maximum sizing information *) - - | WM_GETTEXT of { length: int, text: string ref } - (* Gets the text that corresponds to a Window *) - - | WM_GETTEXTLENGTH - (* Gets length of text associated with a Window *) - - | WM_HOTKEY of { id: int } - (* Hot key has been detected *) - - | WM_HSCROLL of { value: ScrollDirection, position: int, scrollbar: HWND } - (* Indicates a click in a horizontal scroll bar *) - - | WM_HSCROLLCLIPBOARD of { viewer: HWND, code: int, position: int } - (* Prompts owner to scroll clipboard contents *) - - | WM_ICONERASEBKGND of { devicecontext: HDC } - (* Notifies minimized Window to fill icon background *) - - | WM_INITDIALOG of { dialog: HWND, initdata: int } - (* Initializes a dialog box *) - - | WM_INITMENU of { menu: HMENU } - (* Indicates a menu is about to become active *) - - | WM_INITMENUPOPUP of { menupopup: HMENU, itemposition: int, isSystemMenu: bool } - (* Indicates a pop-up menu is being created *) - - | WM_KEYDOWN of { virtualKey: int, data: KeyData } - (* Indicates a nonsystem key was pressed *) - - | WM_KEYUP of { virtualKey: int, data: KeyData } - (* Indicates a nonsystem key was released *) - - | WM_KILLFOCUS of { receivefocus: HWND } - (* Indicates the Window is losing keyboard focus *) - - | WM_LBUTTONDBLCLK of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates double-click of left button *) - - | WM_LBUTTONDOWN of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates when left mouse button is pressed *) - - | WM_LBUTTONUP of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates when left mouse button is released *) - - | WM_MBUTTONDBLCLK of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates double-click of middle mouse button *) - - | WM_MBUTTONDOWN of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates when middle mouse button is pressed *) - - | WM_MBUTTONUP of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates when middle mouse button is released *) - - | WM_MDICASCADE of { skipDisabled: bool } - (* Arranges MDI child Windows in cascade format *) - - | WM_MDICREATE of - { class: ClassType, title: string, instance: HINSTANCE, x: int, y: int, - cx: int, cy: int, style: int, cdata: int } - (* Prompts MDI client to create a child Window *) - - | WM_MDIDESTROY of { child: HWND } - (* Closes an MDI child Window *) - - | WM_MDIGETACTIVE - (* Retrieves data about the active MDI child Window *) - - | WM_MDIICONARRANGE - (* Arranges minimized MDI child Windows *) - - | WM_MDIMAXIMIZE of { child: HWND } - (* Maximizes an MDI child Window *) - - | WM_MDINEXT of { child: HWND, flagnext: bool } - (* Activates the next MDI child Window *) - - | WM_MDIREFRESHMENU - (* Refreshes an MDI frame Window's menu *) - - | WM_MDIRESTORE of { child: HWND } - (* Prompts MDI client to restore a child Window *) - - | WM_MDISETMENU of { frameMenu: HMENU, windowMenu: HMENU } - (* Replaces an MDI frame Window's menu *) - - | WM_MDITILE of { tilingflag: MDITileFlags list } - (* Arranges MDI child Windows in tiled format *) - - | WM_MEASUREITEM of - { senderId: int, ctlType: ControlType, ctlID: int, itemID: int, itemWidth: int ref, itemHeight: int ref, itemData: int } - (* Requests dimensions of owner-draw control or item *) - - | WM_MENUCHAR of { ch: char, menuflag: MenuBase.MenuFlag, menu: HMENU } - (* Indicates an unknown menu mnemonic was pressed *) - - | WM_MENUSELECT of { menuitem: int, menuflags: MenuBase.MenuFlag list, menu: HMENU } - (* Indicates that the user selected a menu item *) - - | WM_MOUSEACTIVATE of { parent: HWND, hitTest: HitTest, message: int } - (* Indicates a mouse click in an inactive Window *) - - | WM_MOUSEMOVE of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates mouse-cursor movement *) - - | WM_MOUSEHOVER of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates the mouse hovering in the client area *) - - | WM_MOUSELEAVE - (* Indicates the mouse leaving the client area *) - - | WM_MOVE of { x: int, y: int } - (* Indicates a Window's position has changed *) - - | WM_NCACTIVATE of { active: bool } - (* Changes the active state of nonclient area *) - - | WM_NCCALCSIZE of - { validarea: bool, newrect: RECT ref, oldrect: RECT, oldclientarea: RECT, - hwnd: HWND, insertAfter: HWND, x: int, y: int, cx: int, cy: int, style: WindowPositionStyle list} - (* Calculates the size of a Window's client area *) - - | WM_NCCREATE of - { instance: HINSTANCE, creation: Foreign.Memory.voidStar, menu: HMENU, parent: HWND, cy: int, cx: int, - y: int, x: int, style: windowFlags, name: string, class: ClassType, extendedstyle: int } - (* Indicates a Window's nonclient area being created *) - - | WM_NCDESTROY - (* Indicates Window's nonclient area being destroyed *) - - | WM_NCHITTEST of { x: int, y: int } - (* Indicates mouse-cursor movement *) - - | WM_NCLBUTTONDBLCLK of { hitTest: HitTest, x: int, y: int } - (* Indicates nonclient left button double-click *) - - | WM_NCLBUTTONDOWN of { hitTest: HitTest, x: int, y: int } - (* Indicates left button pressed in nonclient area *) - - | WM_NCLBUTTONUP of { hitTest: HitTest, x: int, y: int } - (* Indicates left button released in nonclient area *) - - | WM_NCMBUTTONDBLCLK of { hitTest: HitTest, x: int, y: int } - (* Indicates nonclient middle button double-click *) - - | WM_NCMBUTTONDOWN of { hitTest: HitTest, x: int, y: int } - (* Indicates middle button pressed in nonclient area *) - - | WM_NCMBUTTONUP of { hitTest: HitTest, x: int, y: int } - (* Indicates middle button released in nonclient area *) - - | WM_NCMOUSEMOVE of { hitTest: HitTest, x: int, y: int } - (* Indicates mouse-cursor movement in nonclient area *) - - | WM_NCMOUSEHOVER of { hitTest: HitTest, x: int, y: int } - (* Indicates the mouse hovering in the nonclient area *) - - | WM_NCMOUSELEAVE - (* Indicates the mouse leaving the nonclient area *) - - | WM_NCPAINT of { region: HRGN } - (* Indicates a Window's frame needs painting *) - - | WM_NCRBUTTONDBLCLK of { hitTest: HitTest, x: int, y: int } - (* Indicates nonclient right button double-click *) - - | WM_NCRBUTTONDOWN of { hitTest: HitTest, x: int, y: int } - (* Indicates right button pressed in nonclient area *) - - | WM_NCRBUTTONUP of { hitTest: HitTest, x: int, y: int } - (* Indicates right button released in nonclient area *) - - | WM_NEXTDLGCTL of { control: int, handleflag: bool } - (* Sets focus to different dialog box control *) - - | WM_PAINT - (* Indicates a Window's client area need painting *) - - | WM_PAINTCLIPBOARD of { clipboard: HWND } - (* Prompts owner to display clipboard contents *) - - | WM_PAINTICON - (* Icon is about to be painted *) - - | WM_PALETTECHANGED of { palChg: HWND } - (* Indicates the focus-Window realized its palette *) - - | WM_PALETTEISCHANGING of { realize: HWND } - (* Informs Windows that palette is changing *) - - | WM_PARENTNOTIFY of { eventflag: int, idchild: int, value: int } - (* Notifies parent of child-Window activity *) - - | WM_PASTE - (* Inserts clipboard data into an edit control *) - - | WM_POWER of { powerevent: int } - (* Indicates the system is entering suspended mode *) - - | WM_QUERYDRAGICON - (* Requests a cursor handle for a minimized Window *) - - | WM_QUERYENDSESSION of { source: int } - (* Requests that the Windows session be ended *) - - | WM_QUERYNEWPALETTE - (* Allows a Window to realize its logical palette *) - - | WM_QUERYOPEN - (* Requests that a minimized Window be restored *) - - | WM_QUEUESYNC - (* Delimits CBT messages *) - - | WM_QUIT of { exitcode: int } - (* Requests that an application be terminated *) - - | WM_RBUTTONDBLCLK of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates double-click of right mouse button *) - - | WM_RBUTTONDOWN of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates when right mouse button is pressed *) - - | WM_RBUTTONUP of { keyflags: MouseKeyFlags list, x: int, y: int } - (* Indicates when right mouse button is released *) - - | WM_RENDERALLFORMATS - (* Notifies owner to render all clipboard formats *) - - | WM_RENDERFORMAT of { format: ClipboardFormat } - (* Notifies owner to render clipboard data *) - - | WM_SETCURSOR of { cursorwindow: HWND, hitTest: HitTest, mousemessage: int } - (* Prompts a Window to set the cursor shape *) - - | WM_SETFOCUS of { losing: HWND } - - | WM_SETFONT of {font: HFONT, redrawflag: bool } - - | WM_SETHOTKEY of { virtualKey: int } - - | WM_SETREDRAW of { redrawflag: bool } - - | WM_SETTEXT of { text: string } - - | WM_SHOWWINDOW of { showflag: bool, statusflag: int } - - | WM_SIZE of { flag: WMSizeOptions, width: int, height: int } - - | WM_SIZECLIPBOARD of { viewer: HWND} - - | WM_SYSCHAR of { charCode: char, data: KeyData } - - | WM_SYSCOLORCHANGE - - | WM_SYSCOMMAND of { commandvalue: SystemCommand, sysBits: int, p: POINT } - - | WM_SYSDEADCHAR of { charCode: char, data: KeyData } - - | WM_SYSKEYDOWN of { virtualKey: int, data: KeyData } - - | WM_SYSKEYUP of { virtualKey: int, data: KeyData } - - | WM_TIMECHANGE - (* Indicates the system time has been set *) - - | WM_TIMER of { timerid: int } - - | WM_UNDO - - | WM_SYSTEM_OTHER of { uMsg: int, wParam: SysWord.word, lParam: SysWord.word } - | WM_USER of { uMsg: int, wParam: SysWord.word, lParam: SysWord.word } - | WM_APP of { uMsg: int, wParam: SysWord.word, lParam: SysWord.word } - | WM_REGISTERED of { uMsg: int, wParam: SysWord.word, lParam: SysWord.word } - - | WM_VKEYTOITEM of { virtualKey: int, - caretpos: int, - listbox: HWND } - - | WM_VSCROLL of { value: ScrollDirection, - position: int, - scrollbar: HWND } - - | WM_VSCROLLCLIPBOARD of { viewer: HWND, - code: int, - position: int } - - | WM_WINDOWPOSCHANGED of - { hwnd: HWND, front: HWND, x: int, y: int, width: int, height: int, flags: WindowPositionStyle list } - - | WM_WINDOWPOSCHANGING of - { - hwnd: HWND, front: HWND ref, x: int ref, y: int ref, - width: int ref, height: int ref, flags: WindowPositionStyle list ref - } - - | WM_NOTIFY of {from: HWND, idCtrl: int, idFrom: int, notification: Notification } - - | WM_CAPTURECHANGED of { newCapture: HWND } - - | WM_ENTERSIZEMOVE - - | WM_EXITSIZEMOVE - - | WM_PRINT of {hdc: HDC, flags: WMPrintOption list } - - | WM_PRINTCLIENT of {hdc: HDC, flags: WMPrintOption list } - - | WM_HELP of { ctrlId: int, itemHandle: HelpHandle, contextId: int, mousePos: POINT } - - | WM_GETICON of { big: bool } - - | WM_SETICON of { big: bool, icon: HICON } - - | WM_CONTEXTMENU of { hwnd: HWND, xPos: int, yPos: int } - - | WM_DISPLAYCHANGE of { bitsPerPixel: int, xScreen: int, yScreen: int } - - | EM_CANUNDO - - | EM_CHARFROMPOS of EMCharFromPos - - | EM_EMPTYUNDOBUFFER - - | EM_FMTLINES of {addEOL: bool} - - | EM_GETFIRSTVISIBLELINE - - | EM_GETLIMITTEXT - - | EM_GETLINE of { lineNo: int, size: int, result: string ref } - - | EM_GETLINECOUNT - - | EM_GETMARGINS - - | EM_GETMODIFY - - | EM_GETPASSWORDCHAR - - | EM_GETRECT of {rect: RECT ref} - - | EM_GETSEL of {startPos: int ref, endPos: int ref} - - | EM_GETTHUMB - - | EM_LIMITTEXT of {limit: int} - - | EM_LINEFROMCHAR of {index: int} - - | EM_LINEINDEX of {line: int} - - | EM_LINELENGTH of {index: int} - - | EM_LINESCROLL of {xScroll: int, yScroll: int} - - | EM_POSFROMCHAR of {index: int} - - | EM_REPLACESEL of {canUndo: bool, text: string} - - | EM_SCROLL of {action: ScrollDirection} - - | EM_SCROLLCARET - - | EM_SETMARGINS of {margins: MarginSettings} - - | EM_SETMODIFY of { modified: bool } - - | EM_SETPASSWORDCHAR of { ch: char } - - | EM_SETREADONLY of { readOnly: bool } - - | EM_SETRECT of {rect: RECT} - - | EM_SETRECTNP of {rect: RECT} - - | EM_SETSEL of {startPos: int, endPos: int} - - | EM_SETTABSTOPS of {tabs: IntVector.vector} - - | EM_UNDO - - | BM_CLICK - - | BM_GETCHECK - - | BM_GETIMAGE of {imageType: ImageType} - - | BM_GETSTATE - - | BM_SETCHECK of {state: int} - - | BM_SETIMAGE of {image: HGDIOBJ, imageType: ImageType} - - | BM_SETSTATE of {highlight: bool } - - | BM_SETSTYLE of {redraw: bool, style: windowFlags} - - | CB_GETEDITSEL of {startPos: int ref, endPos: int ref} - - | CB_LIMITTEXT of {limit: int} - - | CB_SETEDITSEL of {startPos: int, endPos: int} - - | CB_ADDSTRING of { text: string } - - | CB_DELETESTRING of { index: int } - - | CB_GETCOUNT - - | CB_GETCURSEL - - | CB_DIR of { attrs: ComboBase.CBDirAttr list, fileSpec: string } - - | CB_GETLBTEXT of { index: int, length: int, text: string ref } - - | CB_GETLBTEXTLEN of { index: int } - - | CB_INSERTSTRING of { index: int, text: string } - - | CB_RESETCONTENT - - | CB_FINDSTRING of { indexStart: int, text: string } - - | CB_SELECTSTRING of { indexStart: int, text: string } - - | CB_SETCURSEL of { index: int } - - | CB_SHOWDROPDOWN of { show: bool } - - | CB_GETITEMDATA of { index: int } - - | CB_SETITEMDATA of { index: int, data: int } - - | CB_GETDROPPEDCONTROLRECT of { rect: RECT ref } - - | CB_SETITEMHEIGHT of { index: int, height: int } - - | CB_GETITEMHEIGHT of { index: int } - - | CB_SETEXTENDEDUI of { extended: bool } - - | CB_GETEXTENDEDUI - - | CB_GETDROPPEDSTATE - - | CB_FINDSTRINGEXACT of { indexStart: int, text: string } - - | CB_SETLOCALE of { locale: int } - - | CB_GETLOCALE - - | CB_GETTOPINDEX - - | CB_SETTOPINDEX of { index: int } - - | CB_GETHORIZONTALEXTENT - - | CB_SETHORIZONTALEXTENT of { extent: int } - - | CB_GETDROPPEDWIDTH - - | CB_SETDROPPEDWIDTH of { width: int } - - | CB_INITSTORAGE of { items: int, bytes: int } - - | LB_ADDSTRING of { text: string } - - | LB_INSERTSTRING of { index: int, text: string } - - | LB_DELETESTRING of { index: int } - - | LB_SELITEMRANGEEX of { first: int, last: int } - - | LB_RESETCONTENT - - | LB_SETSEL of { select: bool, index: int } - - | LB_SETCURSEL of { index: int } - - | LB_GETSEL of { index: int } - - | LB_GETCURSEL - - | LB_GETTEXT of { index: int, length: int, text: string ref } - - | LB_GETTEXTLEN of { index: int } - - | LB_GETCOUNT - - | LB_SELECTSTRING of { indexStart: int, text: string } - - | LB_DIR of { attrs: ComboBase.CBDirAttr list, fileSpec: string } - - | LB_GETTOPINDEX - - | LB_FINDSTRING of { indexStart: int, text: string } - - | LB_GETSELCOUNT - - | LB_GETSELITEMS of { items: IntArray.array } - - | LB_SETTABSTOPS of { tabs: IntVector.vector } - - | LB_GETHORIZONTALEXTENT - - | LB_SETHORIZONTALEXTENT of { extent: int } - - | LB_SETCOLUMNWIDTH of { column: int } - - | LB_ADDFILE of { fileName: string } - - | LB_SETTOPINDEX of { index: int } - - | LB_GETITEMRECT of { rect: RECT ref, index: int } - - | LB_GETITEMDATA of { index: int } - - | LB_SETITEMDATA of { index: int, data: int } - - | LB_SELITEMRANGE of { select: bool, first: int, last: int } - - | LB_SETANCHORINDEX of { index: int } - - | LB_GETANCHORINDEX - - | LB_SETCARETINDEX of { index: int, scroll: bool } - - | LB_GETCARETINDEX - - | LB_SETITEMHEIGHT of { index: int, height: int } - - | LB_GETITEMHEIGHT of { index: int } - - | LB_FINDSTRINGEXACT of { indexStart: int, text: string } - - | LB_SETLOCALE of { locale: int } (* Should be an abstract type? *) - - | LB_GETLOCALE (* Result will be the type used above. *) - - | LB_SETCOUNT of { items: int } - - | LB_INITSTORAGE of { items: int, bytes: int } - - | LB_ITEMFROMPOINT of { point: POINT } - - | STM_GETICON - - | STM_GETIMAGE of {imageType: ImageType} - - | STM_SETICON of {icon: HICON} - - | STM_SETIMAGE of {image: HGDIOBJ, imageType: ImageType} - - | SBM_SETPOS of { pos: int, redraw: bool } - - | SBM_GETPOS - - | SBM_SETRANGE of { minPos: int, maxPos: int } - - | SBM_SETRANGEREDRAW of { minPos: int, maxPos: int } - - | SBM_GETRANGE of { minPos: int ref, maxPos: int ref } - - | SBM_ENABLE_ARROWS of ScrollBase.enableArrows - - | SBM_SETSCROLLINFO of { info: ScrollBase.SCROLLINFO, - options: ScrollBase.ScrollInfoOption list } - - | SBM_GETSCROLLINFO of { info: ScrollBase.SCROLLINFO ref, - options: ScrollBase.ScrollInfoOption list } - - | FINDMSGSTRING of - { flags: findReplaceFlags, findWhat: string, replaceWith: string } - - - (* GetMessage and PeekMessage return these values. *) - type MSG = { - msg: Message, - hwnd: HWND, - time: Time.time, - pt: {x: int, y: int} - } - - type HGDIOBJ = HGDIOBJ and HWND = HWND and RECT = RECT and POINT = POINT - and HMENU = HMENU and HICON = HICON and HINSTANCE = HINSTANCE and HDC = HDC - and HFONT = HFONT and HRGN = HRGN and HDROP = HDROP - and ClipboardFormat = ClipboardFormat and ClassType = ClassType - and findReplaceFlags = FindReplaceFlags.flags - and windowFlags = flags - - (* WM_MOUSEMOVE etc *) - fun decompileMouseMove(constr, wp, lp) = - let - val lp32 = Word32.fromLargeWord lp - in - constr { keyflags = fromCmkf(Word32.fromLargeWord wp), x = Word.toInt(LOWORD lp32), y = Word.toInt(HIWORD lp32) } - end - - fun compileMouseMove(code, { keyflags, x, y}) = - (code, Word32.toLargeWord (toCmkf keyflags), Word32.toLargeWord(MAKELONG(Word.fromInt x, Word.fromInt y)), fn()=>()) - - local (* EM_GETSEL and CB_GETEDITSEL *) - val {load=loadDword, store=storeDword, ctype={size=sizeDword, ...}, ...} = breakConversion cDWORD - in - fun compileGetSel(code, {startPos=ref s, endPos=ref e}) = - let - open Memory - infix 6 ++ - (* Allocate space for two DWORDs *) - val mem = malloc(sizeDword * 0w2) - val eAddr = mem ++ sizeDword - val () = ignore(storeDword(mem, s)) (* Can ignore the results *) - and () = ignore(storeDword(eAddr, e)) - in - (code, fromAddr mem, fromAddr eAddr, fn () => free mem) - end - - and decompileGetSel{wp, lp} = - let - val s = loadDword(toAddr wp) - and e = loadDword(toAddr lp) - in - {startPos = ref s, endPos=ref e} - end - - (* Update ML from wp/lp values *) - fun updateGetSelFromWpLp({startPos, endPos}, {wp, lp}) = - ( startPos := loadDword(toAddr wp); endPos := loadDword(toAddr lp) ) - (* Update wp/lp from ML *) - and updateGetSelParms({wp, lp}, {startPos = ref s, endPos = ref e}) = - ( ignore(storeDword(toAddr wp, s)); ignore(storeDword(toAddr lp, e)) ) - end - - local (* EM_GETRECT and CB_GETDROPPEDCONTROLRECT. LB_GETITEMRECT and WM_NCCALCSIZE are similar *) - val {load=loadRect, store=storeRect, ctype={size=sizeRect, ...}, ...} = breakConversion cRect - in - fun compileGetRect(code, wp, r) = - let - open Memory - val mem = malloc sizeRect - val () = ignore(storeRect(mem, r)) (* Can ignore the result *) - in - (code, wp, fromAddr mem, fn () => free mem) - end - - and compileSetRect(code, rect) = - let - open Memory - val mem = malloc sizeRect - val () = ignore(storeRect(mem, rect)) - in - (code, 0w0, fromAddr mem, fn () => free mem) - end - - (* These can be used for updating *) - val fromCrect = loadRect (* For the moment *) - and toCrect = ignore o storeRect - end - - val hiWord = Word.toInt o HIWORD o Word32.fromLargeWord - and loWord = Word.toInt o LOWORD o Word32.fromLargeWord - - (* Decode a received message. *) - fun decompileMessage (0x0000, _: SysWord.word, _: SysWord.word) = WM_NULL - - | decompileMessage (0x0001, wp, lp) = WM_CREATE(decompileCreate{wp=wp, lp=lp}) - - | decompileMessage (0x0002, _, _) = WM_DESTROY - - | decompileMessage (0x0003, _, lp) = WM_MOVE { x = loWord lp, y = hiWord lp } - - | decompileMessage (0x0005, wp, lp) = WM_SIZE { flag = toWMSizeOpt wp, width = loWord lp, height = hiWord lp } - - | decompileMessage (0x0006, wp, _) = - let - val wp32 = Word32.fromLargeWord wp - in - WM_ACTIVATE { active = toWMactive (LOWORD wp32), minimize = HIWORD wp32 <> 0w0 } - end - - | decompileMessage (0x0007, wp, _) = WM_SETFOCUS { losing = handleOfVoidStar(toAddr wp) } - - | decompileMessage (0x0008, wp, _) = WM_KILLFOCUS { receivefocus = handleOfVoidStar(toAddr wp) } - - | decompileMessage (0x000A, wp, _) = WM_ENABLE { enabled = wp <> 0w0 } - - | decompileMessage (0x000B, wp, _) = WM_SETREDRAW { redrawflag = wp <> 0w0 } - - | decompileMessage (0x000C, _, lp) = WM_SETTEXT { text = fromCstring(toAddr lp) } - - (* When the message arrives we don't know what the text is. *) - | decompileMessage (0x000D, wp, _) = WM_GETTEXT { length = SysWord.toInt wp, text = ref "" } - - | decompileMessage ( 0x000E, _, _) = WM_GETTEXTLENGTH - - | decompileMessage ( 0x000F, _, _) = WM_PAINT - - | decompileMessage ( 0x0010, _, _) = WM_CLOSE - - | decompileMessage ( 0x0011, wp, _) = WM_QUERYENDSESSION { source = SysWord.toInt wp } - - | decompileMessage (0x0012, wp, _) = WM_QUIT {exitcode = SysWord.toInt wp } - - | decompileMessage ( 0x0013, _, _) = WM_QUERYOPEN - - | decompileMessage ( 0x0014, wp, _) = WM_ERASEBKGND { devicecontext = toHDC wp } - - | decompileMessage ( 0x0015, _, _) = WM_SYSCOLORCHANGE - - | decompileMessage ( 0x0016, wp, _) = WM_ENDSESSION { endsession = wp <> 0w0 } - - | decompileMessage ( 0x0018, wp, lp) = WM_SHOWWINDOW { showflag = wp <> 0w0, statusflag = SysWord.toInt lp } - - | decompileMessage ( 0x001B, _, lp) = WM_DEVMODECHANGE { devicename = fromCstring(toAddr lp) } (* "0x001B" *) - - | decompileMessage ( 0x001C, wp, lp) = WM_ACTIVATEAPP { active = wp <> 0w0, threadid = SysWord.toInt lp } (* "0x001C" *) - - | decompileMessage ( 0x001D, _, _) = WM_FONTCHANGE - - | decompileMessage ( 0x001E, _, _) = WM_TIMECHANGE (* "0x001E" *) - - | decompileMessage ( 0x001F, _, _) = WM_CANCELMODE (* "0x001F" *) - - | decompileMessage ( 0x0020, wp, lp) = - WM_SETCURSOR - { cursorwindow = toHWND wp, hitTest = toHitTest(loWord lp), mousemessage = hiWord lp } - - | decompileMessage ( 0x0021, wp, lp) = - WM_MOUSEACTIVATE - { parent = toHWND wp, hitTest = toHitTest(loWord lp), message = hiWord lp } - - | decompileMessage (0x0022, _, _) = WM_CHILDACTIVATE (* "0x0022" *) - - | decompileMessage (0x0023, _, _) = WM_QUEUESYNC (* "0x0023" *) - - | decompileMessage (0x0024, wp, lp) = WM_GETMINMAXINFO(decompileMinMax{lp=lp, wp=wp}) - - | decompileMessage ( 0x0026, _, _) = WM_PAINTICON - - | decompileMessage ( 0x0027, wp, _) = WM_ICONERASEBKGND { devicecontext = toHDC wp } (* "0x0027" *) - - | decompileMessage ( 0x0028, wp, lp) = WM_NEXTDLGCTL { control = SysWord.toInt wp, handleflag = lp <> 0w0 } (* "0x0028" *) - - | decompileMessage (0x002B, wp, lp) = - let - val (ctlType,ctlID,itemID,itemAction,itemState,hItem,hDC, rcItem,itemData) = - toMLDrawItem lp - in - WM_DRAWITEM{ senderId = SysWord.toInt wp, ctlType = ctlType, ctlID = ctlID, itemID = itemID, - itemAction = itemAction, itemState = itemState, hItem = hItem, hDC = hDC, - rcItem = rcItem, itemData = itemData } - end - - | decompileMessage (0x002C, wp, lp) = - let - val (ctlType,ctlID,itemID, itemWidth,itemHeight,itemData) = toMLMeasureItem lp - in - WM_MEASUREITEM - { - senderId = SysWord.toInt wp, ctlType = ctlType, ctlID = ctlID, - itemID = itemID, itemWidth = ref itemWidth, itemHeight = ref itemHeight, itemData = itemData - } - end - - | decompileMessage (0x002D, wp, lp) = - let - val (ctlType,ctlID,itemID,hItem,itemData) = toMLDeleteItem lp - in - WM_DELETEITEM - { senderId = SysWord.toInt wp, ctlType = ctlType, ctlID = ctlID, itemID = itemID, - item = hItem, itemData = itemData } - end - - | decompileMessage ( 0x002E, wp, lp) = - WM_VKEYTOITEM { virtualKey = loWord wp, caretpos = hiWord wp, listbox = toHWND lp } (* "0x002E" *) - - | decompileMessage ( 0x002F, wp, lp) = - WM_CHARTOITEM { key = loWord wp, caretpos = hiWord wp,listbox = toHWND lp } (* "0x002F" *) - - | decompileMessage ( 0x0030, wp, lp) = - (* The definition of WM_SETFONT says that it is the low order word of lp that says whether the - control should be redrawn immediately. *) - WM_SETFONT { font = toHFONT wp, redrawflag = SysWord.andb(0wxffff, lp) <> 0w0 } (* "0x0030" *) - - | decompileMessage ( 0x0031, _, _) = WM_GETFONT (* "0x0031" *) - - | decompileMessage ( 0x0032, wp, _) = WM_SETHOTKEY { virtualKey = SysWord.toInt wp } (* "0x0032" *) - - | decompileMessage ( 0x0033, _, _) = WM_GETHOTKEY (* "0x0033" *) - - | decompileMessage ( 0x0037, _, _) = WM_QUERYDRAGICON (* "0x0037" *) - - | decompileMessage (0x0039, wp, lp) = - let - val (ctlType, ctlID, hItem, itemID1, itemData1, itemID2, itemData2, _) = toMLCompareItem lp - in - WM_COMPAREITEM - { - controlid = SysWord.toInt wp, ctlType = ctlType, ctlID = ctlID, hItem = hItem, - itemID1 = itemID1, itemData1 = itemData1, itemID2 = itemID2, itemData2 = itemData2 - } - end - - | decompileMessage (0x0046, wp, lp) = WM_WINDOWPOSCHANGING(cToMLWindowPosChanging{wp=wp, lp=lp}) - - | decompileMessage (0x0047, wp, lp) = WM_WINDOWPOSCHANGED(cToMLWindowPosChanged{wp=wp, lp=lp}) - - | decompileMessage ( 0x0048, wp, _) = WM_POWER { powerevent = SysWord.toInt wp } (* "0x0048" *) - - | decompileMessage ( 0x004B, _, _) = WM_CANCELJOURNAL (* "0x004B" *) - - | decompileMessage ( 0x004E, wp, lp) = WM_NOTIFY(decompileNotify{wp=wp, lp=lp}) - - | decompileMessage ( 0x0053, wp, lp) = WM_HELP(decompileHelpInfo{wp=wp, lp=lp}) - -(* -WM_INPUTLANGCHANGEREQUEST 0x0050 -WM_INPUTLANGCHANGE 0x0051 -WM_TCARD 0x0052 -WM_USERCHANGED 0x0054 -WM_NOTIFYFORMAT 0x0055 - -NFR_ANSI 1 -NFR_UNICODE 2 -NF_QUERY 3 -NF_REQUERY 4 - -WM_CONTEXTMENU 0x007B -WM_STYLECHANGING 0x007C -WM_STYLECHANGED 0x007D -*) - - | decompileMessage ( 0x007B, wp, lp) = - WM_CONTEXTMENU { hwnd = toHWND wp, xPos = loWord lp, yPos = hiWord lp} - - | decompileMessage ( 0x007E, wp, lp) = - WM_DISPLAYCHANGE { bitsPerPixel = SysWord.toInt wp, xScreen = loWord lp, yScreen = hiWord lp} - - | decompileMessage ( 0x007F, wp, _) = WM_GETICON { big = SysWord.toInt wp = 1} - - | decompileMessage ( 0x0080, wp, lp) = WM_SETICON { big = SysWord.toInt wp = 1, icon = toHICON lp} - - | decompileMessage ( 0x0081, wp, lp) = WM_NCCREATE(decompileCreate{wp=wp, lp=lp}) - - | decompileMessage ( 0x0082, _, _) = WM_NCDESTROY - - | decompileMessage ( 0x0083, wp, lp) = WM_NCCALCSIZE(decompileNCCalcSize{wp=wp, lp=lp}) - - | decompileMessage ( 0x0084, _, lp) = WM_NCHITTEST { x = loWord lp, y = hiWord lp } (* "0x0084" *) - - | decompileMessage ( 0x0085, wp, _) = WM_NCPAINT { region = toHRGN wp } (* "0x0085" *) - - | decompileMessage ( 0x0086, wp, _) = WM_NCACTIVATE { active = wp <> 0w0 } (* "0x0086" *) - - | decompileMessage ( 0x0087, _, _) = WM_GETDLGCODE (* "0x0087" *) - - | decompileMessage ( 0x00A0, wp, lp) = WM_NCMOUSEMOVE { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } - - | decompileMessage ( 0x00A1, wp, lp) = WM_NCLBUTTONDOWN { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } - - | decompileMessage ( 0x00A2, wp, lp) = WM_NCLBUTTONUP { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } - - | decompileMessage ( 0x00A3, wp, lp) = WM_NCLBUTTONDBLCLK { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } - - | decompileMessage ( 0x00A4, wp, lp) = WM_NCRBUTTONDOWN { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } - - | decompileMessage ( 0x00A5, wp, lp) = WM_NCRBUTTONUP { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } - - | decompileMessage ( 0x00A6, wp, lp) = WM_NCRBUTTONDBLCLK { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } - - | decompileMessage ( 0x00A7, wp, lp) = WM_NCMBUTTONDOWN { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } - - | decompileMessage ( 0x00A8, wp, lp) = WM_NCMBUTTONUP { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } - - | decompileMessage ( 0x00A9, wp, lp) = WM_NCMBUTTONDBLCLK { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } - -(* Edit control messages *) - | decompileMessage ( 0x00B0, wp, lp) = EM_GETSEL (decompileGetSel{wp=wp, lp=lp}) - - | decompileMessage ( 0x00B1, wp, lp) = EM_SETSEL { startPos = SysWord.toInt wp, endPos = SysWord.toInt lp } - - | decompileMessage ( 0x00B2, _, lp) = EM_GETRECT {rect = ref(fromCrect(toAddr lp))} - - | decompileMessage ( 0x00B3, _, lp) = EM_SETRECT { rect = fromCrect(toAddr lp) } - - | decompileMessage ( 0x00B4, _, lp) = EM_SETRECTNP { rect = fromCrect(toAddr lp) } - - | decompileMessage ( 0x00B5, wp, _) = EM_SCROLL{action = fromCsd(Word.fromLargeWord wp)} - - | decompileMessage ( 0x00B6, wp, lp) = EM_LINESCROLL{xScroll = SysWord.toInt wp, yScroll = SysWord.toInt lp} - - | decompileMessage ( 0x00B7, _, _) = EM_SCROLLCARET - - | decompileMessage ( 0x00B8, _, _) = EM_GETMODIFY - - | decompileMessage ( 0x00B9, wp, _) = EM_SETMODIFY{modified = wp <> 0w0} - - | decompileMessage ( 0x00BA, _, _) = EM_GETLINECOUNT - - | decompileMessage ( 0x00BB, wp, _) = EM_LINEINDEX {line = SysWord.toIntX (* -1 = current line *) wp} -(* -EM_SETHANDLE 0x00BC -*) - | decompileMessage ( 0x00BE, _, _) = EM_GETTHUMB - - | decompileMessage ( 0x00C1, wp, _) = EM_LINELENGTH {index = SysWord.toIntX (* May be -1 *) wp} - - | decompileMessage ( 0x00C2, wp, lp) = EM_REPLACESEL {canUndo = wp <> 0w0, text = fromCstring(toAddr lp)} - - | decompileMessage ( 0x00C4, wp, lp) = EM_GETLINE(decompileGetLine{wp=wp, lp=lp}) - - | decompileMessage ( 0x00C5, wp, _) = EM_LIMITTEXT {limit = SysWord.toInt wp} - - | decompileMessage ( 0x00C6, _, _) = EM_CANUNDO - - | decompileMessage ( 0x00C7, _, _) = EM_UNDO - - | decompileMessage ( 0x00C8, wp, _) = EM_FMTLINES{addEOL = wp <> 0w0} - - | decompileMessage ( 0x00C9, wp, _) = EM_LINEFROMCHAR{index = SysWord.toInt wp} - - | decompileMessage ( 0x00CB, wp, lp) = EM_SETTABSTOPS{tabs=decompileTabStops{wp=wp, lp=lp}} - - | decompileMessage ( 0x00CC, wp, _) = EM_SETPASSWORDCHAR{ch = chr (SysWord.toInt wp)} - - | decompileMessage ( 0x00CD, _, _) = EM_EMPTYUNDOBUFFER - - | decompileMessage ( 0x00CE, _, _) = EM_GETFIRSTVISIBLELINE - - | decompileMessage ( 0x00CF, wp, _) = EM_SETREADONLY{readOnly = wp <> 0w0} -(* -EM_SETWORDBREAKPROC 0x00D0 -EM_GETWORDBREAKPROC 0x00D1 -*) - - | decompileMessage (0x00D2, _, _) = EM_GETPASSWORDCHAR - - | decompileMessage (0x00D3, wp, lp) = - if wp = 0wxffff then EM_SETMARGINS{margins=UseFontInfo} - else - let - val left = - if SysWord.andb(wp, 0w1) <> 0w0 - then SOME(loWord lp) - else NONE - val right = - if SysWord.andb(wp, 0w2) <> 0w0 - then SOME(hiWord lp) - else NONE - in - EM_SETMARGINS{margins=Margins{left=left, right=right}} - end - - | decompileMessage (0x00D4, _, _) = EM_GETMARGINS - - | decompileMessage (0x00D5, _, _) = EM_GETLIMITTEXT - - | decompileMessage (0x00D6, wp, _) = EM_POSFROMCHAR {index = SysWord.toInt wp} - - | decompileMessage (0x00D7, _, lp) = - (* The value in lParam is different depending on whether this is an edit control - or a rich edit control. Since we don't know we just pass the lp value. *) - EM_CHARFROMPOS(EMcfpUnknown lp) - -(* Scroll bar messages *) - - | decompileMessage (0x00E0, wp, lp) = SBM_SETPOS {pos = SysWord.toInt wp, redraw = lp <> 0w0} - - | decompileMessage (0x00E1, _, _) = SBM_GETPOS - - | decompileMessage (0x00E2, wp, lp) = SBM_SETRANGE {minPos = SysWord.toInt wp, maxPos = SysWord.toInt lp} - - | decompileMessage (0x00E6, wp, lp) = SBM_SETRANGEREDRAW {minPos = SysWord.toInt wp, maxPos = SysWord.toInt lp} - - | decompileMessage (0x00E3, wp, lp) = - SBM_GETRANGE { minPos = ref(loadInt(toAddr wp)), maxPos = ref(loadInt(toAddr lp)) } - - | decompileMessage (0x00E4, wp, _) = SBM_ENABLE_ARROWS(fromCesbf(SysWord.toInt wp)) - - | decompileMessage (0x00E9, _, lp) = - let - val (info, options) = toScrollInfo lp - in - SBM_SETSCROLLINFO{ info = info, options = options } - end - - | decompileMessage (0x00EA, _, lp) = - let - (* The values may not be correct at this point but the mask - should have been set. *) - val (info, options) = toScrollInfo lp - in - SBM_GETSCROLLINFO{ info = ref info, options = options } - end - -(* Button control messages *) - | decompileMessage (0x00F0, _, _) = BM_GETCHECK - - | decompileMessage (0x00F1, wp, _) = BM_SETCHECK{state = SysWord.toInt wp} - - | decompileMessage (0x00F2, _, _) = BM_GETSTATE - - | decompileMessage (0x00F3, wp, _) = BM_SETSTATE{highlight = SysWord.toInt wp <> 0} - - | decompileMessage (0x00F4, wp, lp) = BM_SETSTYLE{redraw = SysWord.toInt lp <> 0, style = Style.fromWord wp} - - | decompileMessage (0x00F5, _, _) = BM_CLICK - - | decompileMessage (0x00F6, wp, _) = BM_GETIMAGE{imageType = fromCit(SysWord.toInt wp)} - - | decompileMessage (0x00F7, wp, lp) = BM_SETIMAGE{imageType = fromCit (SysWord.toInt wp), image = toHGDIOBJ lp} - - | decompileMessage (0x0100, wp, lp) = WM_KEYDOWN { virtualKey = SysWord.toInt wp, data = Word32.fromLargeWord lp } - - | decompileMessage (0x0101, wp, lp) = WM_KEYUP { virtualKey = SysWord.toInt wp, data = Word32.fromLargeWord lp } - - | decompileMessage (0x0102, wp, lp) = WM_CHAR { charCode = chr (SysWord.toInt wp), data = Word32.fromLargeWord lp } - - | decompileMessage (0x0103, wp, lp) = WM_DEADCHAR { charCode = chr (SysWord.toInt wp), data = Word32.fromLargeWord lp } - - | decompileMessage (0x0104, wp, lp) = WM_SYSKEYDOWN { virtualKey = SysWord.toInt wp, data = Word32.fromLargeWord lp } - - | decompileMessage (0x0105, wp, lp) = WM_SYSKEYUP { virtualKey = SysWord.toInt wp, data = Word32.fromLargeWord lp } - - | decompileMessage (0x0106, wp, lp) = WM_SYSCHAR { charCode = chr (SysWord.toInt wp), data = Word32.fromLargeWord lp } - - | decompileMessage (0x0107, wp, lp) = WM_SYSDEADCHAR { charCode = chr (SysWord.toInt wp), data = Word32.fromLargeWord lp } -(* -WM_IME_STARTCOMPOSITION 0x010D -WM_IME_ENDCOMPOSITION 0x010E -WM_IME_COMPOSITION 0x010F -WM_IME_KEYLAST 0x010F -*) - - | decompileMessage (0x0110, wp, lp) = WM_INITDIALOG { dialog = toHWND wp, initdata = SysWord.toInt lp } (* "0x0110" *) - - | decompileMessage (0x0111, wp, lp) = - let - val wp32 = Word32.fromLargeWord wp - in - WM_COMMAND { notifyCode = Word.toInt(HIWORD wp32), wId = Word.toInt(LOWORD wp32), control = toHWND lp } - end - - | decompileMessage (0x0112, wp, lp) = - WM_SYSCOMMAND - { commandvalue = toSysCommand(SysWord.toInt(SysWord.andb(wp, 0wxFFF0))), - sysBits = SysWord.toInt(SysWord.andb(wp, 0wxF)), - p = {x= getXLParam lp, y= getYLParam lp}} - - | decompileMessage (0x0113, wp, _) = WM_TIMER { timerid = SysWord.toInt wp } (* "0x0113" *) - - | decompileMessage (0x0114, wp, lp) = - WM_HSCROLL { value = fromCsd(LOWORD(Word32.fromLargeWord wp)), position = hiWord wp, scrollbar = toHWND lp } (* "0x0114" *) - - | decompileMessage (0x0115, wp, lp) = - WM_VSCROLL { value = fromCsd(LOWORD(Word32.fromLargeWord wp)), position = hiWord wp, scrollbar = toHWND lp } (* "0x0115" *) - - | decompileMessage (0x0116, wp, _) = WM_INITMENU { menu = toHMENU wp } (* "0x0116" *) - - | decompileMessage (0x0117, wp, lp) = - WM_INITMENUPOPUP { menupopup = toHMENU wp, itemposition = loWord lp, isSystemMenu = hiWord lp <> 0 } (* "0x0117" *) - - | decompileMessage (0x011F, wp, lp) = - let - val wp32 = Word32.fromLargeWord wp - in - WM_MENUSELECT { menuitem = Word.toInt(LOWORD wp32), - menuflags = - MenuBase.toMenuFlagSet(Word32.fromLargeWord(Word.toLargeWord(Word.andb(HIWORD wp32, 0wxffff)))), - menu = toHMENU lp } (* "0x011F" *) - end - - | decompileMessage (0x0120, wp, lp) = - let - val wp32 = Word32.fromLargeWord wp - in - WM_MENUCHAR { ch = chr(Word.toInt(LOWORD wp32)), - menuflag = (* Just a single flag *) - MenuBase.toMenuFlag(Word32.fromLargeWord(Word.toLargeWord(Word.andb(HIWORD wp32, 0wxffff)))), - menu= toHMENU lp } (* "0x0120" *) - end - - | decompileMessage (0x0121, wp, lp) = WM_ENTERIDLE { flag = SysWord.toInt wp, window = toHWND lp } (* "0x0121" *) - - | decompileMessage (0x0132, wp, lp) = WM_CTLCOLORMSGBOX { displaycontext = toHDC wp, messagebox = toHWND lp } (* "0x0132" *) - - | decompileMessage (0x0133, wp, lp) = WM_CTLCOLOREDIT { displaycontext = toHDC wp, editcontrol = toHWND lp } (* "0x0133" *) - - | decompileMessage (0x0134, wp, lp) = WM_CTLCOLORLISTBOX { displaycontext = toHDC wp, listbox = toHWND lp } (* "0x0134" *) - - | decompileMessage (0x0135, wp, lp) = WM_CTLCOLORBTN { displaycontext = toHDC wp, button = toHWND lp }(* "0x0135" *) - - | decompileMessage (0x0136, wp, lp) = WM_CTLCOLORDLG { displaycontext = toHDC wp, dialogbox = toHWND lp } (* "0x0136" *) - - | decompileMessage (0x0137, wp, lp) = WM_CTLCOLORSCROLLBAR { displaycontext = toHDC wp, scrollbar = toHWND lp } (* "0x0137" *) - - | decompileMessage (0x0138, wp, lp) = WM_CTLCOLORSTATIC { displaycontext = toHDC wp, staticcontrol = toHWND lp } (* "0x0138" *) - -(* Combobox messages. *) - | decompileMessage (0x0140, wp, lp) = CB_GETEDITSEL (decompileGetSel{wp=wp, lp=lp}) - - | decompileMessage (0x0141, wp, _) = CB_LIMITTEXT {limit = SysWord.toInt wp} - - | decompileMessage (0x0142, _, lp) = CB_SETEDITSEL { startPos = loWord lp, endPos = hiWord lp } - - | decompileMessage (0x0143, _, lp) = CB_ADDSTRING {text = fromCstring(toAddr lp) } - - | decompileMessage (0x0144, wp, _) = CB_DELETESTRING {index = SysWord.toInt wp} - - | decompileMessage (0x0145, wp, lp) = - CB_DIR {attrs = fromCcbal(Word32.fromLargeWord wp), fileSpec = fromCstring(toAddr lp) } - - | decompileMessage (0x0146, _, _) = CB_GETCOUNT - - | decompileMessage (0x0147, _, _) = CB_GETCURSEL - - | decompileMessage (0x0148, wp, _) = CB_GETLBTEXT { index = SysWord.toInt wp, length = 0, text = ref "" } - - | decompileMessage (0x0149, wp, _) = CB_GETLBTEXTLEN {index = SysWord.toInt wp} - - | decompileMessage (0x014A, wp, lp) = CB_INSERTSTRING {text = fromCstring(toAddr lp), index = SysWord.toInt wp } - - | decompileMessage (0x014B, _, _) = CB_RESETCONTENT - - | decompileMessage (0x014C, wp, lp) = CB_FINDSTRING {text = fromCstring(toAddr lp), indexStart = SysWord.toInt wp } - - | decompileMessage (0x014D, wp, lp) = CB_SELECTSTRING {text = fromCstring(toAddr lp), indexStart = SysWord.toInt wp } - - | decompileMessage (0x014E, wp, _) = CB_SETCURSEL {index = SysWord.toInt wp} - - | decompileMessage (0x014F, wp, _) = CB_SHOWDROPDOWN {show = wp <> 0w0} - - | decompileMessage (0x0150, wp, _) = CB_GETITEMDATA {index = SysWord.toInt wp} - - | decompileMessage (0x0151, wp, lp) = CB_SETITEMDATA {index = SysWord.toInt wp, data = SysWord.toInt lp} - - | decompileMessage (0x0152, _, lp) = CB_GETDROPPEDCONTROLRECT {rect = ref(fromCrect(toAddr lp))} - - | decompileMessage (0x0153, wp, lp) = CB_SETITEMHEIGHT {index = SysWord.toInt wp, height = SysWord.toInt lp} - - | decompileMessage (0x0154, wp, _) = CB_GETITEMHEIGHT {index = SysWord.toInt wp} - - | decompileMessage (0x0155, wp, _) = CB_SETEXTENDEDUI {extended = wp <> 0w0} - - | decompileMessage (0x0156, _, _) = CB_GETEXTENDEDUI - - | decompileMessage (0x0157, _, _) = CB_GETDROPPEDSTATE - - | decompileMessage (0x0158, wp, lp) = CB_FINDSTRINGEXACT {text = fromCstring(toAddr lp), indexStart = SysWord.toInt wp } - - | decompileMessage (0x0159, wp, _) = CB_SETLOCALE {locale = SysWord.toInt wp} - - | decompileMessage (0x015A, _, _) = CB_GETLOCALE - - | decompileMessage (0x015b, _, _) = CB_GETTOPINDEX - - | decompileMessage (0x015c, wp, _) = CB_SETTOPINDEX {index = SysWord.toInt wp} - - | decompileMessage (0x015d, _, _) = CB_GETHORIZONTALEXTENT - - | decompileMessage (0x015e, wp, _) = CB_SETHORIZONTALEXTENT {extent = SysWord.toInt wp} - - | decompileMessage (0x015f, _, _) = CB_GETDROPPEDWIDTH - - | decompileMessage (0x0160, wp, _) = CB_SETDROPPEDWIDTH {width = SysWord.toInt wp} - - | decompileMessage (0x0161, wp, lp) = CB_INITSTORAGE {items = SysWord.toInt wp, bytes = SysWord.toInt lp} - -(* Static control messages. *) - | decompileMessage (0x0170, wp, _) = STM_SETICON{icon = toHICON wp} - - | decompileMessage (0x0171, _, _) = STM_GETICON - - | decompileMessage (0x0172, wp, lp) = STM_SETIMAGE{imageType = fromCit(SysWord.toInt wp), image = toHGDIOBJ lp} - - | decompileMessage (0x0173, wp, _) = STM_GETIMAGE{imageType = fromCit(SysWord.toInt wp)} - -(* Listbox messages *) - | decompileMessage (0x0180, _, lp) = LB_ADDSTRING {text = fromCstring(toAddr lp) } - - | decompileMessage (0x0181, wp, lp) = LB_INSERTSTRING {text = fromCstring(toAddr lp), index = SysWord.toInt wp } - - | decompileMessage (0x0182, wp, _) = LB_DELETESTRING {index = SysWord.toInt wp} - - | decompileMessage (0x0183, wp, lp) = LB_SELITEMRANGEEX {first = SysWord.toInt wp, last = SysWord.toInt lp} - - | decompileMessage (0x0184, _, _) = LB_RESETCONTENT - - | decompileMessage (0x0185, wp, lp) = LB_SETSEL {select = wp <> 0w0, index = SysWord.toInt lp} - - | decompileMessage (0x0186, wp, _) = LB_SETCURSEL {index = SysWord.toInt wp} - - | decompileMessage (0x0187, wp, _) = LB_GETSEL {index = SysWord.toInt wp} - - | decompileMessage (0x0188, _, _) = LB_GETCURSEL - - | decompileMessage (0x0189, wp, _) = LB_GETTEXT { index = SysWord.toInt wp, length = 0, text = ref "" } - - | decompileMessage (0x018A, wp, _) = LB_GETTEXTLEN {index = SysWord.toInt wp} - - | decompileMessage (0x018B, _, _) = LB_GETCOUNT - - | decompileMessage (0x018C, wp, lp) = LB_SELECTSTRING {text = fromCstring(toAddr lp), indexStart = SysWord.toInt wp } - - | decompileMessage (0x018D, wp, lp) = LB_DIR {attrs = fromCcbal(Word32.fromLargeWord wp), fileSpec = fromCstring(toAddr lp) } - - | decompileMessage (0x018E, _, _) = LB_GETTOPINDEX - - | decompileMessage (0x018F, wp, lp) = LB_FINDSTRING {text = fromCstring(toAddr lp), indexStart = SysWord.toInt wp } - - | decompileMessage (0x0190, _, _) = LB_GETSELCOUNT - - | decompileMessage (0x0191, wp, _) = LB_GETSELITEMS { items = IntArray.array(SysWord.toInt wp, ~1) } - - | decompileMessage (0x0192, wp, lp) = LB_SETTABSTOPS{tabs=decompileTabStops{wp=wp, lp=lp}} - - | decompileMessage (0x0193, _, _) = LB_GETHORIZONTALEXTENT - - | decompileMessage (0x0194, wp, _) = LB_SETHORIZONTALEXTENT {extent = SysWord.toInt wp} - - | decompileMessage (0x0195, wp, _) = LB_SETCOLUMNWIDTH {column = SysWord.toInt wp} - - | decompileMessage (0x0196, _, lp) = LB_ADDFILE {fileName = fromCstring(toAddr lp) } - - | decompileMessage (0x0197, wp, _) = LB_SETTOPINDEX {index = SysWord.toInt wp} - - | decompileMessage (0x0198, wp, lp) = LB_GETITEMRECT {index = SysWord.toInt wp, rect = ref(fromCrect(toAddr lp))} - - | decompileMessage (0x0199, wp, _) = LB_GETITEMDATA {index = SysWord.toInt wp} - - | decompileMessage (0x019A, wp, lp) = LB_SETITEMDATA {index = SysWord.toInt wp, data = SysWord.toInt lp} - - | decompileMessage (0x019B, wp, lp) = LB_SELITEMRANGE {select = wp <> 0w0, first = loWord lp, last = hiWord lp} - - | decompileMessage (0x019C, wp, _) = LB_SETANCHORINDEX {index = SysWord.toInt wp} - - | decompileMessage (0x019D, _, _) = LB_GETANCHORINDEX - - | decompileMessage (0x019E, wp, lp) = LB_SETCARETINDEX {index = SysWord.toInt wp, scroll = lp <> 0w0} - - | decompileMessage (0x019F, _, _) = LB_GETCARETINDEX - - | decompileMessage (0x01A0, wp, lp) = LB_SETITEMHEIGHT {index = SysWord.toInt wp, height = loWord lp} - - | decompileMessage (0x01A1, wp, _) = LB_GETITEMHEIGHT {index = SysWord.toInt wp} - - | decompileMessage (0x01A2, wp, lp) = LB_FINDSTRINGEXACT {text = fromCstring(toAddr lp), indexStart = SysWord.toInt wp } - - | decompileMessage (0x01A5, wp, _) = LB_SETLOCALE {locale = SysWord.toInt wp} - - | decompileMessage (0x01A6, _, _) = LB_GETLOCALE - - | decompileMessage (0x01A7, wp, _) = LB_SETCOUNT {items = SysWord.toInt wp} - - | decompileMessage (0x01A8, wp, lp) = LB_INITSTORAGE {items = SysWord.toInt wp, bytes = SysWord.toInt lp} - - | decompileMessage (0x01A9, _, lp) = LB_ITEMFROMPOINT {point = {x = loWord lp, y = hiWord lp }} - - | decompileMessage (0x0200, wp, lp) = decompileMouseMove(WM_MOUSEMOVE, wp, lp) - - | decompileMessage (0x0201, wp, lp) = decompileMouseMove(WM_LBUTTONDOWN, wp, lp) - - | decompileMessage (0x0202, wp, lp) = decompileMouseMove(WM_LBUTTONUP, wp, lp) - - | decompileMessage (0x0203, wp, lp) = decompileMouseMove(WM_LBUTTONDBLCLK, wp, lp) - - | decompileMessage (0x0204, wp, lp) = decompileMouseMove(WM_RBUTTONDOWN, wp, lp) - - | decompileMessage (0x0205, wp, lp) = decompileMouseMove(WM_RBUTTONUP, wp, lp) - - | decompileMessage (0x0206, wp, lp) = decompileMouseMove(WM_RBUTTONDBLCLK, wp, lp) - - | decompileMessage (0x0207, wp, lp) = decompileMouseMove(WM_MBUTTONDOWN, wp, lp) - - | decompileMessage (0x0208, wp, lp) = decompileMouseMove(WM_MBUTTONUP, wp, lp) - - | decompileMessage (0x0209, wp, lp) = decompileMouseMove(WM_MBUTTONDBLCLK, wp, lp) - -(* -WM_MOUSEWHEEL 0x020A -*) - | decompileMessage (0x0210, wp, lp) = WM_PARENTNOTIFY { eventflag = loWord wp, idchild = hiWord wp, value = SysWord.toInt lp } - - | decompileMessage (0x0211, wp, _) = WM_ENTERMENULOOP { istrack= wp <> 0w0 } (* "0x0211" *) - - | decompileMessage (0x0212, wp, _) = WM_EXITMENULOOP { istrack= wp <> 0w0 } (* "0x0212" *) -(* -WM_NEXTMENU 0x0213 -WM_SIZING 0x0214 -*) - | decompileMessage (0x0215, _, lp) = WM_CAPTURECHANGED { newCapture = toHWND lp } -(* -WM_MOVING 0x0216 -WM_POWERBROADCAST 0x0218 -WM_DEVICECHANGE 0x0219 -*) - - | decompileMessage (0x0220, _, lp) = - let - val (class, title, hinst, x,y,cx,cy, style, lParam) = toMdiCreate lp - in - WM_MDICREATE - { class = class, title = title, instance = hinst, x = x, y = y, - cx = cx, cy = cy, style = style, cdata = lParam } - end - - | decompileMessage (0x0221, wp, _) = WM_MDIDESTROY { child = toHWND wp } (* "0x0221" *) - - | decompileMessage (0x0223, wp, _) = WM_MDIRESTORE { child = toHWND wp } (* "0x0223" *) - - | decompileMessage (0x0224, wp, lp) = WM_MDINEXT { child = toHWND wp, flagnext = lp <> 0w0 } (* "0x0224" *) - - | decompileMessage (0x0225, wp, _) = WM_MDIMAXIMIZE { child = toHWND wp } (* "0x0225" *) - - | decompileMessage (0x0226, wp, _) = WM_MDITILE { tilingflag = fromCmdif(Word32.fromLargeWord wp) } (* "0x0226" *) - - | decompileMessage (0x0227, wp, _) = WM_MDICASCADE { skipDisabled = SysWord.andb(wp, 0w2) <> 0w0 } - - | decompileMessage (0x0228, _, _) = WM_MDIICONARRANGE - - | decompileMessage (0x0229, _, _) = WM_MDIGETACTIVE - - | decompileMessage (0x0230, wp, lp) = WM_MDISETMENU { frameMenu = toHMENU wp, windowMenu = toHMENU lp } (* "0x0230" *) - - | decompileMessage (0x0231, _, _) = WM_ENTERSIZEMOVE - - | decompileMessage (0x0232, _, _) = WM_EXITSIZEMOVE - - | decompileMessage (0x0233, wp, _) = WM_DROPFILES { hDrop = toHDROP wp } - - | decompileMessage (0x0234, _, _) = WM_MDIREFRESHMENU (* "0x0234" *) -(* -WM_IME_SETCONTEXT 0x0281 -WM_IME_NOTIFY 0x0282 -WM_IME_CONTROL 0x0283 -WM_IME_COMPOSITIONFULL 0x0284 -WM_IME_SELECT 0x0285 -WM_IME_CHAR 0x0286 -WM_IME_KEYDOWN 0x0290 -WM_IME_KEYUP 0x0291 -*) - | decompileMessage (0x02A0, wp, lp) = WM_NCMOUSEHOVER { hitTest = toHitTest(SysWord.toInt wp), x = getXLParam lp, y = getYLParam lp } - - | decompileMessage (0x02A1, wp, lp) = decompileMouseMove(WM_MOUSEHOVER, wp, lp)(* "0x02A1" *) - - | decompileMessage (0x02A2, _, _) = WM_NCMOUSELEAVE (* "0x02A2" *) - - | decompileMessage (0x02A3, _, _) = WM_MOUSELEAVE (* "0x02A3" *) - - | decompileMessage (0x0300, _, _) = WM_CUT (* "0x0300" *) - - | decompileMessage (0x0301, _, _) = WM_COPY (* "0x0301" *) - - | decompileMessage (0x0302, _, _) = WM_PASTE (* "0x0302" *) - - | decompileMessage (0x0303, _, _) = WM_CLEAR (* "0x0303" *) - - | decompileMessage (0x0304, _, _) = WM_UNDO (* "0x0304" *) - - | decompileMessage (0x0305, wp, _) = WM_RENDERFORMAT { format = fromCcbf(SysWord.toInt wp) } (* "0x0305" *) - - | decompileMessage (0x0306, _, _) = WM_RENDERALLFORMATS (* "0x0306" *) - - | decompileMessage (0x0307, _, _) = WM_DESTROYCLIPBOARD (* "0x0307" *) - - | decompileMessage (0x0308, _, _) = WM_DRAWCLIPBOARD (* "0x0308" *) - - | decompileMessage (0x0309, wp, _) = WM_PAINTCLIPBOARD { clipboard = toHWND wp } (* "0x0309" *) - - | decompileMessage (0x030A, wp, lp) = - WM_VSCROLLCLIPBOARD { viewer = toHWND wp, code = loWord lp, position = hiWord lp } (* "0x030A" *) - - | decompileMessage (0x030B, _, lp) = WM_SIZECLIPBOARD { viewer = toHWND lp } (* "0x030B" *) - - (* The format name is inserted by the window procedure so any - incoming message won't have the information. Indeed the - buffer may not have been initialised. *) - | decompileMessage (0x030C, wp, _) = WM_ASKCBFORMATNAME { length = SysWord.toInt wp, formatName = ref "" } - - | decompileMessage (0x030D, wp, lp) = WM_CHANGECBCHAIN { removed = toHWND wp, next = toHWND lp } - - | decompileMessage (0x030E, wp, lp) = - WM_HSCROLLCLIPBOARD { viewer = toHWND wp, code = loWord lp, position = hiWord lp } (* "0x030E" *) - - | decompileMessage (0x030F, _, _) = WM_QUERYNEWPALETTE (* "0x030F" *) - - | decompileMessage (0x0310, wp, _) = WM_PALETTEISCHANGING { realize = toHWND wp } (* "0x0310" *) - - | decompileMessage (0x0311, wp, _) = WM_PALETTECHANGED { palChg = toHWND wp } (* "0x0311" *) - - | decompileMessage (0x0312, wp, _) = WM_HOTKEY { id = SysWord.toInt wp } (* "0x0312" *) - - | decompileMessage (0x0317, wp, lp) = WM_PRINT { hdc = toHDC wp, flags = fromCwmpl(Word32.fromLargeWord lp) } - - | decompileMessage (0x0318, wp, lp) = WM_PRINTCLIENT { hdc = toHDC wp, flags = fromCwmpl(Word32.fromLargeWord lp) } - - | decompileMessage (m, wp, lp) = - (* User, application and registered messages. *) - (* Rich edit controls use WM_USER+37 to WM_USER+122. As and when we implement - rich edit controls we may want to treat those messages specially. *) - if m >= 0x0400 andalso m <= 0x7FFF - then WM_USER { uMsg = m, wParam = wp, lParam = lp } - else if m >= 0x8000 andalso m <= 0xBFFF - then WM_APP { uMsg = m, wParam = wp, lParam = lp } - else if m >= 0x8000 andalso m <= 0xFFFF - then - ( - (* We could use PolyML.OnEntry or use a weak byte ref to initialise the registered messages. *) - if m = RegisterMessage "commdlg_FindReplace" - then FINDMSGSTRING(decompileFindMsg{wp=wp, lp=lp}) - else WM_REGISTERED { uMsg = m, wParam = wp, lParam = lp } - ) - else (* Other system messages. *) - WM_SYSTEM_OTHER { uMsg = m, wParam = wp, lParam = lp } - - fun btoi false = 0 | btoi true = 1 - - fun makeLong(x, y) = Word32.toLargeWord(MAKELONG(Word.fromInt x, Word.fromInt y)) - - (* If we return a string we need to ensure it's freed *) - fun compileStringAsLp(code, wp, string) = - let - val s = toCstring string - in - (code, wp, fromAddr s, fn () => Memory.free s) - end - - (* Requests for strings. Many of these don't pass the length as an argument. *) - fun compileStringRequest(code, wparam, length) = - let - open Memory - val mem = malloc(Word.fromInt length) - in - (code, wparam, fromAddr mem, fn () => free mem) - end - - fun strAddrAsLp(code, wp, (addr, free)) = (code, wp, addr, free) - - fun noFree () = () - - fun compileMessage WM_NULL = (0x0000, 0w0: SysWord.word, 0w0: SysWord.word, noFree) - - | compileMessage (WM_CREATE args) = compileCreate(0x0001, args) - - | compileMessage WM_DESTROY = (0x0002, 0w0, 0w0, noFree) - - | compileMessage (WM_MOVE {x, y}) = (0x0003, 0w0, makeLong(x, y), noFree) - - | compileMessage (WM_SIZE {flag, width, height}) = - (0x0005, fromWMSizeOpt flag, makeLong(width, height), noFree) - - | compileMessage (WM_ACTIVATE {active, minimize}) = - (0x0006, Word32.toLargeWord(MAKELONG(fromWMactive active, if minimize then 0w1 else 0w1)), 0w0, noFree) - - | compileMessage (WM_SETFOCUS {losing}) = (0x0007, 0w0, fromHWND losing, noFree) - - | compileMessage (WM_KILLFOCUS {receivefocus}) = (0x0008, 0w0, fromHWND receivefocus, noFree) - - | compileMessage (WM_ENABLE {enabled}) = (0x000A, if enabled then 0w1 else 0w0, 0w0, noFree) - - | compileMessage (WM_SETREDRAW {redrawflag}) = (0x000B, if redrawflag then 0w1 else 0w0, 0w0, noFree) - - | compileMessage (WM_SETTEXT {text}) = compileStringAsLp(0x000C, 0w0, text) - - | compileMessage (WM_GETTEXT {length, ...}) = compileStringRequest(0x000D, SysWord.fromInt length, length) - - | compileMessage WM_GETTEXTLENGTH = (0x000E, 0w0, 0w0, noFree) - - | compileMessage WM_PAINT = (0x000F, 0w0, 0w0, noFree) - - | compileMessage WM_CLOSE = (0x0010, 0w0, 0w0, noFree) - - | compileMessage (WM_QUERYENDSESSION { source}) = (0x0011, SysWord.fromInt source, 0w0, noFree) - - | compileMessage (WM_QUIT {exitcode}) = (0x0012, SysWord.fromInt exitcode, 0w0, noFree) - - | compileMessage WM_QUERYOPEN = (0x0013, 0w0, 0w0, noFree) - - | compileMessage (WM_ERASEBKGND {devicecontext}) = (0x0014, 0w0, fromHDC devicecontext, noFree) - - | compileMessage WM_SYSCOLORCHANGE = (0x0015, 0w0, 0w0, noFree) - - | compileMessage (WM_ENDSESSION {endsession}) = (0x0016, SysWord.fromInt(btoi endsession), 0w0, noFree) - - | compileMessage (WM_SHOWWINDOW {showflag, statusflag}) = - (0x0018, SysWord.fromInt(btoi showflag), SysWord.fromInt statusflag, noFree) - - | compileMessage (WM_DEVMODECHANGE {devicename}) = compileStringAsLp(0x001B, 0w0, devicename) - - | compileMessage (WM_ACTIVATEAPP {active, threadid}) = - (0x001B, SysWord.fromInt(btoi active), SysWord.fromInt threadid, noFree) - - | compileMessage WM_FONTCHANGE = (0x001D, 0w0, 0w0, noFree) - - | compileMessage WM_TIMECHANGE = (0x001E, 0w0, 0w0, noFree) - - | compileMessage WM_CANCELMODE = (0x001F, 0w0, 0w0, noFree) - - | compileMessage (WM_SETCURSOR {cursorwindow, hitTest, mousemessage}) = - (0x0020, fromHWND cursorwindow, makeLong(fromHitTest hitTest, mousemessage), noFree) - - | compileMessage (WM_MOUSEACTIVATE {parent, hitTest, message}) = - (0x0021, fromHWND parent, makeLong(fromHitTest hitTest, message), noFree) - - | compileMessage WM_CHILDACTIVATE = (0x0022, 0w0, 0w0, noFree) - - | compileMessage WM_QUEUESYNC = (0x0023, 0w0, 0w0, noFree) - - | compileMessage(WM_GETMINMAXINFO args) = compileMinMax(0x0024, args) - - | compileMessage WM_PAINTICON = (0x0026, 0w0, 0w0, noFree) - - | compileMessage (WM_ICONERASEBKGND {devicecontext}) = - (0x0027, fromHDC devicecontext, 0w0, noFree) - - | compileMessage (WM_NEXTDLGCTL {control, handleflag}) = - (0x0028, SysWord.fromInt control, SysWord.fromInt(btoi handleflag), noFree) - - | compileMessage (WM_DRAWITEM { senderId, ctlType, ctlID, itemID, itemAction,itemState, - hItem, hDC, rcItem, itemData}) = - strAddrAsLp(0x002B, SysWord.fromInt senderId, - fromMLDrawItem(ctlType, ctlID, itemID, itemAction,itemState, hItem, hDC,rcItem,itemData)) - - | compileMessage (WM_MEASUREITEM{ senderId, ctlType, ctlID, itemID, itemWidth=ref itemWidth, itemHeight=ref itemHeight, itemData}) = - strAddrAsLp(0x002C, SysWord.fromInt senderId, - fromMLMeasureItem(ctlType, ctlID, itemID, itemWidth, itemHeight, itemData)) - - | compileMessage (WM_DELETEITEM{ senderId, ctlType, ctlID, itemID, item, itemData}) = - strAddrAsLp(0x002D, SysWord.fromInt senderId, - fromMLDeleteItem(ctlType, ctlID, itemID, item, itemData)) - - | compileMessage (WM_VKEYTOITEM {virtualKey, caretpos, listbox}) = - (0x002E, makeLong(virtualKey, caretpos), fromHWND listbox, noFree) - - | compileMessage (WM_CHARTOITEM {key, caretpos, listbox}) = - (0x002F, makeLong(key, caretpos), fromHWND listbox, noFree) - - | compileMessage (WM_SETFONT {font, redrawflag}) = - (0x0030, fromHFONT font, if redrawflag then 0w1 else 0w0, noFree) - - | compileMessage WM_GETFONT = (0x0031, 0w0, 0w0, noFree) - - | compileMessage (WM_SETHOTKEY {virtualKey}) = (0x0032, SysWord.fromInt virtualKey, 0w0, noFree) - - | compileMessage WM_GETHOTKEY = (0x0033, 0w0, 0w0, noFree) - - | compileMessage WM_QUERYDRAGICON = (0x0037, 0w0, 0w0, noFree) - - | compileMessage (WM_COMPAREITEM { controlid, ctlType, ctlID, hItem, itemID1,itemData1, itemID2,itemData2}) = - let - (* TODO: Perhaps we should have locale Id in the argument record. *) - val LOCALE_USER_DEFAULT = 0x0400 - in - strAddrAsLp(0x0039, SysWord.fromInt controlid, - fromMLCompareItem (ctlType, ctlID, hItem, itemID1, itemData1, itemID2, itemData2, LOCALE_USER_DEFAULT)) - end - - | compileMessage (WM_WINDOWPOSCHANGING wpc) = mlToCWindowPosChanging(0x0046, wpc) - - | compileMessage (WM_WINDOWPOSCHANGED wpc) = mlToCWindowPosChanged(0x0047, wpc) - - | compileMessage (WM_POWER {powerevent}) = (0x0048, SysWord.fromInt powerevent, 0w0, noFree) - - | compileMessage WM_CANCELJOURNAL = (0x004B, 0w0, 0w0, noFree) - - | compileMessage (WM_NOTIFY {idCtrl, from, idFrom, notification}) = - strAddrAsLp (0x004E, SysWord.fromInt idCtrl, compileNotification(from, idFrom, notification)) - -(* -WM_INPUTLANGCHANGEREQUEST 0x0050 -WM_INPUTLANGCHANGE 0x0051 -WM_TCARD 0x0052 -WM_USERCHANGED 0x0054 -WM_NOTIFYFORMAT 0x0055 - -WM_STYLECHANGING 0x007C -WM_STYLECHANGED 0x007D -*) - - | compileMessage (WM_HELP args) = compileHelpInfo(0x0053, args) - - | compileMessage (WM_CONTEXTMENU { hwnd, xPos, yPos }) = - (0x007B, fromHWND hwnd, makeLong(xPos, yPos), noFree) - - | compileMessage (WM_DISPLAYCHANGE { bitsPerPixel, xScreen, yScreen}) = - (0x007E, SysWord.fromInt bitsPerPixel, makeLong(xScreen, yScreen), noFree) - - | compileMessage (WM_GETICON {big}) = (0x007F, SysWord.fromInt(btoi big), 0w0, noFree) - - | compileMessage (WM_SETICON { big, icon }) = - (0x0080, SysWord.fromInt(btoi big), fromAddr(voidStarOfHandle icon), noFree) - - | compileMessage (WM_NCCREATE args) = compileCreate(0x0081, args) - - | compileMessage WM_NCDESTROY = (0x0082, 0w0, 0w0, noFree) - - | compileMessage (WM_NCCALCSIZE args) = compileNCCalcSize args - - | compileMessage (WM_NCHITTEST {x, y}) = (0x0084, 0w0, makeLong(x, y), noFree) - - | compileMessage (WM_NCPAINT {region}) = (0x0085, fromHRGN region, 0w0, noFree) - - | compileMessage (WM_NCACTIVATE {active}) = (0x0086, SysWord.fromInt(btoi active), 0w0, noFree) - - | compileMessage WM_GETDLGCODE = (0x0087, 0w0, 0w0, noFree) - - | compileMessage (WM_NCMOUSEMOVE {hitTest, x, y}) = - (0x00A0, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) - - | compileMessage (WM_NCLBUTTONDOWN {hitTest, x, y}) = - (0x00A1, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) - - | compileMessage (WM_NCLBUTTONUP {hitTest, x, y}) = - (0x00A2, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) - - | compileMessage (WM_NCLBUTTONDBLCLK {hitTest, x, y}) = - (0x00A3, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) - - | compileMessage (WM_NCRBUTTONDOWN {hitTest, x, y}) = - (0x00A4, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) - - | compileMessage (WM_NCRBUTTONUP {hitTest, x, y}) = - (0x00A5, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) - - | compileMessage (WM_NCRBUTTONDBLCLK {hitTest, x, y}) = - (0x00A6, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) - - | compileMessage (WM_NCMBUTTONDOWN {hitTest, x, y}) = - (0x00A7, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) - - | compileMessage (WM_NCMBUTTONUP {hitTest, x, y}) = - (0x00A8, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) - - | compileMessage (WM_NCMBUTTONDBLCLK {hitTest, x, y}) = - (0x00A9, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) - -(* Edit control messages *) - | compileMessage (EM_GETSEL args) = compileGetSel(0x00B0, args) - - | compileMessage (EM_SETSEL{startPos, endPos}) = - (0x00B1, SysWord.fromInt startPos, SysWord.fromInt endPos, noFree) - - | compileMessage (EM_GETRECT {rect=ref r}) = compileGetRect(0x00B2, 0w0, r) - - | compileMessage (EM_SETRECT {rect}) = compileSetRect(0x00B3, rect) - - | compileMessage (EM_SETRECTNP {rect}) = compileSetRect(0x00B4, rect) - - | compileMessage (EM_SCROLL{action}) = (0x00B5, Word.toLargeWord(toCsd action), 0w0, noFree) - - | compileMessage (EM_LINESCROLL{xScroll, yScroll}) = - (0x00B6, SysWord.fromInt xScroll, SysWord.fromInt yScroll, noFree) - - | compileMessage EM_SCROLLCARET = (0x00B7, 0w0, 0w0, noFree) - - | compileMessage EM_GETMODIFY = (0x00B8, 0w0, 0w0, noFree) - - | compileMessage (EM_SETMODIFY{modified}) = (0x00B9, if modified then 0w1 else 0w0, 0w0, noFree) - - | compileMessage EM_GETLINECOUNT = (0x00BA, 0w0, 0w0, noFree) - - | compileMessage (EM_LINEINDEX{line}) = (0x00BB, SysWord.fromInt line, 0w0, noFree) -(* -EM_SETHANDLE 0x00BC -*) - | compileMessage EM_GETTHUMB = (0x00BE, 0w0, 0w0, noFree) - - | compileMessage (EM_LINELENGTH{index}) = (0x00BB, SysWord.fromInt index, 0w0, noFree) - - | compileMessage (EM_REPLACESEL{canUndo, text}) = compileStringAsLp(0x00C2, SysWord.fromInt(btoi canUndo), text) - - | compileMessage (EM_GETLINE args) = compileGetLine args - - | compileMessage (EM_LIMITTEXT{limit}) = (0x00C5, SysWord.fromInt limit, 0w0, noFree) - - | compileMessage EM_CANUNDO = (0x00C6, 0w0, 0w0, noFree) - - | compileMessage EM_UNDO = (0x00C7, 0w0, 0w0, noFree) - - | compileMessage (EM_FMTLINES{addEOL}) = (0x00C8, SysWord.fromInt(btoi addEOL), 0w0, noFree) - - | compileMessage (EM_LINEFROMCHAR{index}) = (0x00C9, SysWord.fromInt index, 0w0, noFree) - - | compileMessage (EM_SETTABSTOPS{tabs}) = compileTabStops(0x00CB, tabs) - - | compileMessage (EM_SETPASSWORDCHAR{ch}) = (0x00CC, SysWord.fromInt(ord ch), 0w0, noFree) - - | compileMessage EM_EMPTYUNDOBUFFER = (0x00CD, 0w0, 0w0, noFree) - - | compileMessage EM_GETFIRSTVISIBLELINE = (0x00CE, 0w0, 0w0, noFree) - - | compileMessage (EM_SETREADONLY{readOnly}) = (0x00CF, SysWord.fromInt(btoi readOnly), 0w0, noFree) -(* -EM_SETWORDBREAKPROC 0x00D0 -EM_GETWORDBREAKPROC 0x00D1 -*) - | compileMessage EM_GETPASSWORDCHAR = (0x00D2, 0w0, 0w0, noFree) - - | compileMessage (EM_SETMARGINS{margins}) = - ( - case margins of - UseFontInfo => (0x00D3, SysWord.fromInt 0xffff, 0w0, noFree) - | Margins{left, right} => - let - val (b0, lo) = case left of SOME l => (0w1, l) | NONE => (0w0, 0) - val (b1, hi) = case right of SOME r => (0w2, r) | NONE => (0w0, 0) - in - (0x00D3, SysWord.orb(b0, b1), makeLong(hi,lo), noFree) - end - ) - - | compileMessage EM_GETMARGINS = (0x00D4, 0w0, 0w0, noFree) (* Returns margins in lResult *) - - | compileMessage EM_GETLIMITTEXT = (0x00D5, 0w0, 0w0, noFree) - - | compileMessage (EM_POSFROMCHAR {index}) = (0x00D6, SysWord.fromInt index, 0w0, noFree) - - | compileMessage (EM_CHARFROMPOS arg) = - let - val (lParam, toFree) = - case arg of - EMcfpEdit{x,y} => (makeLong(x, y), noFree) - | EMcfpRichEdit pt => makePointStructAddr pt - | EMcfpUnknown lp => (lp, noFree) - in - (0x00D7, 0w0, lParam, toFree) - end - -(* Scroll bar messages *) - - | compileMessage (SBM_SETPOS {pos, redraw}) = (0x00E0, SysWord.fromInt pos, SysWord.fromInt(btoi redraw), noFree) - - | compileMessage SBM_GETPOS = (0x00E1, 0w0, 0w0, noFree) - - | compileMessage (SBM_SETRANGE {minPos, maxPos}) = (0x00E2, SysWord.fromInt minPos, SysWord.fromInt maxPos, noFree) - - | compileMessage (SBM_SETRANGEREDRAW {minPos, maxPos}) = (0x00E6, SysWord.fromInt minPos, SysWord.fromInt maxPos, noFree) - - | compileMessage (SBM_GETRANGE _) = - let - (* An application should use GetScrollRange rather than sending this.*) - open Memory - (* We need to allocate two ints and pass their addresses *) - val mem = malloc(0w2 * sizeInt) - infix 6 ++ - in - (0x00E3, fromAddr mem, fromAddr(mem ++ sizeInt), fn () => free mem) - end - - | compileMessage (SBM_ENABLE_ARROWS flags) = (0x00E4, SysWord.fromInt(toCesbf flags), 0w0, noFree) - - | compileMessage (SBM_SETSCROLLINFO {info, options}) = - strAddrAsLp(0x00E9, 0w0, fromScrollInfo(info, options)) - - | compileMessage (SBM_GETSCROLLINFO {info = ref info, options}) = - strAddrAsLp(0x00EA, 0w0, fromScrollInfo(info, options)) - -(* Button control messages *) - - | compileMessage BM_GETCHECK = (0x00F0, 0w0, 0w0, noFree) - - | compileMessage (BM_SETCHECK{state}) = (0x00F1, SysWord.fromInt state, 0w0, noFree) - - | compileMessage BM_GETSTATE = (0x00F2, 0w0, 0w0, noFree) - - | compileMessage (BM_SETSTATE{highlight}) = (0x00F3, SysWord.fromInt(btoi highlight), 0w0, noFree) - - | compileMessage (BM_SETSTYLE{redraw, style}) - = (0x00F3, SysWord.fromInt(LargeWord.toInt(Style.toWord style)), SysWord.fromInt(btoi redraw), noFree) - - | compileMessage BM_CLICK = (0x00F5, 0w0, 0w0, noFree) - - | compileMessage (BM_GETIMAGE{imageType}) = (0x00F6, SysWord.fromInt(toCit imageType), 0w0, noFree) - - | compileMessage (BM_SETIMAGE{imageType, image}) = - (0x00F7, SysWord.fromInt(toCit imageType), fromHGDIOBJ image, noFree) - - | compileMessage (WM_KEYDOWN {virtualKey, data}) = (0x0100, SysWord.fromInt virtualKey, Word32.toLargeWord data, noFree) - - | compileMessage (WM_KEYUP {virtualKey, data}) = (0x0101, SysWord.fromInt virtualKey, Word32.toLargeWord data, noFree) - - | compileMessage (WM_CHAR {charCode, data}) = (0x0102, SysWord.fromInt(ord charCode), Word32.toLargeWord data, noFree) - - | compileMessage (WM_DEADCHAR {charCode, data}) = (0x0103, SysWord.fromInt(ord charCode), Word32.toLargeWord data, noFree) - - | compileMessage (WM_SYSKEYDOWN {virtualKey, data}) = (0x0104, SysWord.fromInt virtualKey, Word32.toLargeWord data, noFree) - - | compileMessage (WM_SYSKEYUP {virtualKey, data}) = (0x0105, SysWord.fromInt virtualKey, Word32.toLargeWord data, noFree) - - | compileMessage (WM_SYSCHAR {charCode, data}) = (0x0106, SysWord.fromInt(ord charCode), Word32.toLargeWord data, noFree) - - | compileMessage (WM_SYSDEADCHAR {charCode, data}) = (0x0107, SysWord.fromInt(ord charCode), Word32.toLargeWord data, noFree) -(* -WM_IME_STARTCOMPOSITION 0x010D -WM_IME_ENDCOMPOSITION 0x010E -WM_IME_COMPOSITION 0x010F -WM_IME_KEYLAST 0x010F - -*) - - | compileMessage (WM_INITDIALOG { dialog, initdata}) = - (0x0110, fromHWND dialog, SysWord.fromInt initdata, noFree) - - | compileMessage (WM_COMMAND {notifyCode, wId, control}) = - (0x0111, makeLong(wId, notifyCode), fromHWND control, noFree) - - | compileMessage (WM_SYSCOMMAND {commandvalue, sysBits, p={x,y}}) = - (0x0112, Word.toLargeWord(Word.orb(Word.fromInt sysBits, Word.fromInt(fromSysCommand commandvalue))), - makeLong(x,y), noFree) - - | compileMessage (WM_TIMER {timerid}) = (0x0113, SysWord.fromInt timerid, 0w0, noFree) - - | compileMessage (WM_HSCROLL {value, position, scrollbar}) = - (0x0114, makeLong(Word.toInt(toCsd value), position), fromHWND scrollbar, noFree) - - | compileMessage (WM_VSCROLL {value, position, scrollbar}) = - (0x0115, makeLong(Word.toInt(toCsd value), position), fromHWND scrollbar, noFree) - - | compileMessage (WM_INITMENU {menu}) = - (0x0116, fromHMENU menu, 0w0, noFree) - - | compileMessage (WM_INITMENUPOPUP {menupopup, itemposition, isSystemMenu}) = - (0x0117, fromHMENU menupopup, makeLong(itemposition, btoi isSystemMenu), noFree) - - | compileMessage (WM_MENUSELECT {menuitem, menuflags, menu}) = - (0x011F, makeLong(menuitem, Word32.toInt(MenuBase.fromMenuFlagSet menuflags)), fromHMENU menu, noFree) - - | compileMessage (WM_MENUCHAR { ch, menuflag, menu}) = - (0x0120, makeLong(ord ch, Word32.toInt(MenuBase.fromMenuFlag menuflag)), fromHMENU menu, noFree) - - | compileMessage (WM_ENTERIDLE { flag, window}) = (0x0121, SysWord.fromInt flag, fromHWND window, noFree) - - | compileMessage (WM_CTLCOLORMSGBOX { displaycontext, messagebox}) = - (0x0132, fromHDC displaycontext, fromHWND messagebox, noFree) - - | compileMessage (WM_CTLCOLOREDIT { displaycontext, editcontrol}) = - (0x0133, fromHDC displaycontext, fromHWND editcontrol, noFree) - - | compileMessage (WM_CTLCOLORLISTBOX { displaycontext, listbox}) = - (0x0134, fromHDC displaycontext, fromHWND listbox, noFree) - - | compileMessage (WM_CTLCOLORBTN { displaycontext, button}) = - (0x0135, fromHDC displaycontext, fromHWND button, noFree) - - | compileMessage (WM_CTLCOLORDLG { displaycontext, dialogbox}) = - (0x0136, fromHDC displaycontext, fromHWND dialogbox, noFree) - - | compileMessage (WM_CTLCOLORSCROLLBAR { displaycontext, scrollbar}) = - (0x0137, fromHDC displaycontext, fromHWND scrollbar, noFree) - - | compileMessage (WM_CTLCOLORSTATIC { displaycontext, staticcontrol}) = - (0x0138, fromHDC displaycontext, fromHWND staticcontrol, noFree) - -(* Combobox messages. *) - - | compileMessage (CB_GETEDITSEL args) = compileGetSel(0x0140, args) - - | compileMessage (CB_LIMITTEXT{limit}) = (0x0141, SysWord.fromInt limit, 0w0, noFree) - - | compileMessage (CB_SETEDITSEL{startPos, endPos}) = - (0x0142, 0w0, makeLong(startPos, endPos), noFree) - - | compileMessage (CB_ADDSTRING{text}) = compileStringAsLp(0x0143, 0w0, text) - - | compileMessage (CB_DELETESTRING{index}) = (0x0144, SysWord.fromInt index, 0w0, noFree) - - | compileMessage (CB_DIR{attrs, fileSpec}) = compileStringAsLp(0x0145, Word32.toLargeWord(toCcbal attrs), fileSpec) - - | compileMessage CB_GETCOUNT = (0x0146, 0w0, 0w0, noFree) - - | compileMessage CB_GETCURSEL = (0x0147, 0w0, 0w0, noFree) - - | compileMessage (CB_GETLBTEXT {length, index, ...}) = compileStringRequest(0x0148, SysWord.fromInt index, length) - - | compileMessage (CB_GETLBTEXTLEN{index}) = (0x0149, SysWord.fromInt index, 0w0, noFree) - - | compileMessage (CB_INSERTSTRING{text, index}) = compileStringAsLp(0x014A, SysWord.fromInt index, text) - - | compileMessage CB_RESETCONTENT = (0x014B, 0w0, 0w0, noFree) - - | compileMessage (CB_FINDSTRING{text, indexStart}) = compileStringAsLp(0x014C, SysWord.fromInt indexStart, text) - - | compileMessage (CB_SELECTSTRING{text, indexStart}) = compileStringAsLp(0x014D, SysWord.fromInt indexStart, text) - - | compileMessage (CB_SETCURSEL{index}) = (0x014E, SysWord.fromInt index, 0w0, noFree) - - | compileMessage (CB_SHOWDROPDOWN{show}) = (0x014F, SysWord.fromInt(btoi show), 0w0, noFree) - - | compileMessage (CB_GETITEMDATA{index}) = (0x0150, SysWord.fromInt index, 0w0, noFree) - - | compileMessage (CB_SETITEMDATA{index, data}) = (0x0151, SysWord.fromInt index, SysWord.fromInt data, noFree) - - | compileMessage (CB_GETDROPPEDCONTROLRECT {rect=ref rect}) = compileGetRect(0x0152, 0w0, rect) - - | compileMessage (CB_SETITEMHEIGHT{index, height}) = (0x0153, SysWord.fromInt index, SysWord.fromInt height, noFree) - - | compileMessage (CB_GETITEMHEIGHT{index}) = (0x0154, SysWord.fromInt index, 0w0, noFree) - - | compileMessage (CB_SETEXTENDEDUI{extended}) = (0x0155, SysWord.fromInt(btoi extended), 0w0, noFree) - - | compileMessage CB_GETEXTENDEDUI = (0x0156, 0w0, 0w0, noFree) - - | compileMessage CB_GETDROPPEDSTATE = (0x0157, 0w0, 0w0, noFree) - - | compileMessage (CB_FINDSTRINGEXACT{text, indexStart}) = compileStringAsLp(0x0158, SysWord.fromInt indexStart, text) - - | compileMessage (CB_SETLOCALE{locale}) = (0x0159, SysWord.fromInt locale, 0w0, noFree) - - | compileMessage CB_GETLOCALE = (0x015A, 0w0, 0w0, noFree) - - | compileMessage CB_GETTOPINDEX = (0x015b, 0w0, 0w0, noFree) - - | compileMessage (CB_SETTOPINDEX{index}) = (0x015c, SysWord.fromInt index, 0w0, noFree) - - | compileMessage CB_GETHORIZONTALEXTENT = (0x015d, 0w0, 0w0, noFree) - - | compileMessage (CB_SETHORIZONTALEXTENT{extent}) = (0x015e, SysWord.fromInt extent, 0w0, noFree) - - | compileMessage CB_GETDROPPEDWIDTH = (0x015f, 0w0, 0w0, noFree) - - | compileMessage (CB_SETDROPPEDWIDTH{width}) = (0x0160, SysWord.fromInt width, 0w0, noFree) - - | compileMessage (CB_INITSTORAGE{items, bytes}) = (0x0161, SysWord.fromInt items, SysWord.fromInt bytes, noFree) - -(* Static control messages. *) - - | compileMessage (STM_SETICON{icon}) = (0x0170, fromHICON icon, 0w0, noFree) - - | compileMessage STM_GETICON = (0x0171, 0w0, 0w0, noFree) - - | compileMessage (STM_SETIMAGE{imageType, image}) = - (0x0172, SysWord.fromInt(toCit imageType), fromHGDIOBJ image, noFree) - - | compileMessage (STM_GETIMAGE{imageType}) = (0x0173, SysWord.fromInt(toCit imageType), 0w0, noFree) - -(* Listbox messages *) - | compileMessage (LB_ADDSTRING{text}) = compileStringAsLp(0x0180, 0w0, text) - - | compileMessage (LB_INSERTSTRING{text, index}) = compileStringAsLp(0x0181, SysWord.fromInt index, text) - - | compileMessage (LB_DELETESTRING{index}) = (0x0182, SysWord.fromInt index, 0w0, noFree) - - | compileMessage (LB_SELITEMRANGEEX{first, last}) = (0x0183, SysWord.fromInt first, SysWord.fromInt last, noFree) - - | compileMessage LB_RESETCONTENT = (0x0184, 0w0, 0w0, noFree) - - | compileMessage (LB_SETSEL{select, index}) = (0x0185, SysWord.fromInt(btoi select), SysWord.fromInt index, noFree) - - | compileMessage (LB_SETCURSEL{index}) = (0x0186, SysWord.fromInt index, 0w0, noFree) - - | compileMessage (LB_GETSEL{index}) = (0x0187, SysWord.fromInt index, 0w0, noFree) - - | compileMessage LB_GETCURSEL = (0x0188, 0w0, 0w0, noFree) - - | compileMessage (LB_GETTEXT {length, index, ...}) = compileStringRequest(0x0189, SysWord.fromInt index, length) - - | compileMessage (LB_GETTEXTLEN{index}) = (0x018A, SysWord.fromInt index, 0w0, noFree) - - | compileMessage LB_GETCOUNT = (0x018B, 0w0, 0w0, noFree) - - | compileMessage (LB_SELECTSTRING{text, indexStart}) = compileStringAsLp(0x018C, SysWord.fromInt indexStart, text) - - | compileMessage (LB_DIR{attrs, fileSpec}) = compileStringAsLp(0x018D, Word32.toLargeWord(toCcbal attrs), fileSpec) - - | compileMessage LB_GETTOPINDEX = (0x018E, 0w0, 0w0, noFree) - - | compileMessage (LB_FINDSTRING{text, indexStart}) = compileStringAsLp (0x018F, SysWord.fromInt indexStart, text) - - | compileMessage LB_GETSELCOUNT = (0x0190, 0w0, 0w0, noFree) - - | compileMessage (LB_GETSELITEMS args) = compileGetSelItems(0x0191, args) - - | compileMessage (LB_SETTABSTOPS{tabs}) = compileTabStops(0x0192, tabs) - - | compileMessage LB_GETHORIZONTALEXTENT = (0x0193, 0w0, 0w0, noFree) - - | compileMessage (LB_SETHORIZONTALEXTENT{extent}) = (0x0194, SysWord.fromInt extent, 0w0, noFree) - - | compileMessage (LB_SETCOLUMNWIDTH{column}) = (0x0195, SysWord.fromInt column, 0w0, noFree) - - | compileMessage (LB_ADDFILE{fileName}) = compileStringAsLp(0x0196, 0w0, fileName) - - | compileMessage (LB_SETTOPINDEX{index}) = (0x0197, SysWord.fromInt index, 0w0, noFree) - - | compileMessage (LB_GETITEMRECT{rect=ref rect, index}) = compileGetRect(0x0198, SysWord.fromInt index, rect) - - | compileMessage (LB_GETITEMDATA{index}) = (0x0199, SysWord.fromInt index, 0w0, noFree) - - | compileMessage (LB_SETITEMDATA{index, data}) = (0x019A, SysWord.fromInt index, SysWord.fromInt data, noFree) - - | compileMessage (LB_SELITEMRANGE{select, first, last}) = - (0x019B, SysWord.fromInt(btoi select), makeLong(first, last), noFree) - - | compileMessage (LB_SETANCHORINDEX{index}) = (0x019C, SysWord.fromInt index, 0w0, noFree) - - | compileMessage LB_GETANCHORINDEX = (0x019D, 0w0, 0w0, noFree) - - | compileMessage (LB_SETCARETINDEX{index, scroll}) = (0x019E, SysWord.fromInt index, SysWord.fromInt(btoi scroll), noFree) - - | compileMessage LB_GETCARETINDEX = (0x019F, 0w0, 0w0, noFree) - - | compileMessage (LB_SETITEMHEIGHT{index, height}) = - (0x01A0, SysWord.fromInt index, makeLong(height, 0), noFree) - - | compileMessage (LB_GETITEMHEIGHT{index}) = (0x01A1, SysWord.fromInt index, 0w0, noFree) - - | compileMessage (LB_FINDSTRINGEXACT{text, indexStart}) = - compileStringAsLp(0x01A2, SysWord.fromInt indexStart, text) - - | compileMessage (LB_SETLOCALE{locale}) = (0x01A5, SysWord.fromInt locale, 0w0, noFree) - - | compileMessage LB_GETLOCALE = (0x01A6, 0w0, 0w0, noFree) - - | compileMessage (LB_SETCOUNT{items}) = (0x01A7, SysWord.fromInt items, 0w0, noFree) - - | compileMessage (LB_INITSTORAGE{items, bytes}) = (0x01A8, SysWord.fromInt items, SysWord.fromInt bytes, noFree) - - | compileMessage (LB_ITEMFROMPOINT { point = {x, y}}) = (0x01A9, 0w0, makeLong(x,y), noFree) - - | compileMessage (WM_MOUSEMOVE margs) = compileMouseMove(0x0200, margs) - - | compileMessage (WM_LBUTTONDOWN margs) = compileMouseMove(0x0201, margs) - - | compileMessage (WM_LBUTTONUP margs) = compileMouseMove(0x0202, margs) - - | compileMessage (WM_LBUTTONDBLCLK margs) = compileMouseMove(0x0203, margs) - - | compileMessage (WM_RBUTTONDOWN margs) = compileMouseMove(0x0204, margs) - - | compileMessage (WM_RBUTTONUP margs) = compileMouseMove(0x0205, margs) - - | compileMessage (WM_RBUTTONDBLCLK margs) = compileMouseMove(0x0206, margs) - - | compileMessage (WM_MBUTTONDOWN margs) = compileMouseMove(0x0207, margs) - - | compileMessage (WM_MBUTTONUP margs) = compileMouseMove(0x0208, margs) - - | compileMessage (WM_MBUTTONDBLCLK margs) = compileMouseMove(0x0209, margs) - (* -WM_MOUSEWHEEL 0x020A -*) - - | compileMessage (WM_PARENTNOTIFY { eventflag, idchild, value}) = - (0x0210, makeLong(eventflag,idchild), SysWord.fromInt value, noFree) - - | compileMessage (WM_ENTERMENULOOP {istrack}) = (0x0211, SysWord.fromInt(btoi istrack), 0w0, noFree) - - | compileMessage (WM_EXITMENULOOP {istrack}) = (0x0212, SysWord.fromInt(btoi istrack), 0w0, noFree) - -(* -WM_NEXTMENU 0x0213 -WM_SIZING 0x0214 -*) - - | compileMessage (WM_CAPTURECHANGED {newCapture}) = (0x0215, 0w0, fromHWND newCapture, noFree) -(* -WM_MOVING 0x0216 -WM_POWERBROADCAST 0x0218 -WM_DEVICECHANGE 0x0219 -*) - - | compileMessage (WM_MDICREATE{class, title, instance, x, y, cx, cy, style, cdata}) = - strAddrAsLp (0x0220, 0w0, fromMdiCreate(class,title,instance,x,y,cx,cy,style,cdata)) - - | compileMessage (WM_MDIDESTROY{child}) = - (0x0221, fromHWND child, 0w0, noFree) - - | compileMessage (WM_MDIRESTORE{child}) = - (0x0223, fromHWND child, 0w0, noFree) - - | compileMessage (WM_MDINEXT{child, flagnext}) = - (0x0224, fromHWND child, SysWord.fromInt(btoi flagnext), noFree) - - | compileMessage (WM_MDIMAXIMIZE{child}) = - (0x0225, fromHWND child, 0w0, noFree) - - | compileMessage (WM_MDITILE{tilingflag}) = (0x0226, Word32.toLargeWord(toCmdif tilingflag), 0w0, noFree) - - | compileMessage (WM_MDICASCADE{skipDisabled}) = - (0x0227, SysWord.fromInt(if skipDisabled then 2 else 0), 0w0, noFree) - - | compileMessage WM_MDIICONARRANGE = (0x0228, 0w0, 0w0, noFree) - - | compileMessage WM_MDIGETACTIVE = (0x0229, 0w0, 0w0 (* MUST be null *), noFree) - - | compileMessage (WM_MDISETMENU{frameMenu, windowMenu}) = - (0x0230, fromHMENU frameMenu, fromHMENU windowMenu, noFree) - - | compileMessage WM_ENTERSIZEMOVE = (0x0231, 0w0, 0w0, noFree) - - | compileMessage WM_EXITSIZEMOVE = (0x0232, 0w0, 0w0, noFree) - - | compileMessage (WM_DROPFILES{hDrop}) = (0x0233, fromHDROP hDrop, 0w0, noFree) - - | compileMessage WM_MDIREFRESHMENU = (0x0234, 0w0, 0w0, noFree) -(* -WM_IME_SETCONTEXT 0x0281 -WM_IME_NOTIFY 0x0282 -WM_IME_CONTROL 0x0283 -WM_IME_COMPOSITIONFULL 0x0284 -WM_IME_SELECT 0x0285 -WM_IME_CHAR 0x0286 -WM_IME_KEYDOWN 0x0290 -WM_IME_KEYUP 0x0291 -*) - | compileMessage (WM_NCMOUSEHOVER {hitTest, x, y}) = - (0x02A0, SysWord.fromInt(fromHitTest hitTest), makeXYParam(x, y), noFree) - - | compileMessage (WM_MOUSEHOVER margs) = compileMouseMove(0x02A1, margs) - - | compileMessage WM_NCMOUSELEAVE = (0x02A2, 0w0, 0w0, noFree) - - | compileMessage WM_MOUSELEAVE = (0x02A3, 0w0, 0w0, noFree) - - | compileMessage WM_CUT = (0x0300, 0w0, 0w0, noFree) - - | compileMessage WM_COPY = (0x0301, 0w0, 0w0, noFree) - - | compileMessage WM_PASTE = (0x0302, 0w0, 0w0, noFree) - - | compileMessage WM_CLEAR = (0x0303, 0w0, 0w0, noFree) - - | compileMessage WM_UNDO = (0x0304, 0w0, 0w0, noFree) - - | compileMessage (WM_RENDERFORMAT {format}) = (0x0305, SysWord.fromInt(toCcbf format), 0w0, noFree) - - | compileMessage WM_RENDERALLFORMATS = (0x0306, 0w0, 0w0, noFree) - - | compileMessage WM_DESTROYCLIPBOARD = (0x0307, 0w0, 0w0, noFree) - - | compileMessage WM_DRAWCLIPBOARD = (0x0308, 0w0, 0w0, noFree) - - | compileMessage (WM_PAINTCLIPBOARD{clipboard}) = - (0x030A, fromHWND clipboard, 0w0, noFree) - - | compileMessage (WM_VSCROLLCLIPBOARD{viewer, code, position}) = - (0x030A, fromHWND viewer, makeLong(code, position), noFree) - - | compileMessage (WM_SIZECLIPBOARD{viewer}) = (0x030B, 0w0, fromHWND viewer, noFree) - - | compileMessage (WM_ASKCBFORMATNAME {length, ...}) = compileStringRequest(0x030C, SysWord.fromInt length, length) - - | compileMessage (WM_CHANGECBCHAIN{removed, next}) = - (0x030D, fromHWND removed, fromHWND next, noFree) - - | compileMessage (WM_HSCROLLCLIPBOARD{viewer, code, position}) = - (0x030E, fromHWND viewer, makeLong(code, position), noFree) - - | compileMessage WM_QUERYNEWPALETTE = (0x030F, 0w0, 0w0, noFree) - - | compileMessage (WM_PALETTEISCHANGING{realize}) = - (0x0310, fromHWND realize, 0w0, noFree) - - | compileMessage (WM_PALETTECHANGED{palChg}) = - (0x0311, fromHWND palChg, 0w0, noFree) - - | compileMessage (WM_HOTKEY{id}) = (0x0312, SysWord.fromInt id, 0w0, noFree) - - | compileMessage (WM_PRINT{hdc, flags}) = - (0x0317, fromHDC hdc, Word32.toLargeWord(toCwmpl flags), noFree) - - | compileMessage (WM_PRINTCLIENT{hdc, flags}) = - (0x0318, fromHDC hdc, Word32.toLargeWord(toCwmpl flags), noFree) - - | compileMessage (FINDMSGSTRING args) = compileFindMsg args - - | compileMessage (WM_SYSTEM_OTHER{uMsg, wParam, lParam}) = (uMsg, wParam, lParam, noFree) - - | compileMessage (WM_USER{uMsg, wParam, lParam}) = (uMsg, wParam, lParam, noFree) - - | compileMessage (WM_APP{uMsg, wParam, lParam}) = (uMsg, wParam, lParam, noFree) - - | compileMessage (WM_REGISTERED{uMsg, wParam, lParam}) = (uMsg, wParam, lParam, noFree) - - local - val msgStruct = cStruct6(cHWND, cUint, cUINT_PTRw, cUINT_PTRw, cDWORD, cPoint) - val { load=loadMsg, store=storeMsg, ctype={size=msgSize, ... }, ... } = - breakConversion msgStruct - in - (* Store the address of the message in the memory. *) - fun storeMessage(v: voidStar, {msg, hwnd, time, pt}: MSG) = - let - val (msgId: int, wParam, lParam, freeMem) = compileMessage msg - val mem = Memory.malloc msgSize - val f = storeMsg(mem, (hwnd, msgId, wParam, lParam, Int.fromLarge(Time.toMilliseconds time), pt)) - in - setAddress(v, 0w0, mem); - fn () => (freeMem(); f(); Memory.free mem) - end - - fun loadMessage(v: voidStar): MSG = - let - val (hWnd, msgId, wParam, lParam, t, pt) = loadMsg v - val msg = decompileMessage(msgId, wParam, lParam) - (*val () = - case msg of WM_USER _ => TextIO.print(Int.toString msgId ^ "\n") | _ => ()*) - in - { - msg = msg, - hwnd = hWnd, - time = Time.fromMilliseconds(LargeInt.fromInt t), - pt = pt - } - end - - val LPMSG: MSG conversion = - makeConversion { load = loadMessage, store = storeMessage, ctype=LowLevel.cTypePointer } - - val msgSize = msgSize - end - - (* Update the lParam/wParam values from the values in a returned message. This is needed - if an ML callback makes a modification that has to be passed back to C. *) - (* TODO: The rest of these. *) - local - fun copyString(_, _, 0) = () (* If the length is zero do nothing *) - | copyString(ptr: voidStar, s: string, length: int) = - let - open Memory - fun copyChar(i, c) = - if i < length then set8(ptr, Word.fromInt i, Byte.charToByte c) else () - in - CharVector.appi copyChar s; - (* Null terminate either at the end of the string or the buffer *) - set8(ptr, Word.fromInt(Int.min(size s + 1, length-1)), 0w0) - end - in - fun updateParamsFromMessage(msg: Message, wp: SysWord.word, lp: SysWord.word): unit = - case msg of - WM_GETTEXT{text = ref t, ...} => copyString(toAddr lp, t, SysWord.toInt wp) - | WM_ASKCBFORMATNAME{formatName = ref t, ...} => copyString(toAddr lp, t, SysWord.toInt wp) - | EM_GETLINE{result = ref t, size, ...} => copyString(toAddr lp, t, size) - | EM_GETRECT {rect = ref r} => toCrect(toAddr lp, r) - | EM_GETSEL args => updateGetSelParms({wp=wp, lp=lp}, args) - | CB_GETEDITSEL args => updateGetSelParms({wp=wp, lp=lp}, args) - | CB_GETLBTEXT {text = ref t, length, ...} => copyString(toAddr lp, t, length) - | CB_GETDROPPEDCONTROLRECT {rect = ref r} => toCrect(toAddr lp, r) - | SBM_GETRANGE {minPos=ref minPos, maxPos=ref maxPos} => - (ignore(storeInt(toAddr wp, minPos)); ignore(storeInt(toAddr lp, maxPos))) - | SBM_GETSCROLLINFO args => updateScrollInfo({wp=wp, lp=lp}, args) - | LB_GETTEXT {text = ref t, length, ...} => copyString(toAddr lp, t, length) - | LB_GETSELITEMS args => updateGetSelItemsParms({wp=wp, lp=lp}, args) - | LB_GETITEMRECT{rect = ref r, ...} => toCrect(toAddr lp, r) - | WM_NCCALCSIZE { newrect = ref r, ...} => toCrect(toAddr lp, r) (* This sets the first rect *) - | WM_MEASUREITEM args => updateMeasureItemParms({wp=wp, lp=lp}, args) - | WM_GETMINMAXINFO args => updateMinMaxParms({wp=wp, lp=lp}, args) - | WM_WINDOWPOSCHANGING args => updateWindowPosChangingParms({wp=wp, lp=lp}, args) - (* | WM_NOTIFY{ notification=TTN_GETDISPINFO(ref s), ...} => - (* This particular notification allows the result to be fed - back in several ways. We copy into the char array. *) - assign charArray80 (offset 1 (Cpointer Cvoid) (offset 1 nmhdr (deref lp))) - (toCcharArray80 s) *) - - | _ => () - end - - (* Update the message contents from the values of wParam/lParam. This is used - when a message has been sent or passed into C code that may have updated - the message contents. Casts certain message results to HGDIOBJ. *) - fun messageReturnFromParams(msg: Message, wp: SysWord.word, lp: SysWord.word, reply: SysWord.word): LRESULT = - let - val () = - (* For certain messages we need to extract the reply from the arguments. *) - case msg of - WM_GETTEXT{text, ...} => - text := (if reply = 0w0 then "" else fromCstring(toAddr lp)) - | WM_ASKCBFORMATNAME{formatName, ...} => - formatName := (if reply = 0w0 then "" else fromCstring(toAddr lp)) - | EM_GETLINE{result, ...} => - result := (if reply = 0w0 then "" else fromCstring(toAddr lp)) - | EM_GETRECT { rect } => rect := fromCrect(toAddr lp) - | EM_GETSEL args => updateGetSelFromWpLp(args, {wp=wp, lp=lp}) - | CB_GETEDITSEL args => updateGetSelFromWpLp(args, {wp=wp, lp=lp}) - | CB_GETLBTEXT {text, ...} => - text := (if reply = 0w0 then "" else fromCstring(toAddr lp)) - | CB_GETDROPPEDCONTROLRECT { rect } => rect := fromCrect(toAddr lp) - | SBM_GETRANGE {minPos, maxPos} => (minPos := loadInt(toAddr wp); maxPos := loadInt(toAddr lp)) - - | SBM_GETSCROLLINFO {info, ...} => - let - val ({minPos, maxPos, pageSize, pos, trackPos}, _) = toScrollInfo lp - in - info := {minPos = minPos, maxPos = maxPos, pageSize = pageSize, - pos = pos, trackPos = trackPos} - end - - | LB_GETTEXT {text, ...} => - text := (if reply = 0w0 then "" else fromCstring(toAddr lp)) - - | LB_GETSELITEMS args => updateGetSelItemsFromWpLp(args, {wp=wp, lp=lp, reply=reply}) - | LB_GETITEMRECT{rect, ...} => rect := fromCrect(toAddr lp) (* This also has an item index *) - | WM_NCCALCSIZE { newrect, ...} => - (* Whatever the value of "validarea" we just look at the first rectangle. *) - newrect := fromCrect (toAddr lp) - - | WM_GETMINMAXINFO args => updateMinMaxFromWpLp(args, {wp=wp, lp=lp}) - - | WM_WINDOWPOSCHANGING wpCh => - updateCfromMLwmWindowPosChanging({wp=wp, lp=lp}, wpCh) - - | WM_MEASUREITEM args => updateMeasureItemFromWpLp(args, {wp=wp, lp=lp}) - | _ => () - - val fromHgdi = handleOfVoidStar o toAddr - in - (* We need to "cast" some of the results. *) - case msg of - WM_GETFONT => LRESHANDLE(fromHgdi reply) - | WM_GETICON _ => LRESHANDLE(fromHgdi reply) - | WM_SETICON _ => LRESHANDLE(fromHgdi reply) - | BM_GETIMAGE _ => LRESHANDLE(fromHgdi reply) - | BM_SETIMAGE _ => LRESHANDLE(fromHgdi reply) - | STM_GETICON => LRESHANDLE(fromHgdi reply) - | STM_GETIMAGE _ => LRESHANDLE(fromHgdi reply) - | STM_SETICON _ => LRESHANDLE(fromHgdi reply) - | STM_SETIMAGE _ => LRESHANDLE(fromHgdi reply) - | _ => LRESINT (SysWord.toInt reply) - end - - (* Window callback table. *) - local - type callback = HWND * int * SysWord.word * SysWord.word -> SysWord.word - (* *) - datatype tableEntry = TableEntry of {hWnd: HWND, callBack: callback} - (* Windows belong to the thread that created them so each thread has - its own list of windows. Any thread could have one outstanding - callback waiting to be assigned to a window that is being created. *) - val threadWindows = Universal.tag(): tableEntry list Universal.tag - val threadOutstanding = Universal.tag(): callback option Universal.tag - - (* This message is used to test if we are using the Poly callback. We use - the same number as MFC uses so it's unlikely that any Windows class will - use this. *) - val WMTESTPOLY = 0x0360 - fun getWindowList (): tableEntry list = - getOpt (Thread.Thread.getLocal threadWindows, []) - and setWindowList(t: tableEntry list): unit = - Thread.Thread.setLocal(threadWindows, t) - - fun getOutstanding(): callback option = - Option.join(Thread.Thread.getLocal threadOutstanding) - and setOutstanding(t: callback option): unit = - Thread.Thread.setLocal(threadOutstanding, t) - - (* Get the callback for this window. If it's the first time we've - had a message for this window we need to use the outstanding callback. *) - fun getCallback(hw: HWND): callback = - case List.find (fn (TableEntry{hWnd, ...}) => - hw = hWnd) (getWindowList ()) - of - SOME(TableEntry{callBack, ...}) => callBack - | NONE => (* See if this has just been set up. *) - (case getOutstanding() of - SOME cb => (* It has. We now know the window handle so link it up. *) - ( - setWindowList(TableEntry{hWnd=hw, callBack=cb} :: getWindowList ()); - setOutstanding NONE; - cb - ) - | NONE => raise Fail "No callback found" - ) - - fun removeCallback(hw: HWND): unit = - setWindowList(List.filter - (fn(TableEntry{hWnd, ...}) => hw <> hWnd) (getWindowList ())) - - fun mainCallbackFunction(hw:HWND, msgId:int, wParam:SysWord.word, lParam:SysWord.word): SysWord.word = - if msgId = WMTESTPOLY - then SysWord.fromInt ~1 (* This tests whether we are already installed. *) - else getCallback hw (hw, msgId, wParam, lParam) - - val mainWinProc = - buildCallback4withAbi(winAbi, (cHWND, cUint, cUINT_PTRw, cUINT_PTRw), cUINT_PTRw) - mainCallbackFunction - - val WNDPROC: (HWND * int * SysWord.word * SysWord.word -> SysWord.word) closure conversion = cFunction - - (* This is used to set the window proc. The result is also a window proc. *) - val SetWindowLong = winCall3 (user "SetWindowLongPtrA") (cHWND, cInt, WNDPROC) cPointer - val CallWindowProc = winCall5 (user "CallWindowProcA") (cPointer, cHWND, cUint, cUINT_PTRw, cUINT_PTRw) cUINT_PTRw - - in - val mainWinProc = mainWinProc - and removeCallback = removeCallback - - fun windowCallback (call: HWND * Message * 'a -> LRESULT * 'a, init: 'a): - (HWND * int * SysWord.word * SysWord.word -> SysWord.word) = - let - val state = ref init - - fun callBack(h: HWND, uMsg:int, wParam: SysWord.word, lParam: SysWord.word): SysWord.word = - let - val msg = decompileMessage(uMsg, wParam, lParam) - handle exn => - ( - print(concat["Exception with message ", - Int.toString uMsg, exnMessage exn ]); - WM_NULL - ) - val (result, newState) = - call(h, msg, !state) - handle exn => - ( - print(concat["Exception with message ", - PolyML.makestring msg, - exnMessage exn ]); - (LRESINT 0, !state) - ) - in - (* For a few messages we have to update the value pointed to - by wParam/lParam after we've handled it. *) - updateParamsFromMessage(msg, wParam, lParam); - state := newState; - (* If our callback returned SOME x we use that as the result, - otherwise we call the default. We do it this way rather - than having the caller call DefWindowProc because that - would involve recompiling the message and we can't - guarantee that all the parameters of the original message - would be correctly set. *) - case result of - LRESINT res => SysWord.fromInt res - | LRESHANDLE res => fromAddr(voidStarOfHandle res) - end; - in - callBack - end - - (* When we first set up a callback we don't know the window handle so we use null. *) - fun setCallback(call, init) = setOutstanding(SOME(windowCallback(call, init))) - - val sendMsg = winCall4(user "SendMessageA") (cHWND, cUint, cUINT_PTRw, cUINT_PTRw) cUINT_PTRw - - fun subclass(w: HWND, f: HWND * Message * 'a -> LRESULT * 'a, init: 'a): - (HWND * Message -> LRESULT) = - let - - val testPoly = sendMsg(w, WMTESTPOLY, 0w0, 0w0) - - fun addCallback (hWnd, call: HWND * Message * 'a -> LRESULT * 'a, init: 'a): unit = - setWindowList( - TableEntry{ hWnd = hWnd, callBack = windowCallback(call, init) } :: getWindowList ()) - - val oldDefProc: callback = - if SysWord.toIntX testPoly = ~1 - then (* We already have our Window proc installed. *) - let - (* We should have a callback already installed. *) - val oldCallback = getCallback w - in - removeCallback w; - addCallback(w, f, init); - oldCallback - end - else - let - (* Set up the new window proc and get the existing one. *) - val oldWProc = SetWindowLong(w, ~4, mainWinProc) - - val defProc = - fn (h, m, w, l) => CallWindowProc(oldWProc, h, m, w, l) - in - (* Remove any existing callback function and install the new one. *) - removeCallback w; - addCallback(w, f, init); - defProc - end - in - fn (hw: HWND, msg: Message) => - let - val (m: int, w: SysWord.word, l: SysWord.word, freeMem) = compileMessage msg - val res: SysWord.word = oldDefProc(hw, m, w, l) - in - messageReturnFromParams(msg, w, l, res) - before freeMem() - end - end - end - - - (* Keyboard operations on modeless dialogues are performed by isDialogMessage. - We keep a list of modeless dialogues and process them in the main - message loop. - This also has an important function for dialogues created by FindText. - They allocate memory which can't be freed until the dialogue has gone. *) - local - val modeless = ref [] - val isDialogMessage = winCall2 (user "IsDialogMessage") (cHWND, cPointer) cBool - val isWindow = winCall1 (user "IsWindow") (cHWND) cBool - in - fun addModelessDialogue (hWnd: HWND, doFree) = - modeless := (hWnd, doFree) :: (!modeless) - - fun isDialogueMsg(msg: voidStar) = - let - (* Take this opportunity to filter any dialogues that have gone away. *) - (* If this has gone away run any "free" function.*) - fun filter(w, f) = - if isWindow w - then true (* Still there *) - else (case f of NONE => () | SOME f => f(); false) - in - modeless := List.filter filter (!modeless); - (* See if isDialogMessage returns true for any of these. *) - List.foldl (fn ((w, _), b) => b orelse isDialogMessage(w, msg)) false (!modeless) - end - end - - datatype PeekMessageOptions = PM_NOREMOVE | PM_REMOVE - (* TODO: We can also include PM_NOYIELD. *) - - val peekMsg = winCall5(user "PeekMessageA") (cPointer, cHWND, cUint, cUint, cUint) cBool - - fun PeekMessage(hWnd: HWND option, wMsgFilterMin: int, - wMsgFilterMax: int, remove: PeekMessageOptions): MSG option = - let - val msg = malloc msgSize - - val opts = case remove of PM_REMOVE => 1 | PM_NOREMOVE => 0 - val res = peekMsg(msg, getOpt(hWnd, hNull), wMsgFilterMin, wMsgFilterMax, opts) - in - (if not res - then NONE - else SOME(loadMessage msg)) before free msg - end; - - (* This was originally implemented before we had threads and used a RTS call to - pick up the messages. *) - - val WaitMessage = winCall0 (user "WaitMessage") () cBool - - local - val getMsg = winCall4(user "GetMessage") (cPointer, cHWND, cUint, cUint) cBool - in - fun GetMessage(hWnd: HWND option, wMsgFilterMin: int, wMsgFilterMax: int): MSG = - let - val msg = malloc msgSize - val res = getMsg(msg, getOpt(hWnd, hNull), wMsgFilterMin, wMsgFilterMax) - in - loadMessage msg before free msg - end - end - - (* Wait for messages and dispatch them. It only returns when a QUIT message - has been received. *) - local - val peekMsg = winCall5(user "PeekMessageA") (cPointer, cHWND, cUint, cUint, cUint) cBool - val transMsg = winCall1(user "TranslateMessage") (cPointer) cBool - val dispMsg = winCall1(user "DispatchMessageA") (cPointer) cInt - in - fun RunApplication() = - let - val msg = malloc msgSize - val res = peekMsg(msg, hNull, 0, 0, 1) - in - if not res - then (* There's no message at the moment. Wait for one. *) - (free msg; WaitMessage(); RunApplication()) - else case loadMessage msg of - { msg = WM_QUIT{exitcode}, ...} => (free msg; exitcode) - | _ => - ( - if isDialogueMsg msg then () - else ( transMsg msg; dispMsg msg; () ); - free msg; - RunApplication() - ) - end - end - - local - val sendMsg = winCall4(user "SendMessageA") (cHWND, cUint, cUINT_PTRw, cUINT_PTRw) cUINT_PTRw - in - fun SendMessage(hWnd: HWND, msg: Message) = - let - val (msgId, wp, lp, freeMem) = compileMessage msg - val reply = sendMsg(hWnd, msgId, wp, lp) - in - (* Update any result values and cast the results if necessary. *) - messageReturnFromParams(msg, wp, lp, reply) - before freeMem() - end - end - - local - val postMessage = - winCall4(user "PostMessageA") (cHWND, cUint, cUINT_PTRw, cUINT_PTRw) - (successState "PostMessage") - in - fun PostMessage(hWnd: HWND, msg: Message) = - let - val (msgId, wp, lp, _) = compileMessage msg - (* This could result in a memory leak. *) - in - postMessage(hWnd, msgId, wp, lp) - end - end - - val HWND_BROADCAST: HWND = handleOfVoidStar(sysWord2VoidStar 0wxffff) - - val PostQuitMessage = winCall1 (user "PostQuitMessage") cInt cVoid - val RegisterWindowMessage = winCall1 (user "RegisterWindowMessageA") (cString) cUint - val InSendMessage = winCall0 (user "InSendMessage") () cBool - val GetInputState = winCall0 (user "GetInputState") () cBool - - local - val getMessagePos = winCall0 (user "GetMessagePos") () cDWORDw - in - fun GetMessagePos(): POINT = - let - val r = getMessagePos () - in - { x = Word.toInt(LOWORD r), y = Word.toInt(HIWORD r) } - end - end - - val GetMessageTime = Time.fromMilliseconds o LargeInt.fromInt o - winCall0 (user "GetMessageTime") () cLong - - datatype QueueStatus = - QS_KEY | QS_MOUSEMOVE | QS_MOUSEBUTTON | QS_POSTMESSAGE | QS_TIMER | - QS_PAINT | QS_SENDMESSAGE | QS_HOTKEY | QS_ALLPOSTMESSAGE - local - val tab = [ - (QS_KEY, 0wx0001), - (QS_MOUSEMOVE, 0wx0002), - (QS_MOUSEBUTTON, 0wx0004), - (QS_POSTMESSAGE, 0wx0008), - (QS_TIMER, 0wx0010), - (QS_PAINT, 0wx0020), - (QS_SENDMESSAGE, 0wx0040), - (QS_HOTKEY, 0wx0080), - (QS_ALLPOSTMESSAGE, 0wx0100) - ] - in - val (fromQS, toQS) = tableSetLookup(tab, NONE) - end - - val QS_MOUSE = [QS_MOUSEMOVE, QS_MOUSEBUTTON] - val QS_INPUT = QS_KEY :: QS_MOUSE - val QS_ALLEVENTS = QS_POSTMESSAGE :: QS_TIMER :: QS_PAINT :: QS_HOTKEY :: QS_INPUT - val QS_ALLINPUT = QS_SENDMESSAGE :: QS_ALLEVENTS - - local - val getQueueStatus = winCall1 (user "GetQueueStatus") (cUintw) cDWORDw - in - fun GetQueueStatus flags = - let - val res = getQueueStatus(fromQS flags) - in - (* The RTS uses PeekMessage internally so the "new messages" - value in the LOWORD is meaningless. *) - toQS(Word32.fromLargeWord(Word.toLargeWord(HIWORD(res)))) - end - end - -(* -BroadcastSystemMessage -DispatchMessage -GetMessageExtraInfo -InSendMessageEx - NT 5.0 and Windows 98 -PostThreadMessage -ReplyMessage -SendAsyncProc -SendMessageCallback -SendMessageTimeout -SendNotifyMessage -SetMessageExtraInfo -TranslateMessage - -Obsolete Functions - -PostAppMessage -SetMessageQueue - -*) - end -end; diff --git a/mlsource/extra/Win/MessageBox.sml b/mlsource/extra/Win/MessageBox.sml deleted file mode 100644 index ad4acc5a..00000000 --- a/mlsource/extra/Win/MessageBox.sml +++ /dev/null @@ -1,159 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) -structure MessageBox : -sig - type HWND - - val IDABORT : int - val IDCANCEL : int - val IDCLOSE : int - val IDHELP : int - val IDIGNORE : int - val IDNO : int - val IDOK : int - val IDRETRY : int - val IDYES : int - - structure MessageBoxStyle : - sig - include BIT_FLAGS - val MB_ABORTRETRYIGNORE : flags - val MB_APPLMODAL : flags - val MB_DEFAULT_DESKTOP_ONLY : flags - val MB_DEFBUTTON1 : flags - val MB_DEFBUTTON2 : flags - val MB_DEFBUTTON3 : flags - val MB_DEFBUTTON4 : flags - val MB_HELP : flags - val MB_ICONASTERISK : flags - val MB_ICONERROR : flags - val MB_ICONEXCLAMATION : flags - val MB_ICONHAND : flags - val MB_ICONINFORMATION : flags - val MB_ICONQUESTION : flags - val MB_ICONSTOP : flags - val MB_ICONWARNING : flags - val MB_NOFOCUS : flags - val MB_OK : flags - val MB_OKCANCEL : flags - val MB_RETRYCANCEL : flags - val MB_RIGHT : flags - val MB_RTLREADING : flags - val MB_SERVICE_NOTIFICATION : flags - val MB_SERVICE_NOTIFICATION_NT3X : flags - val MB_SETFOREGROUND : flags - val MB_SYSTEMMODAL : flags - val MB_TASKMODAL : flags - val MB_TOPMOST : flags - val MB_USERICON : flags - val MB_YESNO : flags - val MB_YESNOCANCEL : flags - end - - val MessageBox : HWND option * string option * string option * MessageBoxStyle.flags -> int - val MessageBeep: MessageBoxStyle.flags -> unit - -end -= -struct - local - open Foreign - open Base - open Globals - in - type HWND = HWND - - structure MessageBoxStyle = - struct - open Word32 - type flags = word - val toWord = toLargeWord - and fromWord = fromLargeWord - val flags = List.foldl (fn (a, b) => orb(a,b)) 0w0 - fun allSet (fl1, fl2) = andb(fl1, fl2) = fl1 - fun anySet (fl1, fl2) = andb(fl1, fl2) <> 0w0 - fun clear (fl1, fl2) = andb(notb fl1, fl2) - - val MB_OK = 0wx00000000 - val MB_OKCANCEL = 0wx00000001 - val MB_ABORTRETRYIGNORE = 0wx00000002 - val MB_YESNOCANCEL = 0wx00000003 - val MB_YESNO = 0wx00000004 - val MB_RETRYCANCEL = 0wx00000005 - - val MB_ICONHAND = 0wx00000010 - val MB_ICONQUESTION = 0wx00000020 - val MB_ICONEXCLAMATION = 0wx00000030 - val MB_ICONASTERISK = 0wx00000040 - val MB_USERICON = 0wx00000080 - val MB_ICONWARNING = MB_ICONEXCLAMATION - val MB_ICONERROR = MB_ICONHAND - - val MB_ICONINFORMATION = MB_ICONASTERISK - val MB_ICONSTOP = MB_ICONHAND - - val MB_DEFBUTTON1 = 0wx00000000 - val MB_DEFBUTTON2 = 0wx00000100 - val MB_DEFBUTTON3 = 0wx00000200 - val MB_DEFBUTTON4 = 0wx00000300 - - val MB_APPLMODAL = 0wx00000000 - val MB_SYSTEMMODAL = 0wx00001000 - val MB_TASKMODAL = 0wx00002000 - val MB_HELP = 0wx00004000 (* Help Button *) - - val MB_NOFOCUS = 0wx00008000 - val MB_SETFOREGROUND = 0wx00010000 - val MB_DEFAULT_DESKTOP_ONLY = 0wx00020000 - - val MB_TOPMOST = 0wx00040000 - val MB_RIGHT = 0wx00080000 - val MB_RTLREADING = 0wx00100000 - - val MB_SERVICE_NOTIFICATION = 0wx00200000 - val MB_SERVICE_NOTIFICATION_NT3X = 0wx00040000 - - val all = flags[MB_OK, MB_OKCANCEL, MB_ABORTRETRYIGNORE, MB_YESNOCANCEL, - MB_YESNO, MB_RETRYCANCEL, MB_ICONHAND, MB_ICONQUESTION, - MB_ICONEXCLAMATION, MB_ICONASTERISK, MB_USERICON, MB_DEFBUTTON1, - MB_DEFBUTTON2, MB_DEFBUTTON3, MB_DEFBUTTON4, MB_APPLMODAL, - MB_SYSTEMMODAL, MB_TASKMODAL, MB_HELP, MB_NOFOCUS, MB_SETFOREGROUND, - MB_DEFAULT_DESKTOP_ONLY, MB_TOPMOST, MB_RIGHT, MB_RTLREADING, - MB_SERVICE_NOTIFICATION, MB_SERVICE_NOTIFICATION_NT3X] - - val intersect = List.foldl (fn (a, b) => andb(a,b)) all - val cConvert: flags conversion = cUintw - end - - (* Return values from a message box. Should this be a datatype? *) - val IDOK = 1 - val IDCANCEL = 2 - val IDABORT = 3 - val IDRETRY = 4 - val IDIGNORE = 5 - val IDYES = 6 - val IDNO = 7 - val IDCLOSE = 8 - val IDHELP = 9 - - - val MessageBox = winCall4 (user "MessageBoxA") (cHWNDOPT, STRINGOPT, STRINGOPT, MessageBoxStyle.cConvert) cInt - val MessageBeep = winCall1 (user "MessageBeep") MessageBoxStyle.cConvert (successState "MessageBeep") - - end -end; diff --git a/mlsource/extra/Win/Metafile.sml b/mlsource/extra/Win/Metafile.sml deleted file mode 100644 index 851b4231..00000000 --- a/mlsource/extra/Win/Metafile.sml +++ /dev/null @@ -1,272 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Metafile : - sig - type HENHMETAFILE - type HMETAFILE - type HDC (*= Base.HDC*) - type RECT = { top: int, left: int, bottom: int, right: int } - type SIZE = { cx: int, cy: int } - datatype MapMode = datatype Transform.MapMode - type METAFILEPICT = {mm: MapMode, size: SIZE, hMF: HMETAFILE} - - type ENHMETAHEADER = - { - bounds: RECT, frame: RECT, fileSize: int, records: int, - handles: int, palEntries: int, resolutionPixels: SIZE, - resolutionMM: SIZE, openGL: bool - } - - val CloseEnhMetaFile : HDC -> HENHMETAFILE - val CloseMetaFile : HDC -> HMETAFILE - val CopyEnhMetaFile : HENHMETAFILE * string -> HENHMETAFILE - val CopyMetaFile : HMETAFILE * string -> HMETAFILE - val CreateEnhMetaFile : - HDC * string option * RECT * - {pictureName: string, applicationName: string} option -> HDC - val CreateMetaFile : string option -> HDC - val DeleteEnhMetaFile : HENHMETAFILE -> unit - val DeleteMetaFile : HMETAFILE -> unit - val GdiComment : HDC * Word8Vector.vector -> unit - val GetEnhMetaFile : string -> HENHMETAFILE - val GetEnhMetaFileBits : HENHMETAFILE -> Word8Vector.vector - val GetEnhMetaFileDescription : - HENHMETAFILE -> {pictureName: string, applicationName: string} option - val GetEnhMetaFileHeader : HENHMETAFILE -> ENHMETAHEADER - val GetMetaFile : string -> HMETAFILE - val GetMetaFileBitsEx : HMETAFILE -> Word8Vector.vector - val GetWinMetaFileBits : - HENHMETAFILE * Transform.MapMode * HDC -> Word8Vector.vector - val PlayEnhMetaFile : HDC * HENHMETAFILE * RECT -> unit - val PlayMetaFile : HDC * HMETAFILE -> unit - val SetEnhMetaFileBits : Word8Vector.vector -> HENHMETAFILE - val SetWinMetaFileBits : - Word8Vector.vector * HDC * {size: SIZE, mapMode: MapMode} option -> HENHMETAFILE - - end = -struct - local - open Foreign Base GdiBase - in - datatype MapMode = datatype Transform.MapMode - type HENHMETAFILE = HENHMETAFILE and HMETAFILE = HMETAFILE - type HDC = Base.HDC - type SIZE = SIZE and RECT = RECT - type METAFILEPICT = METAFILEPICT - - (* TODO: Many of these should check for NULL as a result indicating an error. *) - val CloseEnhMetaFile = winCall1 (gdi "CloseEnhMetaFile") (cHDC) cHENHMETAFILE - and CloseMetaFile = winCall1 (gdi "CloseMetaFile") (cHDC) cHMETAFILE - and CopyEnhMetaFile = winCall2 (gdi "CopyEnhMetaFileA") (cHENHMETAFILE, cString) cHENHMETAFILE - and CopyMetaFile = winCall2 (gdi "CopyMetaFileA") (cHMETAFILE, cString) cHMETAFILE - and CreateMetaFile = winCall1 (gdi "CreateMetaFileA") (STRINGOPT) cHDC - and DeleteEnhMetaFile = - winCall1 (gdi "DeleteEnhMetaFile") (cHENHMETAFILE) (successState "DeleteEnhMetaFile") - and DeleteMetaFile = winCall1 (gdi "DeleteMetaFile") (cHMETAFILE) (successState "DeleteMetaFile") - and GetEnhMetaFile = winCall1 (gdi "GetEnhMetaFileA") (cString) cHENHMETAFILE - and GetMetaFile = winCall1 (gdi "GetMetaFileA") (cString) cHMETAFILE - and PlayEnhMetaFile = winCall3(gdi "PlayEnhMetaFile") (cHDC, cHENHMETAFILE, cConstStar cRect) - (successState "PlayEnhMetaFile") - and PlayMetaFile = winCall2(gdi "PlayMetaFile") (cHDC, cHMETAFILE) (successState "PlayMetaFile") - - local - val cemf = winCall4 (gdi "CreateEnhMetaFileA") (cHDC, STRINGOPT, cConstStar cRect, cPointer) cHDC - in - fun CreateEnhMetaFile(hdc, name, r, NONE) = cemf(hdc, name, r, Memory.null) - | CreateEnhMetaFile(hdc, name, r, SOME{applicationName, pictureName}) = - let - val appSize = size applicationName and pictSize = size pictureName - open Memory - val buff = malloc (Word.fromInt(appSize + pictSize + 3)) - in - (* The two strings are copied to the buffer with a null between and two - nulls at the end. *) - copyStringToMem(buff, 0, applicationName); - copyStringToMem(buff, appSize+1, pictureName); - set8(buff, Word.fromInt(appSize + pictSize + 2), 0w0); - (cemf(hdc, name, r, buff) - handle ex => (free buff; raise ex)) before free buff - end - end - - local - val gdiComment = winCall3 (gdi "GdiComment") (cHDC, cUint, cPointer) (successState "GdiComment") - in - fun GdiComment(hdc, v) = - let - val vecsize = Word8Vector.length v - val buff = toCWord8vec v - in - gdiComment (hdc, vecsize, buff) handle ex => (Memory.free buff; raise ex); - Memory.free buff - end - end - - local - val gemfb = winCall3 (gdi "GetEnhMetaFileBits") (cHENHMETAFILE, cUint, cPointer) - (cPOSINT "GetEnhMetaFileBits") - in - fun GetEnhMetaFileBits(hemf: HENHMETAFILE): Word8Vector.vector = - let - (* Call with a NULL buffer to find out how big it is. *) - open Memory - val size = gemfb(hemf, 0, Memory.null) - val buff = malloc(Word.fromInt size) - val res = gemfb(hemf, size, buff) handle ex => (free buff; raise ex) - in - fromCWord8vec(buff, size) before free buff - end - end - - local - val gemfb = winCall3 (gdi "GetMetaFileBitsEx") (cHMETAFILE, cUint, cPointer) - (cPOSINT "GetMetaFileBitsEx") - in - fun GetMetaFileBitsEx(hemf: HMETAFILE): Word8Vector.vector = - let - (* Call with a NULL buffer to find out how big it is. *) - open Memory - val size = gemfb(hemf, 0, Memory.null) - val buff = malloc(Word.fromInt size) - val res = gemfb(hemf, size, buff) handle ex => (free buff; raise ex) - in - fromCWord8vec(buff, size) before free buff - end - end - - - local - val gemfd = winCall3 (gdi "GetEnhMetaFileDescriptionA") (cHENHMETAFILE, cUint, cPointer) cInt - (* It's supposed to return a uint but GDI_ERROR is -1 *) - in - fun GetEnhMetaFileDescription(hemf: HENHMETAFILE) = - (* Call with a NULL buffer to find out how big it is. *) - case gemfd(hemf, 0, Memory.null) of - 0 => NONE (* No error - simply no description. *) - | len => - if len < 0 then raiseSysErr() - else - let - (* The application and picture names are encoded as a pair. *) - open Memory - infix 6 ++ - val buff = malloc (Word.fromInt len) - val res = gemfd(hemf, len, buff) - val str1 = fromCstring buff - val str2 = fromCstring(buff ++ Word.fromInt (size str1 +1)) - in - SOME {applicationName=str1, pictureName=str2} - end - end - - local - val setEnhMetaFileBits = winCall2 (gdi "SetEnhMetaFileBits") (cUint, cPointer) cHENHMETAFILE - in - fun SetEnhMetaFileBits(v: Word8Vector.vector): HENHMETAFILE = - let - val mem = toCWord8vec v - in - (setEnhMetaFileBits (Word8Vector.length v, mem) - handle ex => (Memory.free mem; raise ex)) before Memory.free mem - end - end - - local - val gwmfb = winCall5 (gdi "GetWinMetaFileBits") (cHENHMETAFILE, cUint, cPointer, cMAPMODE, cHDC) - (cPOSINT "GetWinMetaFileBits") - in - fun GetWinMetaFileBits(hemf, mapMode, hdc) = - let - (* Call with a null pointer to get the size. *) - open Memory - val size = gwmfb(hemf, 0, null, mapMode, hdc) - val buff = malloc (Word.fromInt size) - val _ = gwmfb(hemf, size, buff, mapMode, hdc) - handle ex => (free buff; raise ex) - in - fromCWord8vec(buff, size) before free buff - end - end - - local - val swmfb = winCall4 (gdi "SetWinMetaFileBits") (cUint, cPointer, cHDC, cOptionPtr(cConstStar cMETAFILEPICT)) cHENHMETAFILE - in - fun SetWinMetaFileBits(v, hdc, opts) = - let - val optmfp = - case opts of - NONE => NONE - | SOME {size, mapMode} => SOME {mm=mapMode, size=size, hMF=hgdiObjNull} - val mem = toCWord8vec v - in - (swmfb(Word8Vector.length v, mem, hdc, optmfp) - handle ex => (Memory.free mem; raise ex)) before Memory.free mem - end - end - - type ENHMETAHEADER = - { - bounds: RECT, frame: RECT, fileSize: int, records: int, - handles: int, palEntries: int, resolutionPixels: SIZE, - resolutionMM: SIZE, openGL: bool - } - - local - val ENHMETAHEADER = cStruct18(cDWORD, cDWORD, cRect, cRect, cDWORD, cDWORD, cDWORD, cDWORD, - cWORD, cWORD, cDWORD, cDWORD, cDWORD, cSize, cSize, cDWORD, cDWORD, cDWORD) - val {load=toEMH, ...} = breakConversion ENHMETAHEADER - val gemf = winCall3 (gdi "GetEnhMetaFileHeader") (cHENHMETAFILE, cUint, cPointer) - (cPOSINT "GetEnhMetaFileHeader") - in - fun GetEnhMetaFileHeader(h: HENHMETAFILE): ENHMETAHEADER = - let - (* Initial call with a NULL buffer to get size and check the handle. *) - open Memory - val size = gemf(h, 0, null) - val buff = malloc(Word.fromInt size) - val _ = gemf(h, size, buff) handle ex => (free buff; raise ex) - val (_, _, bounds, frame, _, _, fileSize, records, handles, - _, _, _, palEntries, resolutionPixels, resolutionMM, - _, _, openGL) = toEMH buff - val () = free buff - (* Ignore the description and the pixelFormat structure. - We can get the description using GetEnhMetaFileDescription. *) - in - { bounds = bounds, frame = frame, fileSize = fileSize, - records = records, handles = handles, palEntries = palEntries, - resolutionPixels = resolutionPixels, resolutionMM = resolutionMM, - openGL = openGL <> 0 } - end - end - - (* - Other metafile Functions - EnhMetaFileProc - EnumEnhMetaFile - GetEnhMetaFilePaletteEntries - PlayEnhMetaFileRecord - - Obsolete Functions - EnumMetaFile - EnumMetaFileProc - PlayMetaFileRecord - SetMetaFileBitsEx - *) - end -end; diff --git a/mlsource/extra/Win/Mouse.sml b/mlsource/extra/Win/Mouse.sml deleted file mode 100644 index 637c8ae1..00000000 --- a/mlsource/extra/Win/Mouse.sml +++ /dev/null @@ -1,54 +0,0 @@ -(* - Copyright (c) 2001, 2015, 2019 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Mouse : - sig - type HWND - type POINT = { x: int, y: int } - val DragDetect : HWND * POINT -> bool - val GetCapture : unit -> HWND option - val GetDoubleClickTime : unit -> Time.time - val ReleaseCapture : unit -> unit - val SetCapture : HWND -> HWND option - val SetDoubleClickTime : Time.time -> unit - val SwapMouseButton : bool -> bool - end = -struct - local - open Foreign Base - in - type HWND = HWND and POINT = POINT - - val GetCapture = winCall0 (user "GetCapture") () cHWNDOPT - val SetCapture = winCall1 (user "SetCapture") (cHWND) cHWNDOPT - val ReleaseCapture = winCall0 (user "ReleaseCapture") () (successState "ReleaseCapture") - val SetDoubleClickTime = - winCall1 (user "SetDoubleClickTime") (cUint) (successState "SetDoubleClickTime") o - LargeInt.toInt o Time.toMilliseconds - val GetDoubleClickTime = - Time.fromMilliseconds o LargeInt.fromInt o winCall0 (user "GetDoubleClickTime") () cUint - val SwapMouseButton = winCall1 (user "SwapMouseButton") (cBool) cBool - val DragDetect = winCall2 (user "DragDetect") (cHWND, cPoint) cBool - end -end; - -(* -GetMouseMovePoints - NT 5.0 and Windows 98 only -mouse_event -TrackMouseEvent -*) diff --git a/mlsource/extra/Win/Painting.sml b/mlsource/extra/Win/Painting.sml deleted file mode 100644 index ad02a549..00000000 --- a/mlsource/extra/Win/Painting.sml +++ /dev/null @@ -1,176 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Painting : - sig - type HWND and HDC and COLORREF and HRGN - - type RECT = { top: int, left: int, bottom: int, right: int } - - type BinaryRasterOperation - val R2_BLACK : BinaryRasterOperation - val R2_COPYPEN : BinaryRasterOperation - val R2_MASKNOTPEN : BinaryRasterOperation - val R2_MASKPEN : BinaryRasterOperation - val R2_MASKPENNOT : BinaryRasterOperation - val R2_MERGENOTPEN : BinaryRasterOperation - val R2_MERGEPEN : BinaryRasterOperation - val R2_MERGEPENNOT : BinaryRasterOperation - val R2_NOP : BinaryRasterOperation - val R2_NOT : BinaryRasterOperation - val R2_NOTCOPYPEN : BinaryRasterOperation - val R2_NOTMASKPEN : BinaryRasterOperation - val R2_NOTMERGEPEN : BinaryRasterOperation - val R2_NOTXORPEN : BinaryRasterOperation - val R2_WHITE : BinaryRasterOperation - val R2_XORPEN : BinaryRasterOperation - - type PAINTSTRUCT = - { hdc: HDC, erase: bool, paint: RECT, private: Word8Vector.vector } - - val BeginPaint : HWND -> HDC * PAINTSTRUCT - val EndPaint : HWND * PAINTSTRUCT -> unit - val GdiFlush : unit -> unit - val GdiGetBatchLimit : unit -> int - val GdiSetBatchLimit : int -> int - val GetBkColor : HDC -> COLORREF - val GetROP2 : HDC -> BinaryRasterOperation - val GetUpdateRect : HWND * bool -> RECT option - val GetUpdateRgn : HWND * HRGN * bool -> Region.ResultRegion - val GetWindowDC : HWND -> HDC - val InvalidateRgn : HWND * HRGN * bool -> unit - val SetBkColor : HDC * COLORREF -> COLORREF - val SetROP2 : HDC * BinaryRasterOperation -> BinaryRasterOperation - val WindowFromDC : HDC -> HWND - val InvalidateRect: HWND * RECT * bool -> unit - end = -struct - local - open Foreign Base GdiBase - - fun checkDC c = (checkResult(not(isHdcNull c)); c) - val zeroRect:RECT = {top=0, bottom=0, left=0, right=0} - in - type ResultRegion = Region.ResultRegion - type HDC = HDC and HRGN = HRGN and HWND = HWND - type RECT = RECT and COLORREF = COLORREF - - (* GetROP2 and SetROP2. *) - local - datatype BinaryRasterOperation = - W of int - in - type BinaryRasterOperation = BinaryRasterOperation - val BINARYRASTEROPERATION = absConversion {abs = W, rep = fn W n => n} cInt - - val R2_BLACK = W (1 (* 0 *)) - val R2_NOTMERGEPEN = W (2 (* DPon *)) - val R2_MASKNOTPEN = W (3 (* DPna *)) - val R2_NOTCOPYPEN = W (4 (* PN *)) - val R2_MASKPENNOT = W (5 (* PDna *)) - val R2_NOT = W (6 (* Dn *)) - val R2_XORPEN = W (7 (* DPx *)) - val R2_NOTMASKPEN = W (8 (* DPan *)) - val R2_MASKPEN = W (9 (* DPa *)) - val R2_NOTXORPEN = W (10 (* DPxn *)) - val R2_NOP = W (11 (* D *)) - val R2_MERGENOTPEN = W (12 (* DPno *)) - val R2_COPYPEN = W (13 (* P *)) - val R2_MERGEPENNOT = W (14 (* PDno *)) - val R2_MERGEPEN = W (15 (* DPo *)) - val R2_WHITE = W (16 (* 1 *)) - end - - val GdiFlush = winCall0 (gdi "GdiFlush") () (successState "GdiFlush") - val GdiGetBatchLimit = winCall0 (gdi "GdiGetBatchLimit") () cDWORD - val GdiSetBatchLimit = winCall1 (gdi "GdiSetBatchLimit") (cDWORD) cDWORD - val GetBkColor = winCall1 (gdi "GetBkColor") (cHDC) cCOLORREF - val GetROP2 = winCall1(user "GetROP2") (cHDC) BINARYRASTEROPERATION - val GetUpdateRgn = winCall3(user "GetUpdateRgn") (cHWND,cHRGN,cBool) RESULTREGION - val GetWindowDC = winCall1(user "GetWindowDC") (cHWND) cHDC - val InvalidateRgn = winCall3(user "InvalidateRgn") (cHWND,cHRGN,cBool) (successState "InvalidateRgn") - val InvalidateRect = - winCall3 (user "InvalidateRect") (cHWND, cConstStar cRect, cBool) (successState "InvalidateRect") - val SetBkColor = winCall2 (gdi "SetBkColor") (cHDC, cCOLORREF) cCOLORREF - val WindowFromDC = winCall1(user "WindowFromDC") (cHDC) cHWND - val SetROP2 = winCall2(user "SetROP2") (cHDC, BINARYRASTEROPERATION) BINARYRASTEROPERATION - - local - val getUpdateRect = winCall3 (user "GetUpdateRect") (cHWND, cStar cRect, cBool) cBool - in - fun GetUpdateRect (hw: HWND, erase: bool): RECT option = - let - val va = ref zeroRect - (* If the update area is empty the result is zero. *) - val res = getUpdateRect(hw, va, erase) - in - if res then SOME(!va) else NONE - end - end - - type PAINTSTRUCT = - { hdc: HDC, erase: bool, paint: RECT, private: Word8Vector.vector } - - local - fun toPt({hdc, erase, paint, private}: PAINTSTRUCT) = - (hdc, erase, paint, Byte.bytesToString private) - and fromPt(hdc, erase, paint, private) = - {hdc = hdc, erase = erase, paint = paint, private = Byte.stringToBytes private} - val PAINTSTRUCT = - absConversion {abs=fromPt, rep=toPt} (cStruct4(cHDC, cBool, cRect, cCHARARRAY 40)) - - val beginPaint = winCall2 (user "BeginPaint") (cHWND, cStar PAINTSTRUCT) cHDC - in - fun BeginPaint(hwnd: HWND): HDC * PAINTSTRUCT = - let - val b = ref {hdc=hNull, erase=false, paint=zeroRect, private=Word8Vector.fromList []} - val hdc = checkDC (beginPaint (hwnd, b)) - in - (hdc, !b) - end - - val EndPaint = winCall2 (user "EndPaint") (cHWND, cConstStar PAINTSTRUCT) cVoid - end - (* - Other painting and drawing functions: - DrawAnimatedRects - DrawCaption - DrawEdge - DrawFocusRect - DrawFrameControl - DrawState - DrawStateProc - ExcludeUpdateRgn - GetBkMode - GetBoundsRect - GetWindowRgn - GrayString - LockWindowUpdate - OutputProc - PaintDesktop - RedrawWindow - SetBkMode - SetBoundsRect - SetWindowRgn - UpdateWindow - ValidateRect - ValidateRgn - *) - - end -end; diff --git a/mlsource/extra/Win/Path.sml b/mlsource/extra/Win/Path.sml deleted file mode 100644 index a61a3474..00000000 --- a/mlsource/extra/Win/Path.sml +++ /dev/null @@ -1,91 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Path : - sig - type HDC and HRGN - type POINT = {x: int, y: int} - datatype PointType = datatype Line.PointType - - val AbortPath : HDC -> unit - val BeginPath : HDC -> unit - val CloseFigure : HDC -> unit - val EndPath : HDC -> unit - val FillPath : HDC -> unit - val FlattenPath : HDC -> unit - val GetMiterLimit : HDC -> real - val GetPath : HDC -> (PointType * POINT) list - val PathToRegion : HDC -> HRGN - val SetMiterLimit : HDC * real -> real - val StrokeAndFillPath : HDC -> unit - val StrokePath : HDC -> unit - val WidenPath : HDC -> unit - - end = -struct - local - open Foreign Base - in - type HDC = HDC and POINT = POINT and HRGN = HRGN - datatype PointType = datatype Line.PointType - - (* PATHS *) - val AbortPath = winCall1(gdi "AbortPath") (cHDC) (successState "AbortPath") - val BeginPath = winCall1(gdi "BeginPath") (cHDC) (successState "BeginPath") - val CloseFigure = winCall1(gdi "CloseFigure") (cHDC) (successState "CloseFigure") - val EndPath = winCall1(gdi "EndPath") (cHDC) (successState "EndPath") - val FillPath = winCall1(gdi "FillPath") (cHDC) (successState "FillPath") - val FlattenPath = winCall1(gdi "FlattenPath") (cHDC) (successState "FlattenPath") - val PathToRegion = winCall1(gdi "PathToRegion") (cHDC) cHRGN - val StrokeAndFillPath = winCall1(gdi "StrokeAndFillPath") (cHDC) (successState "StrokeAndFillPath") - val StrokePath = winCall1(gdi "StrokePath") (cHDC) (successState "StrokePath") - val WidenPath = winCall1(gdi "WidenPath") (cHDC) (successState "WidenPath") - - local - val getMiterLimit = winCall2(gdi "GetMiterLimit") (cHDC, cStar cFloat) (successState "GetMiterLimit") - and setMiterLimit = winCall3(gdi "SetMiterLimit") (cHDC, cFloat, cStar cFloat) (successState "SetMiterLimit") - in - fun GetMiterLimit hdc = let val v = ref 0.0 in getMiterLimit(hdc, v); !v end - and SetMiterLimit(hdc, m) = let val v = ref 0.0 in setMiterLimit(hdc, m, v); !v end - end - - local - val getPath = winCall4 (gdi "GetPath") (cHDC, cPointer, cPointer, cInt) cInt - val {load=fromPt, ctype={size=sizePt, ...}, ...} = breakConversion cPoint - val {load=fromTy, ...} = breakConversion GdiBase.cPOINTTYPE - in - fun GetPath h = - let - open Memory - infix 6 ++ - (* Passing 0 as the size will retrieve the number of points. *) - val count = getPath(h, null, null, 0) - val _ = checkResult(count >= 0) - - val ptarr = malloc(Word.fromInt count * sizePt) - val farr = malloc(Word.fromInt count) - val _ = getPath(h, ptarr, farr, count) handle ex => (free ptarr; free farr; raise ex) - fun getElement n = - (fromTy(farr ++ Word.fromInt n), fromPt(ptarr ++ Word.fromInt n * sizePt)) - in - List.tabulate(count, getElement) before (free ptarr; free farr) - end - end - - end -end; diff --git a/mlsource/extra/Win/Pen.sml b/mlsource/extra/Win/Pen.sml deleted file mode 100644 index 2edbb291..00000000 --- a/mlsource/extra/Win/Pen.sml +++ /dev/null @@ -1,84 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Pen : - sig - type HPEN - datatype - PenStyle = - PS_ALTERNATE - | PS_COSMETIC - | PS_DASH - | PS_DASHDOT - | PS_DASHDOTDOT - | PS_DOT - | PS_ENDCAP_FLAT - | PS_ENDCAP_ROUND - | PS_ENDCAP_SQUARE - | PS_GEOMETRIC - | PS_INSIDEFRAME - | PS_JOIN_BEVEL - | PS_JOIN_MITER - | PS_JOIN_ROUND - | PS_NULL - | PS_SOLID - | PS_USERSTYLE - - type COLORREF = Color.COLORREF - type LOGBRUSH = Brush.LOGBRUSH - type LOGPEN = PenStyle * int option * COLORREF - - val CreatePen : PenStyle list * int * COLORREF -> HPEN - val CreatePenIndirect : LOGPEN -> HPEN - val ExtCreatePen : PenStyle list * int * LOGBRUSH * (int * int) list -> HPEN - - end = -struct - local - open Foreign Base - in - open GdiBase - type HPEN = HPEN - - val CreatePen = winCall3 (gdi "CreatePen") (cPENSTYLE,cInt,cCOLORREF) (cHPEN) - val CreatePenIndirect = winCall1 (gdi "CreatePenIndirect") (cConstStar cLOGPEN) (cHPEN) - - local - val extCreatePen = - winCall5 (gdi "ExtCreatePen") - (cPENSTYLE,cDWORD,cConstStar cLOGBRUSH,cDWORD,cPointer) (cHPEN) - val PAIR = absConversion {abs = fn _ => raise Fail "PAIR", rep = MAKELONG} cDWORDw - val list2v = list2Vector PAIR - in - - fun ExtCreatePen (ps: PenStyle list, width, log: LOGBRUSH, dashSp: (int*int) list) = - let - (* custom is supposed to be NULL if ps <> PS_USERSTYLE. Make sure it is at least - NULL if the list is empty. *) - val (custom, len) = - case dashSp of - [] => (Memory.null, 0) - | _ => list2v (map (fn (i, j) => (Word.fromInt i, Word.fromInt j)) dashSp) - in - (extCreatePen(ps, width, log, len, custom) - handle ex => (Memory.free custom; raise ex)) before Memory.free custom - end - end - - end -end; diff --git a/mlsource/extra/Win/Printing.sml b/mlsource/extra/Win/Printing.sml deleted file mode 100644 index df9b7905..00000000 --- a/mlsource/extra/Win/Printing.sml +++ /dev/null @@ -1,77 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Printing : - sig - type HDC - type DOCINFO = { docName: string, output: string option, dType: string option} - - val StartDoc : HDC * DOCINFO -> int - val StartPage : HDC -> unit - val AbortDoc : HDC -> unit - val EndDoc : HDC -> unit - val EndPage : HDC -> unit - - datatype WMPrintOption = - PRF_CHECKVISIBLE | PRF_NONCLIENT | PRF_CLIENT | PRF_ERASEBKGND | - PRF_CHILDREN | PRF_OWNED - end = -struct - local - open Foreign Base - in - type HDC = HDC - type DOCINFO = { docName: string, output: string option, dType: string option} - - (* PRINTING AND SPOOLING. *) - local - val DOCINFO = cStruct5(cInt, cString, STRINGOPT, STRINGOPT, cDWORDw) - val {ctype={size=sizeDI, ...}, ...} = breakConversion DOCINFO - val startdoc = winCall2(gdi "StartDocA")(cHDC, DOCINFO) cInt - in - - fun StartDoc(hdc: HDC, {docName, output, dType}): int = - let - val res = startdoc(hdc, (Word.toInt sizeDI, docName, output, dType, 0w0)) - in - checkResult(res > 0); - res - end - end - - local - fun checkSuccess res = checkResult(res > 0) - in - val EndDoc = checkSuccess o winCall1(gdi "EndDoc") cHDC cInt - val StartPage = checkSuccess o winCall1(gdi "StartPage") cHDC cInt - val EndPage = checkSuccess o winCall1(gdi "EndPage") cHDC cInt - val AbortDoc = checkSuccess o winCall1(gdi "AbortDoc") cHDC cInt - end - - datatype WMPrintOption = datatype Message.WMPrintOption - - (* - Other printing functions: - DeviceCapabilities - Escape - ExtEscape - SetAbortProc - *) - - end -end; diff --git a/mlsource/extra/Win/README.txt b/mlsource/extra/Win/README.txt new file mode 100644 index 00000000..024a1702 --- /dev/null +++ b/mlsource/extra/Win/README.txt @@ -0,0 +1,2 @@ +The Windows GUI code has been moved in a separate repository. +See https://github.com/polyml/WindowsLibrary . diff --git a/mlsource/extra/Win/ROOT.sml b/mlsource/extra/Win/ROOT.sml deleted file mode 100644 index f1ad6454..00000000 --- a/mlsource/extra/Win/ROOT.sml +++ /dev/null @@ -1,59 +0,0 @@ -PolyML.Compiler.reportUnreferencedIds := true; -use "Base"; -use "Globals"; -use "LocaleBase"; -use "Locale"; -use "Resource"; -use "WinBase"; -use "ComboBase"; -use "ScrollBase"; -use "MenuBase"; -use "MESSAGE.signature"; -use "Message"; -use "Class"; -use "FlagPrint"; -use "Window"; -use "ComboBox"; -use "Edit"; -use "ListBox"; -use "Scrollbar"; -use "Static"; -use "Button"; -use "Dialog"; -use "Cursor"; -use "Icon"; -use "Menu"; -use "GdiBase"; -use "Color"; -use "FontBase"; -use "Font"; -use "DeviceBase"; -use "Bitmap"; -use "Brush"; -use "Pen"; -use "DeviceContext"; -use "CommonDialog"; -use "MessageBox"; -use "Caret"; -use "Transform"; -use "Metafile"; -use "Clipboard"; -use "Rectangle"; -use "Printing"; -use "Line"; -use "Path"; -use "Region"; -use "Painting"; -use "Shape"; -use "Clipping"; -use "DragDrop"; -use "Keyboard"; -use "Mouse"; -use "WinSystem"; -use "CommonControls"; - -List.app PolyML.Compiler.forgetStructure - [ "Base", "ComboBase", "FontBase", "MenuBase", "ScrollBase", "WinBase", - "MessageBase", "GdiBase", "DeviceBase", "LocaleBase" ]; - -List.app PolyML.Compiler.forgetFunctor ["FlagPrint"]; diff --git a/mlsource/extra/Win/Rectangle.sml b/mlsource/extra/Win/Rectangle.sml deleted file mode 100644 index ffbcddb5..00000000 --- a/mlsource/extra/Win/Rectangle.sml +++ /dev/null @@ -1,103 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Rectangle : - sig - type POINT = { x: int, y: int } - type RECT = { top: int, left: int, bottom: int, right: int } - - val EqualRect : RECT * RECT -> bool - val InflateRect : RECT * int * int -> RECT - val IntersectRect : RECT * RECT -> RECT option - val IsRectEmpty : RECT -> bool - val OffsetRect : RECT * int * int -> RECT - val PtInRect : RECT * POINT -> bool - val SetRect : int * int * int * int -> RECT - val SetRectEmpty : unit -> RECT - val SubtractRect : RECT * RECT -> RECT - val UnionRect : RECT * RECT -> RECT - end = -struct - local - open Foreign Base -(* fun usercall_MII name CR (C1,C2,C3) (a1,a2,a3) = - let val (from1,to1,ctype1) = breakConversion C1 - val (from2,to2,ctype2) = breakConversion C2 - val (from3,to3,ctype3) = breakConversion C3 - val (fromR,toR,ctypeR) = breakConversion CR - val va1 = address (to1 a1) - val va2 = to2 a2 - val va3 = to3 a3 - val res = calluser name [(Cpointer ctype1,va1),(ctype2,va2),(ctype3,va3)] ctypeR - in (fromR res,from1 (deref va1)) - end*) - in - type RECT = RECT and POINT = POINT - (* TODO: It would be a lot more efficient to implement these directly in ML. *) - - val zeroRect: RECT = {top=0, bottom=0, left=0, right=0} - - (* RECTANGLES. *) - val EqualRect = winCall2 (user "EqualRect") (cConstStar cRect, cConstStar cRect) cBool - - local - val inflateRect = winCall3 (user "InflateRect") (cStar cRect, cInt, cInt) (successState "InflateRect") - in - fun InflateRect(r, x, y) = let val v = ref r in inflateRect(v, x, y); !v end - end - - local - val intersectRect = winCall3 (user "IntersectRect") (cStar cRect, cConstStar cRect, cConstStar cRect) cBool - in - fun IntersectRect(r1, r2) = - let val r = ref zeroRect in if intersectRect(r, r1, r2) then SOME(!r) else NONE end - end - - local - val offsetRect = winCall3 (user "OffsetRect") (cStar cRect, cInt, cInt) (successState "OffsetRect") - in - fun OffsetRect(r, x, y) = let val v = ref r in offsetRect(v, x, y); !v end - end - - val IsRectEmpty = winCall1(user "IsRectEmpty") (cConstStar cRect) cBool - val PtInRect = winCall2(user "PtInRect") (cConstStar cRect, cPoint) cBool - - local - val setRect = winCall5 (user "SetRect") (cStar cRect, cInt, cInt, cInt, cInt) (successState "SetRect") - in - fun SetRect(a,b,c,d) : RECT = let val v = ref zeroRect in setRect(v, a,b,c,d); !v end - end - - fun SetRectEmpty () : RECT = zeroRect (* No need to call C to do this *) - - local - val subtractRect = - winCall3 (user "SubtractRect") (cStar cRect, cConstStar cRect, cConstStar cRect) (successState "SubtractRect") - and unionRect = - winCall3 (user "UnionRect") (cStar cRect, cConstStar cRect, cConstStar cRect) (successState "UnionRect") - in - fun SubtractRect(r1, r2) = let val v = ref zeroRect in subtractRect(v, r1, r2); !v end - and UnionRect(r1, r2) = let val v = ref zeroRect in unionRect(v, r1, r2); !v end - end - - (* - Other Rectangle functions: - CopyRect - *) - end -end; diff --git a/mlsource/extra/Win/Region.sml b/mlsource/extra/Win/Region.sml deleted file mode 100644 index e0807d01..00000000 --- a/mlsource/extra/Win/Region.sml +++ /dev/null @@ -1,213 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Region: -sig - type HDC and HBRUSH and HRGN and HPEN - type POINT = { x: int, y: int } - type RECT = { top: int, left: int, bottom: int, right: int } - - type RegionOperation - val RGN_AND : RegionOperation - val RGN_COPY : RegionOperation - val RGN_DIFF : RegionOperation - val RGN_ERROR : RegionOperation - val RGN_OR : RegionOperation - val RGN_XOR : RegionOperation - - type ResultRegion - val COMPLEXREGION : ResultRegion - val NULLREGION : ResultRegion - val ERROR : ResultRegion - val SIMPLEREGION : ResultRegion - - type PolyFillMode - val ALTERNATE : PolyFillMode - val WINDING : PolyFillMode - - val CombineRgn : HRGN * HRGN * HRGN * RegionOperation -> ResultRegion - val CreateEllipticRgn : RECT -> HRGN - val CreatePolygonRgn : POINT list * PolyFillMode -> HRGN - val CreateRectRgn : RECT -> HRGN - val CreateRoundRectRgn : RECT * int * int -> HRGN - val EqualRgn : HRGN * HRGN -> bool - val FillRgn : HDC * HRGN * HBRUSH -> unit - val FrameRgn : HDC * HRGN * HBRUSH * int * int -> unit - val GetPolyFillMode : HDC -> PolyFillMode - val GetRgnBox : HRGN -> RECT - val InvertRgn : HDC * HRGN -> unit - val OffsetRgn : HRGN * int * int -> ResultRegion - val PaintRgn : HDC * HRGN -> unit - val PtInRegion : HRGN * int * int -> bool - val RectInRegion : HRGN * RECT -> bool - val SetPolyFillMode : HDC * PolyFillMode -> PolyFillMode - val SetRectRgn : HRGN * RECT -> unit - - end = -struct - local - open Foreign Base - in - type HRGN = Base.HRGN and HBRUSH = Base.HBRUSH and HDC = Base.HDC - and HPEN = HPEN and RECT = RECT and POINT = POINT - - open GdiBase - - local - datatype PolyFillMode = - W of int - in - type PolyFillMode = PolyFillMode - val POLYFILLMODE = absConversion {abs = W, rep = fn W n => n} cInt - - val ALTERNATE = W (1) - val WINDING = W (2) - end - - val CombineRgn = winCall4(gdi "CombineRgn") (cHRGN,cHRGN,cHRGN,REGIONOPERATION) RESULTREGION - val EqualRgn = winCall2(gdi "EqualRgn") (cHRGN,cHRGN) cBool - val FillRgn = winCall3(gdi "FillRgn") (cHDC,cHRGN,cHBRUSH) (successState "FillRgn") - val FrameRgn = winCall5(gdi "FrameRgn") (cHDC,cHRGN,cHBRUSH,cInt,cInt) (successState "FrameRgn") - val GetPolyFillMode = winCall1(gdi "GetPolyFillMode") (cHDC) POLYFILLMODE - val InvertRgn = winCall2(gdi "InvertRgn") (cHDC,cHRGN) (successState "InvertRgn") - val OffsetRgn = winCall3(gdi "OffsetRgn") (cHRGN,cInt,cInt) RESULTREGION - val PaintRgn = winCall2(gdi "PaintRgn") (cHDC,cHRGN) (successState "PaintRgn") - val PtInRegion = winCall3(gdi "PtInRegion") (cHRGN,cInt,cInt) cBool - val RectInRegion = winCall2(gdi "RectInRegion") (cHRGN,cRect) cBool - val SetPolyFillMode = winCall2(gdi "SetPolyFillMode") (cHDC,POLYFILLMODE) POLYFILLMODE - - local - val getRgnBox = winCall2(gdi "GetRgnBox") (cHRGN, cStar cRect) cInt - val zeroRect = {top=0, bottom=0, left=0, right=0} - in - fun GetRgnBox hr = - let val v = ref zeroRect in checkResult(getRgnBox(hr, v) <> 0); !v end - end - - local - val setRectRgn = winCall5 (gdi "SetRectRgn") (cHRGN,cInt,cInt,cInt,cInt) (successState "SetRectRgn") - in - fun SetRectRgn (h, { left, top, right, bottom }) = setRectRgn(h,left,top,right,bottom) - end - - local - val createEllipticRgn = winCall4 (gdi "CreateEllipticRgn") (cInt,cInt,cInt,cInt) cHRGN - in - fun CreateEllipticRgn {left,top,right,bottom} = createEllipticRgn(left,top,right,bottom) - end - - local - val createRectRgn = winCall4 (gdi "CreateRectRgn") (cInt,cInt,cInt,cInt) cHRGN - in - fun CreateRectRgn {left,top,right,bottom} = createRectRgn(left,top,right,bottom) - end - - local - val createRoundRectRgn = winCall6 (gdi "CreateRoundRectRgn") (cInt,cInt,cInt,cInt,cInt,cInt) cHRGN - in - fun CreateRoundRectRgn({left,top,right,bottom},w,h) = - createRoundRectRgn(left,top,right,bottom,w,h) - end - - local - val createPolygonRgn = winCall3 (gdi "CreatePolygonRgn") (cPointer,cInt,POLYFILLMODE) cHRGN - val ptList = list2Vector cPoint - in - fun CreatePolygonRgn (pts: POINT list, fmode) = - let - val (ptarr, count) = ptList pts - in - (createPolygonRgn(ptarr,count,fmode) handle ex => (Memory.free ptarr; raise ex)) - before Memory.free ptarr - end - end - -(* fun ExtCreateRegion (x,rects,rectmain) = - let val {r11,r12,r21,r22,tx,ty} = breakXForm x - val xform = make_struct - [ (Cfloat,toCfloat r11), - (Cfloat,toCfloat r12), - (Cfloat,toCfloat r21), - (Cfloat,toCfloat r22), - (Cfloat,toCfloat tx), - (Cfloat,toCfloat ty) ] - - val count = List.length rects - - val rectarr = alloc count (Cstruct [Clong,Clong,Clong,Clong]) - - fun pl2a v n [] = () - | pl2a v n ({left,top,right,bottom} :: rest) = - let val item = make_struct [(Clong,toClong left), - (Clong,toClong top), - (Clong,toClong right), - (Clong,toClong bottom)] - in - ( assign (Cstruct [Clong,Clong,Clong,Clong]) - (offset n (Cstruct [Clong,Clong,Clong,Clong]) v) item ; - pl2a v (n+1) rest ) - end - - val u = pl2a rectarr 0 rects - val {left,top,right,bottom} = rectmain - - val rgndata = make_struct - [ (Clong,toClong 32), - (Clong,toClong 1), - (Clong,toClong count), - (Clong,toClong 0 ), - (Clong,toClong left), - (Clong,toClong top), - (Clong,toClong right), - (Clong,toClong bottom), - (Cvoid,rectarr) ] - - val struct_size = 64 + 16 * count - in - winCall3 (gdi "ExtCreateRegion") - (POINTER,INT,POINTER) (cHRGN) - (address xform,struct_size,address rgndata) - end -*) -(* fun GetRegionData h = - let - val bufsize = winCall3 (gdi "GetRegionData") - (cHRGN,LONG,POINTER) (LONG) - (h,0,toCint 0) - - val rgndata = alloc 1 (Cstruct [Clong,Clong,Clong,Clong, - Clong,Clong,Clong,Clong,Cvoid]) - - val res = winCall3 (gdi "GetRegionData") - (cHRGN,LONG,POINTER) (LONG) - (h,bufsize,address rgndata) - in - "not implemented" - end -*) - (* - Other Region Functions - CreateEllipticRgnIndirect - CreatePolyPolygonRgn - CreateRectRgnIndirect - ExtCreateRegion - GetRegionData - *) - - end -end; diff --git a/mlsource/extra/Win/Resource.sml b/mlsource/extra/Win/Resource.sml deleted file mode 100644 index 4a21711d..00000000 --- a/mlsource/extra/Win/Resource.sml +++ /dev/null @@ -1,171 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Resource : - sig - datatype ResourceType = - RT_CURSOR | RT_BITMAP | RT_ICON | RT_MENU | RT_DIALOG | RT_STRING | RT_FONTDIR | - RT_FONT | RT_ACCELERATOR | RT_RCDATA | RT_MESSAGETABLE | RT_GROUP_CURSOR | - RT_GROUP_ICON | RT_VERSION | RT_DLGINCLUDE | RT_ANICURSOR | RT_ANIICON | - RT_PLUGPLAY | RT_VXD - - type HRSRC - type HRSRCGLOBAL - type HINSTANCE - - datatype RESID = IdAsInt of int | IdAsString of string - val MAKEINTRESOURCE : int -> RESID - - type HUPDATE - - val BeginUpdateResource : string * bool -> HUPDATE - val EndUpdateResource : HUPDATE * bool -> unit - val FindResource : HINSTANCE * RESID * ResourceType -> HRSRC - val FindResourceEx : HINSTANCE * ResourceType * RESID * Locale.LANGID -> HRSRC - val FreeLibrary : HINSTANCE -> unit - val LoadLibrary : string -> HINSTANCE - val LoadResource : HINSTANCE * HRSRC -> HRSRCGLOBAL - val LoadString : HINSTANCE * RESID -> string - val LockResource : HRSRCGLOBAL -> Word8Vector.vector - val SizeofResource : HINSTANCE * HRSRC -> int - val UpdateResource : - HUPDATE * ResourceType * RESID * Locale.LANGID * Word8Vector.vector option -> unit - end - = -struct - open Foreign - open Base - - datatype RESID = datatype RESID - - fun MAKEINTRESOURCE i = - if i >= 0 andalso i < 65536 then IdAsInt i - else raise Fail "resource id out of range" - - fun checkHandle h = (checkResult(not(isHNull h)); h) - - datatype ResourceType = - RT_CURSOR | RT_BITMAP | RT_ICON | RT_MENU | RT_DIALOG | RT_STRING | RT_FONTDIR | - RT_FONT | RT_ACCELERATOR | RT_RCDATA | RT_MESSAGETABLE | RT_GROUP_CURSOR | - RT_GROUP_ICON | RT_VERSION | RT_DLGINCLUDE | RT_ANICURSOR | RT_ANIICON | - RT_PLUGPLAY | RT_VXD - - local - - fun toRes 1 = RT_CURSOR | toRes 2 = RT_BITMAP | toRes 3 = RT_ICON | toRes 4 = RT_MENU - | toRes 5 = RT_DIALOG | toRes 6 = RT_STRING | toRes 7 = RT_FONTDIR | toRes 8 = RT_FONT - | toRes 9 = RT_ACCELERATOR | toRes 10 = RT_RCDATA | toRes 11 = RT_MESSAGETABLE - | toRes 12 = RT_GROUP_CURSOR | toRes 14 = RT_GROUP_ICON | toRes 16 = RT_VERSION - | toRes 17 = RT_DLGINCLUDE | toRes 19 = RT_PLUGPLAY | toRes 20 = RT_VXD - | toRes 21 = RT_ANICURSOR | toRes 22 = RT_ANIICON - | toRes _ = raise Fail "Unknown Resource Type" - - fun fromRes RT_CURSOR = 1 | fromRes RT_BITMAP = 2 | fromRes RT_ICON = 3 - | fromRes RT_MENU = 4 | fromRes RT_DIALOG = 5 | fromRes RT_STRING = 6 - | fromRes RT_FONTDIR = 7 | fromRes RT_FONT = 8 | fromRes RT_ACCELERATOR = 9 - | fromRes RT_RCDATA = 10 | fromRes RT_MESSAGETABLE = 11 | fromRes RT_GROUP_CURSOR = 12 - | fromRes RT_GROUP_ICON = 14 | fromRes RT_VERSION = 16 | fromRes RT_DLGINCLUDE = 17 - | fromRes RT_PLUGPLAY = 19 | fromRes RT_VXD = 20 | fromRes RT_ANICURSOR = 21 - | fromRes RT_ANIICON = 22 - in - val RESOURCETYPE = - absConversion {abs = toRes, rep = fromRes} cInt - end - - local - datatype HRSRCGLOBAL = HRSRCGLOBAL of Memory.voidStar * int - in - type HRSRCGLOBAL = HRSRCGLOBAL - - val LoadLibrary = checkHandle o winCall1 (kernel "LoadLibraryA") (cString) cHINSTANCE - and FreeLibrary = winCall1 (kernel "FreeLibrary") (cHINSTANCE) (successState "FreeLibrary") - and FindResource = checkHandle o - winCall3 (kernel "FindResourceA") - (cHINSTANCE, cRESID, RESOURCETYPE) cHRSRC - and SizeofResource = winCall2 (kernel "SizeofResource") (cHINSTANCE, cHRSRC) cDWORD - (* The name and type are in the reverse order in FindResource and FindResourceEx *) - and FindResourceEx = checkHandle o - winCall4 (kernel "FindResourceExA") - (cHINSTANCE, RESOURCETYPE, cRESID, LocaleBase.LANGID) cHRSRC - - (* LoadResource - load a resource into memory and get a handle to it. *) - local - val loadResource = winCall2 (kernel "LoadResource") (cHINSTANCE, cHRSRC) - and lockResource = winCall1 (kernel "LockResource") (cPointer) cPointer - and loadString = winCall4 (user "LoadStringA") (cHINSTANCE, cRESID, cPointer, cInt) cInt - in - fun LoadResource (hInst, hRsrc) = - let - val size = SizeofResource (hInst, hRsrc) - val load = loadResource cPointer - val rsrc = load(hInst, hRsrc) - in - HRSRCGLOBAL(rsrc, size) - end - - (* LockResource - get the resource as a piece of binary store. *) - fun LockResource (HRSRCGLOBAL(hg, size)) = - let - val res = lockResource hg - in - Word8Vector.tabulate(size, fn i => Memory.get8(res, Word.fromInt i)) - end - - fun LoadString (hInst, resId): string = - let - (* The underlying call returns the number of bytes copied EXCLUDING the terminating null. *) - (* The easiest way to make sure we have enough store is to loop. *) - open Memory - fun tryLoad n = - let - val store = malloc n - val used = Word.fromInt(loadString(hInst, resId, store, Word.toInt n)) - in - (* We can't distinguish the empty string from a missing resource. *) - if used = 0w0 then "" - else if used < n-0w1 - then fromCstring store before free store - else (free store; tryLoad(n*0w2)) - end - in - tryLoad 0w100 - end - end - - val BeginUpdateResource = - (fn c => (checkResult(not(isHNull c)); c)) o - winCall2 (user "BeginUpdateResourceA") (cString, cBool) cHUPDATE - - val EndUpdateResource = - winCall2 (user "EndUpdateResource") (cHUPDATE, cBool) (successState "EndUpdateResource") - - local - val updateResource = - winCall6 (user "UpdateResource") - (cHUPDATE, RESOURCETYPE, cRESID, LocaleBase.LANGID, cOptionPtr cByteArray, cInt) - (successState "UpdateResource") - in - (* NONE here means delete the resource, SOME means a value to store. *) - (* N.B. If updating a string the new value must be in Unicode. *) - fun UpdateResource(hup, rt, resid, lang, v as SOME vec) = - updateResource(hup, rt, resid, lang, v, Word8Vector.length vec) - | UpdateResource(hup, rt, resid, lang, NONE) = - updateResource(hup, rt, resid, lang, NONE, 0) - end - end -end; diff --git a/mlsource/extra/Win/ScrollBase.sml b/mlsource/extra/Win/ScrollBase.sml deleted file mode 100644 index f8460cf6..00000000 --- a/mlsource/extra/Win/ScrollBase.sml +++ /dev/null @@ -1,71 +0,0 @@ -(* - Copyright (c) 2001, 2015, 2019 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure ScrollBase = -struct - local - open Foreign Base - in - type enableArrows = { enableLeftUp: bool, enableRightDown: bool } - val ESB_ENABLE_BOTH = { enableLeftUp = true, enableRightDown = true } - val ESB_DISABLE_BOTH = { enableLeftUp = false, enableRightDown = false } - val ESB_DISABLE_LEFT = { enableLeftUp = false, enableRightDown = true } - val ESB_DISABLE_RIGHT = { enableLeftUp = true, enableRightDown = false } - val ESB_DISABLE_UP = ESB_DISABLE_LEFT - val ESB_DISABLE_DOWN = ESB_DISABLE_RIGHT - - local - (* The arrows are disabled if the bit is set. *) - fun toInt({enableLeftUp: bool, enableRightDown}: enableArrows) = - Word.toInt( - Word.orb(if enableLeftUp then 0w0 else 0w1, - if enableRightDown then 0w0 else 0w2)) - and fromInt i : enableArrows = - {enableLeftUp = Word.andb(Word.fromInt i, 0w1) = 0w0, - enableRightDown = Word.andb(Word.fromInt i, 0w2) = 0w0} - in - (* It's easier to use the functions directly for messages *) - val ENABLESCROLLBARFLAG = (toInt, fromInt) - val cENABLESCROLLBARFLAG = absConversion{rep = toInt, abs = fromInt} cUint - end - - type SCROLLINFO = - { minPos: int, maxPos: int, pageSize: int, pos: int, trackPos: int } - - datatype ScrollInfoOption = - SIF_RANGE | SIF_PAGE | SIF_POS | SIF_DISABLENOSCROLL | SIF_TRACKPOS - - val SIF_ALL = [SIF_RANGE, SIF_PAGE, SIF_POS, SIF_TRACKPOS] - - local - val tab = [ - (SIF_RANGE, 0wx0001), - (SIF_PAGE, 0wx0002), - (SIF_POS, 0wx0004), - (SIF_DISABLENOSCROLL, 0wx0008), - (SIF_TRACKPOS, 0wx0010)] - in - (*val (fromSIF, toSIF) = tableSetLookup(tab, NONE)*) - val cSCROLLINFOOPTION = tableSetConversion(tab, NONE) - end - - (* Needed in Scrollbar and also Messages *) - val cSCROLLINFOSTRUCT = - cStruct7(cUint, cSCROLLINFOOPTION, cInt, cInt, cUint, cInt, cInt) - end -end; diff --git a/mlsource/extra/Win/Scrollbar.sml b/mlsource/extra/Win/Scrollbar.sml deleted file mode 100644 index babe63df..00000000 --- a/mlsource/extra/Win/Scrollbar.sml +++ /dev/null @@ -1,259 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* Scrollbars. *) -structure Scrollbar: -sig - type HWND and HDC and HRGN - type RECT = { left: int, top: int, right: int, bottom: int } - - structure Style: - sig - include BIT_FLAGS where type flags = Window.Style.flags - val WS_OVERLAPPED: flags and WS_POPUP: flags and WS_CHILD: flags and WS_MINIMIZE: flags - and WS_VISIBLE: flags and WS_DISABLED:flags and WS_CLIPSIBLINGS:flags - and WS_CLIPCHILDREN:flags and WS_MAXIMIZE:flags and WS_CAPTION:flags - and WS_BORDER:flags and WS_DLGFRAME:flags and WS_VSCROLL:flags and WS_HSCROLL:flags - and WS_SYSMENU:flags and WS_THICKFRAME:flags and WS_GROUP:flags and WS_TABSTOP:flags - and WS_MINIMIZEBOX:flags and WS_MAXIMIZEBOX:flags and WS_TILED:flags and WS_ICONIC:flags - and WS_SIZEBOX:flags and WS_OVERLAPPEDWINDOW:flags and WS_TILEDWINDOW:flags - and WS_POPUPWINDOW:flags and WS_CHILDWINDOW:flags - and SBS_HORZ:flags and SBS_VERT:flags and SBS_TOPALIGN:flags and SBS_LEFTALIGN:flags - and SBS_BOTTOMALIGN:flags and SBS_RIGHTALIGN:flags and SBS_SIZEBOXTOPLEFTALIGN:flags - and SBS_SIZEBOXBOTTOMRIGHTALIGN:flags and SBS_SIZEBOX:flags and SBS_SIZEGRIP:flags - end - - type enableArrows = { enableLeftUp: bool, enableRightDown: bool } - - val ESB_ENABLE_BOTH: enableArrows - val ESB_DISABLE_BOTH: enableArrows - val ESB_DISABLE_LEFT: enableArrows - val ESB_DISABLE_RIGHT: enableArrows - val ESB_DISABLE_UP: enableArrows - val ESB_DISABLE_DOWN: enableArrows - - type SCROLLINFO = - { minPos: int, maxPos: int, pageSize: int, pos: int, trackPos: int } - - datatype ScrollInfoOption = - SIF_RANGE | SIF_PAGE | SIF_POS | SIF_DISABLENOSCROLL | SIF_TRACKPOS - - val SIF_ALL : ScrollInfoOption list - - datatype ScrollBarType = SB_BOTH | SB_CTL | SB_HORZ | SB_VERT - datatype ScrollWindowFlag = SW_ERASE | SW_INVALIDATE | SW_SCROLLCHILDREN - - val EnableScrollBar : HWND * ScrollBarType * enableArrows -> unit - val GetScrollInfo : HWND * ScrollBarType * ScrollInfoOption list -> SCROLLINFO - val GetScrollPos : HWND * ScrollBarType -> int - val ScrollDC : HDC * int * int * RECT * RECT * HRGN -> RECT - val ScrollWindow : HWND * int * int * RECT * RECT -> unit - val ScrollWindowEx : HWND * int * int * RECT * RECT * HRGN * ScrollWindowFlag list -> RECT - val SetScrollInfo : - HWND * ScrollBarType * ScrollInfoOption list * SCROLLINFO * bool -> int - val SetScrollPos : HWND * ScrollBarType * int * bool -> int - val SetScrollRange : HWND * ScrollBarType * int * int * bool -> bool - val ShowScrollBar : HWND * ScrollBarType * bool -> unit -end -= -struct - local - open Foreign Base - in - open ScrollBase - type HDC = HDC and HWND = HWND and HRGN = HRGN and RECT = RECT - - structure Style = - struct - open Window.Style (* Include all the windows styles. *) - - val SBS_HORZ = fromWord 0wx0000 - val SBS_VERT = fromWord 0wx0001 - val SBS_TOPALIGN = fromWord 0wx0002 - val SBS_LEFTALIGN = fromWord 0wx0002 - val SBS_BOTTOMALIGN = fromWord 0wx0004 - val SBS_RIGHTALIGN = fromWord 0wx0004 - val SBS_SIZEBOXTOPLEFTALIGN = fromWord 0wx0002 - val SBS_SIZEBOXBOTTOMRIGHTALIGN = fromWord 0wx0004 - val SBS_SIZEBOX = fromWord 0wx0008 - val SBS_SIZEGRIP = fromWord 0wx0010 - - val all = flags[Window.Style.all, SBS_HORZ, SBS_VERT, SBS_TOPALIGN, SBS_BOTTOMALIGN, - SBS_SIZEBOX, SBS_SIZEGRIP] - - val intersect = - List.foldl (fn (a, b) => fromWord(SysWord.andb(toWord a, toWord b))) all - end - - datatype ScrollBarType = SB_CTL | SB_HORZ | SB_VERT | SB_BOTH - - local - val tab = [ - (SB_HORZ, 0), - (SB_VERT, 1), - (SB_CTL, 2), - (SB_BOTH, 3) - ] - in - val cSCROLLBARTYPE = tableConversion(tab, NONE) cUint - (* It's a UINT for EnableScrollBar and int for GetScrollInfo *) - end - - datatype ScrollWindowFlag = - SW_SCROLLCHILDREN | SW_INVALIDATE | SW_ERASE - - local - val tab = [ - (SW_SCROLLCHILDREN, 0wx0001), - (SW_INVALIDATE, 0wx0002), - (SW_ERASE, 0wx0004) ] - in - val cSCROLLWINDOWFLAG = tableSetConversion(tab, NONE) - end - - - local - open Foreign - open Base - in - val EnableScrollBar = winCall3(user "EnableScrollBar") (cHWND, cSCROLLBARTYPE, cENABLESCROLLBARFLAG) - (successState "EnableScrollBar") - val GetScrollPos = winCall2 (user "GetScrollPos") (cHWND,cSCROLLBARTYPE) cInt - val SetScrollRange = winCall5(user "SetScrollRange") (cHWND,cSCROLLBARTYPE,cInt,cInt,cBool) cBool - val SetScrollPos = winCall4(user "SetScrollPos") (cHWND,cSCROLLBARTYPE,cInt,cBool) cInt - val ShowScrollBar = winCall3(user "ShowScrollBar") (cHWND,cSCROLLBARTYPE,cBool) (successState "ShowScrollBar") - - val ScrollWindow = winCall5(user "ScrollWindow") (cHWND,cInt,cInt,cConstStar cRect,cConstStar cRect) - (successState "ScrollWindow") - - local - val scrollDC = - winCall7 (user "ScrollDC") (cHDC,cInt,cInt,cConstStar cRect,cConstStar cRect,cHRGN,cStar cRect) - (successState "ScrollDC") - - val scrollWindowEx = winCall8(user "ScrollWindowEx") - (cHWND,cInt,cInt,cConstStar cRect,cConstStar cRect,cHRGN,cStar cRect,cSCROLLWINDOWFLAG) - (successState "ScrollWindowEx") - in - fun ScrollDC(hDC, dx, dy, prcScroll, prcClip, hrgnUpdate): RECT = - let - val v = ref{top=0, bottom=0, left=0, right=0} - val () = scrollDC(hDC, dx, dy, prcScroll, prcClip, hrgnUpdate, v) - in - ! v - end - and ScrollWindowEx(hWnd, dx, dy, prcScroll, prcClip, hrgnUpdate, flags) = - let - val v = ref{top=0, bottom=0, left=0, right=0} - val () = - scrollWindowEx(hWnd, dx, dy, prcScroll, prcClip, hrgnUpdate, v, flags) - in - ! v - end - end - - local - val {ctype = {size=sizeStruct, ...}, ...} = breakConversion cSCROLLINFOSTRUCT - - val getScrollInfo = - winCall3 (user "GetScrollInfo") (cHWND, cSCROLLBARTYPE, cStar cSCROLLINFOSTRUCT) - (successState "GetScrollInfo") - and setScrollInfo = - winCall4 (user "SetScrollInfo") (cHWND, cSCROLLBARTYPE, cConstStar cSCROLLINFOSTRUCT, cBool) cInt - in - fun GetScrollInfo(hwnd, sbt, options): SCROLLINFO = - let - val v = ref(Word.toInt sizeStruct, options, 0, 0, 0, 0, 0) - val _: unit = getScrollInfo(hwnd, sbt, v) - val (_, _, minPos, maxPos, pageSize, pos, trackPos) = ! v - in - {minPos = minPos, maxPos = maxPos, pageSize = pageSize, - pos = pos, trackPos = trackPos} - end - - and SetScrollInfo(hwnd, sbt, options, - { minPos, maxPos, pageSize, pos, trackPos}, redraw): int = - setScrollInfo(hwnd, sbt, - (Word.toInt sizeStruct, options, minPos, maxPos, pageSize, pos, trackPos), redraw) - end - end - end -end; - -(* -let - open Scrollbar.Style - - (* The same values are used with different names for horizontal and vertical bars. - Maybe we should generate different names according to whether the SBS_VERT flag - is set. *) - val flagTable = - [(SBS_VERT, "SBS_VERT"), - (SBS_TOPALIGN, "SBS_TOPALIGN"), - (SBS_BOTTOMALIGN, "SBS_BOTTOMALIGN"), - (SBS_SIZEBOX, "SBS_SIZEBOX"), - (SBS_SIZEGRIP, "SBS_SIZEGRIP"), - (WS_POPUP, "WS_POPUP"), - (WS_CHILD, "WS_CHILD"), - (WS_MINIMIZE, "WS_MINIMIZE"), - (WS_VISIBLE, "WS_VISIBLE"), - (WS_DISABLED, "WS_DISABLED"), - (WS_CLIPSIBLINGS, "WS_CLIPSIBLINGS"), - (WS_CLIPCHILDREN, "WS_CLIPCHILDREN"), - (WS_MAXIMIZE, "WS_MAXIMIZE"), - (WS_CAPTION, "WS_CAPTION"), - (WS_BORDER, "WS_BORDER"), - (WS_DLGFRAME, "WS_DLGFRAME"), - (WS_VSCROLL, "WS_VSCROLL"), - (WS_HSCROLL, "WS_HSCROLL"), - (WS_SYSMENU, "WS_SYSMENU"), - (WS_THICKFRAME, "WS_THICKFRAME"), - (WS_GROUP, "WS_GROUP"), - (WS_TABSTOP, "WS_TABSTOP"), - (WS_MINIMIZEBOX, "WS_MINIMIZEBOX"), - (WS_MAXIMIZEBOX, "WS_MAXIMIZEBOX")] - - fun accumulateFlags f [] = [] - | accumulateFlags f ((w, s)::t) = - if allSet(w, f) then s :: accumulateFlags(clear(w, f)) t - else accumulateFlags f t - - fun printFlags(put, beg, brk, nd) depth _ x = - (* This is just the code to print a list. *) - let - - val stringFlags = accumulateFlags x flagTable - fun plist [] depth = () - | plist _ 0 = put "..." - | plist [h] depth = put h - | plist (h::t) depth = - ( put (h^","); - brk (1, 0); - plist t (depth - 1) - ) - in - beg (3, false); - put "["; - if depth <= 0 then put "..." else plist stringFlags depth; - put "]"; - nd () - end -in - PolyML.install_pp printFlags -end; -*) diff --git a/mlsource/extra/Win/Shape.sml b/mlsource/extra/Win/Shape.sml deleted file mode 100644 index 65aace72..00000000 --- a/mlsource/extra/Win/Shape.sml +++ /dev/null @@ -1,108 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Shape: - sig - type HBRUSH - type HDC - type POINT = { x: int, y: int } - type RECT = { top: int, left: int, bottom: int, right: int } - - val Chord : HDC * RECT * POINT * POINT -> unit - val Ellipse : HDC * RECT -> unit - val FillRect : HDC * RECT * HBRUSH -> unit - val FrameRect : HDC * RECT * HBRUSH -> unit - val InvertRect : HDC * RECT -> unit - val Pie : HDC * RECT * POINT * POINT -> unit - val Polygon : HDC * POINT list -> unit - val Rectangle : HDC * RECT -> unit - val RoundRect : HDC * RECT * int * int -> unit - end = -struct - local - open Foreign Base - in - type HDC = HDC and HBRUSH = HBRUSH - type RECT = RECT and POINT = POINT - (* FILLED SHAPES *) - (* Strangely, some of these are in user32 and some in gdi32. *) - val FillRect = winCall3 (user "FillRect") (cHDC,cConstStar cRect,cHBRUSH) (successState "FillRect") - val FrameRect = winCall3 (user "FrameRect") (cHDC,cConstStar cRect,cHBRUSH) (successState "FrameRect") - val InvertRect = winCall2 (user "InvertRect") (cHDC,cConstStar cRect) (successState "InvertRect") - - local - val chord = - winCall9 (gdi "Chord") (cHDC,cInt,cInt,cInt,cInt,cInt,cInt,cInt,cInt) (successState "Chord") - in - fun Chord (h,{left,top,right,bottom}: RECT,{x=x1,y=y1}: POINT,{x=x2,y=y2}: POINT) = - chord (h,left,top,right,bottom,x1,y1,x2,y2) - end - - local - val ellipse = - winCall5 (gdi "Ellipse") (cHDC,cInt,cInt,cInt,cInt) (successState "Ellipse") - in - fun Ellipse (h,{left,top,right,bottom}: RECT) = - ellipse(h,left,top,right,bottom) - end - - local - val pie = - winCall9 (gdi "Pie") - (cHDC,cInt,cInt,cInt,cInt,cInt,cInt,cInt,cInt) (successState "Pie") - in - fun Pie (h,{left,top,right,bottom}: RECT,{x=x1,y=y1}: POINT,{x=x2,y=y2}: POINT) = - pie(h,left,top,right,bottom,x1,y1,x2,y2) - end - - local - val polygon = winCall3 (gdi "Polygon") (cHDC,cPointer,cInt) (successState "Polygon") - val ptList = list2Vector cPoint - in - fun Polygon (h,pts: POINT list) = - let - val (ptarr, count) = ptList pts - in - polygon (h, ptarr, count) handle ex => (Memory.free ptarr; raise ex); - Memory.free ptarr - end - end - - local - val rectangle = - winCall5 (gdi "Rectangle") (cHDC,cInt,cInt,cInt,cInt) (successState "Rectangle") - in - fun Rectangle(h,{left,top,right,bottom}: RECT) = - rectangle(h,left,top,right,bottom) - end - - local - val roundRect = - winCall7 (gdi "RoundRect") (cHDC,cInt,cInt,cInt,cInt,cInt,cInt) (successState "RoundRect") - in - fun RoundRect(h,{left,top,right,bottom}: RECT,w,ht) = - roundRect(h,left,top,right,bottom,w,ht) - end - - (* - Other Filled shape functions: - PolyPolygon - *) - - end -end; diff --git a/mlsource/extra/Win/Static.sml b/mlsource/extra/Win/Static.sml deleted file mode 100644 index 4425a008..00000000 --- a/mlsource/extra/Win/Static.sml +++ /dev/null @@ -1,200 +0,0 @@ -(* - Copyright (c) 2001 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* Static windows e.g. labels. *) -structure Static: -sig - structure Style: - sig - include BIT_FLAGS where type flags = Window.Style.flags - val WS_OVERLAPPED: flags and WS_POPUP: flags and WS_CHILD: flags and WS_MINIMIZE: flags - and WS_VISIBLE: flags and WS_DISABLED:flags and WS_CLIPSIBLINGS:flags - and WS_CLIPCHILDREN:flags and WS_MAXIMIZE:flags and WS_CAPTION:flags - and WS_BORDER:flags and WS_DLGFRAME:flags and WS_VSCROLL:flags and WS_HSCROLL:flags - and WS_SYSMENU:flags and WS_THICKFRAME:flags and WS_GROUP:flags and WS_TABSTOP:flags - and WS_MINIMIZEBOX:flags and WS_MAXIMIZEBOX:flags and WS_TILED:flags and WS_ICONIC:flags - and WS_SIZEBOX:flags and WS_OVERLAPPEDWINDOW:flags and WS_TILEDWINDOW:flags - and WS_POPUPWINDOW:flags and WS_CHILDWINDOW:flags - and SS_LEFT: flags and SS_CENTER: flags and SS_RIGHT: flags and SS_ICON: flags - and SS_BLACKRECT: flags and SS_GRAYRECT: flags and SS_WHITERECT: flags - and SS_BLACKFRAME: flags and SS_GRAYFRAME: flags and SS_WHITEFRAME: flags - and SS_USERITEM: flags and SS_SIMPLE: flags and SS_LEFTNOWORDWRAP: flags - and SS_OWNERDRAW: flags and SS_BITMAP: flags and SS_ENHMETAFILE: flags - and SS_ETCHEDHORZ: flags and SS_ETCHEDVERT: flags and SS_ETCHEDFRAME: flags - and SS_TYPEMASK: flags and SS_NOPREFIX: flags and SS_NOTIFY: flags and SS_CENTERIMAGE: flags - and SS_RIGHTJUST: flags and SS_REALSIZEIMAGE: flags and SS_SUNKEN: flags - and SS_ENDELLIPSIS: flags and SS_PATHELLIPSIS: flags and SS_WORDELLIPSIS: flags - and SS_ELLIPSISMASK: flags - end - - structure Notifications: - sig - val STN_CLICKED: int - val STN_DBLCLK: int - val STN_ENABLE: int - val STN_DISABLE: int - end -end -= -struct - structure Style = - struct - open Window.Style (* Include all the windows styles. *) - - val SS_LEFT: flags = fromWord 0wx00000000 - val SS_CENTER: flags = fromWord 0wx00000001 - val SS_RIGHT: flags = fromWord 0wx00000002 - val SS_ICON: flags = fromWord 0wx00000003 - val SS_BLACKRECT: flags = fromWord 0wx00000004 - val SS_GRAYRECT: flags = fromWord 0wx00000005 - val SS_WHITERECT: flags = fromWord 0wx00000006 - val SS_BLACKFRAME: flags = fromWord 0wx00000007 - val SS_GRAYFRAME: flags = fromWord 0wx00000008 - val SS_WHITEFRAME: flags = fromWord 0wx00000009 - val SS_USERITEM: flags = fromWord 0wx0000000A - val SS_SIMPLE: flags = fromWord 0wx0000000B - val SS_LEFTNOWORDWRAP: flags = fromWord 0wx0000000C - val SS_OWNERDRAW: flags = fromWord 0wx0000000D - val SS_BITMAP: flags = fromWord 0wx0000000E - val SS_ENHMETAFILE: flags = fromWord 0wx0000000F - val SS_ETCHEDHORZ: flags = fromWord 0wx00000010 - val SS_ETCHEDVERT: flags = fromWord 0wx00000011 - val SS_ETCHEDFRAME: flags = fromWord 0wx00000012 - val SS_TYPEMASK: flags = fromWord 0wx0000001F - val SS_NOPREFIX: flags = fromWord 0wx00000080 - val SS_NOTIFY: flags = fromWord 0wx00000100 - val SS_CENTERIMAGE: flags = fromWord 0wx00000200 - val SS_RIGHTJUST: flags = fromWord 0wx00000400 - val SS_REALSIZEIMAGE: flags = fromWord 0wx00000800 - val SS_SUNKEN: flags = fromWord 0wx00001000 - val SS_ENDELLIPSIS: flags = fromWord 0wx00004000 - val SS_PATHELLIPSIS: flags = fromWord 0wx00008000 - val SS_WORDELLIPSIS: flags = fromWord 0wx0000C000 - val SS_ELLIPSISMASK: flags = fromWord 0wx0000C000 - - val all = flags[Window.Style.all, SS_LEFT, SS_CENTER, SS_RIGHT, SS_ICON, SS_BLACKRECT, - SS_GRAYRECT, SS_WHITERECT, SS_BLACKFRAME, SS_GRAYFRAME, - SS_WHITEFRAME, SS_USERITEM, SS_SIMPLE, SS_LEFTNOWORDWRAP, - SS_OWNERDRAW, SS_BITMAP, SS_ENHMETAFILE, SS_ETCHEDHORZ, - SS_ETCHEDVERT, SS_ETCHEDFRAME, SS_TYPEMASK, SS_NOPREFIX, - SS_NOTIFY, SS_CENTERIMAGE, SS_RIGHTJUST, SS_REALSIZEIMAGE, - SS_SUNKEN, SS_ENDELLIPSIS, SS_PATHELLIPSIS, SS_WORDELLIPSIS, - SS_ELLIPSISMASK] - val intersect = - List.foldl (fn (a, b) => fromWord(SysWord.andb(toWord a, toWord b))) all - end - - structure Notifications = - struct - val STN_CLICKED = 0 - val STN_DBLCLK = 1 - val STN_ENABLE = 2 - val STN_DISABLE = 3 - end -end; - -(* -let - open Static.Style - - fun getType w = - let - val typeField = fromWord(SysWord.andb(toWord w, toWord SS_TYPEMASK)) - in - if typeField = SS_LEFT then "SS_LEFT" - else if typeField = SS_CENTER then "SS_CENTER" - else if typeField = SS_RIGHT then "SS_RIGHT" - else if typeField = SS_ICON then "SS_ICON" - else if typeField = SS_BLACKRECT then "SS_BLACKRECT" - else if typeField = SS_GRAYRECT then "SS_GRAYRECT" - else if typeField = SS_WHITERECT then "SS_WHITERECT" - else if typeField = SS_BLACKFRAME then "SS_BLACKFRAME" - else if typeField = SS_GRAYFRAME then "SS_GRAYFRAME" - else if typeField = SS_WHITEFRAME then "SS_WHITEFRAME" - else if typeField = SS_USERITEM then "SS_USERITEM" - else if typeField = SS_SIMPLE then "SS_SIMPLE" - else if typeField = SS_LEFTNOWORDWRAP then "SS_LEFTNOWORDWRAP" - else if typeField = SS_OWNERDRAW then "SS_OWNERDRAW" - else if typeField = SS_BITMAP then "SS_BITMAP" - else if typeField = SS_ENHMETAFILE then "SS_ENHMETAFILE" - else if typeField = SS_ETCHEDHORZ then "SS_ETCHEDHORZ" - else if typeField = SS_ETCHEDVERT then "SS_ETCHEDVERT" - else if typeField = SS_ETCHEDFRAME then "SS_ETCHEDFRAME" - else "??" - end - - val flagTable = - [(SS_NOPREFIX, "SS_NOPREFIX"), - (SS_NOTIFY, "SS_NOTIFY"), - (SS_CENTERIMAGE, "SS_CENTERIMAGE"), - (SS_RIGHTJUST, "SS_RIGHTJUST"), - (SS_REALSIZEIMAGE, "SS_REALSIZEIMAGE"), - (SS_SUNKEN, "SS_SUNKEN"), - (SS_WORDELLIPSIS, "SS_WORDELLIPSIS"), (* Must come before the next two. *) - (SS_ENDELLIPSIS, "SS_ENDELLIPSIS"), - (SS_PATHELLIPSIS, "SS_PATHELLIPSIS"), - (WS_POPUP, "WS_POPUP"), - (WS_CHILD, "WS_CHILD"), - (WS_MINIMIZE, "WS_MINIMIZE"), - (WS_VISIBLE, "WS_VISIBLE"), - (WS_DISABLED, "WS_DISABLED"), - (WS_CLIPSIBLINGS, "WS_CLIPSIBLINGS"), - (WS_CLIPCHILDREN, "WS_CLIPCHILDREN"), - (WS_MAXIMIZE, "WS_MAXIMIZE"), - (WS_CAPTION, "WS_CAPTION"), - (WS_BORDER, "WS_BORDER"), - (WS_DLGFRAME, "WS_DLGFRAME"), - (WS_VSCROLL, "WS_VSCROLL"), - (WS_HSCROLL, "WS_HSCROLL"), - (WS_SYSMENU, "WS_SYSMENU"), - (WS_THICKFRAME, "WS_THICKFRAME"), - (WS_GROUP, "WS_GROUP"), - (WS_TABSTOP, "WS_TABSTOP"), - (WS_MINIMIZEBOX, "WS_MINIMIZEBOX"), - (WS_MAXIMIZEBOX, "WS_MAXIMIZEBOX")] - - fun accumulateFlags f [] = [] - | accumulateFlags f ((w, s)::t) = - if allSet(w, f) then s :: accumulateFlags(clear(w, f)) t - else accumulateFlags f t - - fun printFlags(put, beg, brk, nd) depth _ x = - (* This is just the code to print a list. *) - let - - val stringFlags = getType x :: accumulateFlags x flagTable - fun plist [] depth = () - | plist _ 0 = put "..." - | plist [h] depth = put h - | plist (h::t) depth = - ( put (h^","); - brk (1, 0); - plist t (depth - 1) - ) - in - beg (3, false); - put "["; - if depth <= 0 then put "..." else plist stringFlags depth; - put "]"; - nd () - end -in - PolyML.install_pp printFlags -end; -*) \ No newline at end of file diff --git a/mlsource/extra/Win/Transform.sml b/mlsource/extra/Win/Transform.sml deleted file mode 100644 index 8135cb58..00000000 --- a/mlsource/extra/Win/Transform.sml +++ /dev/null @@ -1,223 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Transform: - sig - type HDC (*= Base.HDC*) - type HWND (*= Base.HWND*) - type POINT = { x: int, y: int } - type SIZE = { cx: int, cy: int } - datatype Fraction = Fraction of {num: int, denom: int} - - datatype - MapMode = - MM_ANISOTROPIC - | MM_HIENGLISH - | MM_HIMETRIC - | MM_ISOTROPIC - | MM_LOENGLISH - | MM_LOMETRIC - | MM_TEXT - | MM_TWIPS - val MM_MAX : MapMode - val MM_MAX_FIXEDSCALE : MapMode - val MM_MIN : MapMode - - type XForm = { m11: real, m12: real, m21: real, m22: real, dx: real, dy: real } - - type XFormType - val MWT_IDENTITY : XFormType - val MWT_LEFTMULTIPLY : XFormType - val MWT_MAX : XFormType - val MWT_MIN : XFormType - val MWT_RIGHTMULTIPLY : XFormType - - type GraphicsMode - val GM_ADVANCED : GraphicsMode - val GM_COMPATIBLE : GraphicsMode - val GM_ERROR : GraphicsMode - - val ClientToScreen : HWND * POINT -> POINT - val CombineTransform : XForm * XForm -> XForm - val DPtoLP : HDC * POINT list -> POINT list - val GetCurrentPositionEx : HDC -> POINT - val GetGraphicsMode : HDC -> GraphicsMode - val GetMapMode : HDC -> MapMode - val GetViewportExtEx : HDC -> SIZE - val GetViewportOrgEx : HDC -> POINT - val GetWindowExtEx : HDC -> SIZE - val GetWindowOrgEx : HDC -> POINT - val GetWorldTransform : HDC -> XForm - val LPtoDP : HDC * POINT list -> POINT list - val MapWindowPoints : HWND * HWND * POINT list -> POINT list - val ModifyWorldTransform : HDC * XForm * XFormType -> unit - val OffsetViewportOrgEx : HDC * int * int -> POINT - val OffsetWindowOrgEx : HDC * int * int -> POINT - val ScaleViewportExtEx : HWND * Fraction * Fraction -> SIZE - val ScaleWindowExtEx : HWND * Fraction * Fraction -> SIZE - val ScreenToClient : HWND * POINT -> POINT - val SetGraphicsMode : HDC * GraphicsMode -> GraphicsMode - val SetMapMode : HDC * MapMode -> MapMode - val SetViewportExtEx : HDC * int * int -> SIZE - val SetViewportOrgEx : HDC * int * int -> POINT - val SetWindowExtEx : HDC * int * int -> SIZE - val SetWindowOrgEx : HDC * int * int -> POINT - val SetWorldTransform : HDC * XForm -> unit - - end = -struct - local - open Foreign Base GdiBase - in - type HDC = Base.HDC and HWND = Base.HWND - type POINT = POINT and SIZE = SIZE - - open GdiBase - - (* COORDINATE SPACES AND TRANSFORMATIONS *) - local - datatype GraphicsMode = W of int - in - type GraphicsMode = GraphicsMode - val GRAPHICSMODE = absConversion {abs = W, rep = fn W n => n} cInt - - val GM_ERROR (* ???? *) = W 0 - val GM_COMPATIBLE = W (1) - val GM_ADVANCED = W (2) - end - - - (* An XFORM is a struct of six floats. Wrap this as an ML record for clarity *) - type XForm = { m11: real, m12: real, m21: real, m22: real, dx: real, dy: real } - - local - fun breakXForm {m11,m12,m21,m22,dx,dy} = (m11,m12,m21,m22,dx,dy) - fun mkXForm (m11,m12,m21,m22,dx,dy) = {m11=m11,m12=m12,m21=m21,m22=m22,dx=dx,dy=dy} - in - val XFORM = - absConversion {abs=mkXForm, rep=breakXForm} - (cStruct6 (cFloat,cFloat,cFloat,cFloat,cFloat,cFloat)) - end - - local - datatype XFormType = W of int - in - type XFormType = XFormType - val XFORMTYPE = absConversion {abs = W, rep = fn W n => n} cDWORD - - val MWT_IDENTITY = W (1) - val MWT_LEFTMULTIPLY = W (2) - val MWT_RIGHTMULTIPLY = W (3) - val MWT_MIN = MWT_IDENTITY - val MWT_MAX = MWT_RIGHTMULTIPLY - end - - datatype Fraction = Fraction of {num:int, denom:int} - - local - val clientToScreen = winCall2(user "ClientToScreen") (cHWND, cStar cPoint) (successState "ClientToScreen") - val combineTransform = winCall3(gdi "CombineTransform") (cStar XFORM, cConstStar XFORM, cConstStar XFORM) (successState "CombineTransform") - val getCurrentPositionEx = winCall2(gdi "GetCurrentPositionEx") (cHDC, cStar cPoint) (successState "GetCurrentPositionEx") - val getViewportExtEx = winCall2(gdi "GetViewportExtEx") (cHDC, cStar cSize) (successState "GetViewportExtEx") - val getViewportOrgEx = winCall2(gdi "GetViewportOrgEx") (cHDC, cStar cPoint) (successState "GetViewportOrgEx") - val getWindowExtEx = winCall2(gdi "GetWindowExtEx") (cHDC, cStar cSize) (successState "GetWindowExtEx") - val getWindowOrgEx = winCall2(gdi "GetWindowOrgEx") (cHDC, cStar cPoint) (successState "GetWindowOrgEx") - val getWorldTransform = winCall2(gdi "GetWorldTransform") (cHDC, cStar XFORM) (successState "GetWorldTransform") - val offsetViewportOrgEx = winCall4(gdi "OffsetViewportOrgEx") (cHDC, cInt, cInt, cStar cPoint) (successState "OffsetViewportOrgEx") - val offsetWindowOrgEx = winCall4(gdi "OffsetWindowOrgEx") (cHDC, cInt, cInt, cStar cPoint) (successState "OffsetWindowOrgEx") - val screenToClient = winCall2(user "ScreenToClient") (cHWND, cStar cPoint) (successState "ScreenToClient") - val setViewportExtEx = winCall4(gdi "SetViewportExtEx") (cHDC, cInt, cInt, cStar cSize) (successState "SetViewportExtEx") - val setViewportOrgEx = winCall4(gdi "SetViewportOrgEx") (cHDC, cInt, cInt, cStar cPoint) (successState "SetViewportOrgEx") - val setWindowExtEx = winCall4(gdi "SetWindowExtEx") (cHDC, cInt, cInt, cStar cSize) (successState "SetWindowExtEx") - val setWindowOrgEx = winCall4(gdi "SetWindowOrgEx") (cHDC, cInt, cInt, cStar cPoint) (successState "SetWindowOrgEx") - val scaleViewportExtEx = - winCall6 (gdi "ScaleViewportExtEx") (cHWND,cInt,cInt,cInt,cInt,cStar cSize) (successState "ScaleViewportExtEx") - val scaleWindowExtEx = - winCall6 (gdi "ScaleWindowExtEx") (cHWND,cInt,cInt,cInt,cInt,cStar cSize) (successState "ScaleWindowExtEx") - - val zeroXFORM: XForm = { m11=0.0, m12=0.0, m21=0.0, m22=0.0, dx=0.0, dy=0.0 } - val zeroPoint: POINT = { x = 0, y = 0 } - val zeroSize: SIZE = { cx = 0, cy = 0 } - - in - fun ClientToScreen(w, p) = let val r = ref p in clientToScreen(w, r); !r end - and CombineTransform(a, b) = let val r = ref zeroXFORM in combineTransform(r, a, b); ! r end - and GetCurrentPositionEx hdc = let val p = ref zeroPoint in getCurrentPositionEx(hdc, p); !p end - and GetViewportExtEx hdc = let val s = ref zeroSize in getViewportExtEx(hdc, s); !s end - and GetViewportOrgEx hdc = let val p = ref zeroPoint in getViewportOrgEx(hdc, p); !p end - and GetWindowExtEx hdc = let val s = ref zeroSize in getWindowExtEx(hdc, s); !s end - and GetWindowOrgEx hdc = let val p = ref zeroPoint in getWindowOrgEx(hdc, p); !p end - and GetWorldTransform hdc = let val r = ref zeroXFORM in getWorldTransform(hdc, r); !r end - and OffsetViewportOrgEx (hdc, x, y) = - let val p = ref zeroPoint in offsetViewportOrgEx(hdc, x, y, p); !p end - and OffsetWindowOrgEx (hdc, x, y) = - let val p = ref zeroPoint in offsetWindowOrgEx(hdc, x, y, p); !p end - and ScreenToClient(hw, p) = let val r = ref p in screenToClient(hw, r); !r end - and SetViewportExtEx (hdc, x, y) = - let val p = ref zeroSize in setViewportExtEx(hdc, x, y, p); !p end - and SetViewportOrgEx (hdc, x, y) = - let val p = ref zeroPoint in setViewportOrgEx(hdc, x, y, p); !p end - and SetWindowExtEx (hdc, x, y) = - let val p = ref zeroSize in setWindowExtEx(hdc, x, y, p); !p end - and SetWindowOrgEx (hdc, x, y) = - let val p = ref zeroPoint in setWindowOrgEx(hdc, x, y, p); !p end - and ScaleViewportExtEx (h,Fraction{num=n1,denom=d1},Fraction{num=n2,denom=d2}) = - let val p = ref zeroSize in scaleViewportExtEx(h,n1,d1,n2,d2,p); !p end - and ScaleWindowExtEx (h,Fraction{num=n1,denom=d1},Fraction{num=n2,denom=d2}) = - let val p = ref zeroSize in scaleWindowExtEx(h,n1,d1,n2,d2,p); !p end - end - - val ModifyWorldTransform = winCall3(gdi "ModifyWorldTransform") (cHDC, cConstStar XFORM, XFORMTYPE) (successState "ModifyWorldTransform") - val SetWorldTransform = winCall2(gdi "SetWorldTransform") (cHDC, cConstStar XFORM) (successState "SetWorldTransform") - - - val GetMapMode = winCall1(gdi "GetMapMode") (cHDC) cMAPMODE - val SetMapMode = winCall2(gdi "SetMapMode") (cHDC,cMAPMODE) cMAPMODE - (* Should check the result is non-zero. *) - val GetGraphicsMode = winCall1 (gdi "GetGraphicsMode") (cHDC) GRAPHICSMODE - val SetGraphicsMode = winCall2 (gdi "SetGraphicsMode") (cHDC, GRAPHICSMODE) GRAPHICSMODE - - local - val dPtoLP = winCall3 (gdi "DPtoLP") (cHDC,cPointer,cInt) (successState "DPtoLP") - and lPtoDP = winCall3 (gdi "LPtoDP") (cHDC,cPointer,cInt) (successState "LPtoDP") - (* The result is the bits added in each direction to make the mapping or is - zero if there is an error. The caller is supposed to call SetLastError and - check GetLastError because the result could legitimately be zero. *) - and mapWindowPoints = winCall4 (user "MapWindowPoints") (cHWND,cHWND,cPointer,cInt) cInt - - val {load=fromPt, store=toPt, ctype={size=sizePt, ...}, ...} = breakConversion cPoint - - fun mapPts call pts = - let - val count = List.length pts - open Memory - infix 6 ++ - val mem = malloc(Word.fromInt count * sizePt) - val _ = List.foldl (fn (p,n) => (ignore(toPt(n, p)); n ++ sizePt)) mem pts - val _ = call(mem, count) handle ex => (free mem; raise ex) - in - List.tabulate(count, fn i => fromPt(mem ++ (Word.fromInt i * sizePt))) - before free mem - end - in - fun DPtoLP(h,pts) = mapPts(fn (mem, count) => dPtoLP(h, mem, count)) pts - and LPtoDP(h,pts) = mapPts(fn (mem, count) => lPtoDP(h, mem, count)) pts - and MapWindowPoints (h1,h2,pts) = mapPts(fn (mem, count) => mapWindowPoints(h1, h2, mem, count)) pts - end - end -end; diff --git a/mlsource/extra/Win/WinBase.sml b/mlsource/extra/Win/WinBase.sml deleted file mode 100644 index 9e6d4bbe..00000000 --- a/mlsource/extra/Win/WinBase.sml +++ /dev/null @@ -1,223 +0,0 @@ -(* - Copyright (c) 2001-7, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* This contains the types used in the Win structure. *) -structure WinBase = -struct - local - open Foreign Base - in - - structure Style :> - sig - include BIT_FLAGS - val WS_BORDER : flags - val WS_CAPTION : flags - val WS_CHILD : flags - val WS_CHILDWINDOW : flags - val WS_CLIPCHILDREN : flags - val WS_CLIPSIBLINGS : flags - val WS_DISABLED : flags - val WS_DLGFRAME : flags - val WS_GROUP : flags - val WS_HSCROLL : flags - val WS_ICONIC : flags - val WS_MAXIMIZE : flags - val WS_MAXIMIZEBOX : flags - val WS_MINIMIZE : flags - val WS_MINIMIZEBOX : flags - val WS_OVERLAPPED : flags - val WS_OVERLAPPEDWINDOW : flags - val WS_POPUP : flags - val WS_POPUPWINDOW : flags - val WS_SIZEBOX : flags - val WS_SYSMENU : flags - val WS_TABSTOP : flags - val WS_THICKFRAME : flags - val WS_TILED : flags - val WS_TILEDWINDOW : flags - val WS_VISIBLE : flags - val WS_VSCROLL : flags - end = - struct - type flags = SysWord.word - fun toWord f = f - fun fromWord f = f - val flags = List.foldl (fn (a, b) => SysWord.orb(a,b)) 0w0 - fun allSet (fl1, fl2) = SysWord.andb(fl1, fl2) = fl1 - fun anySet (fl1, fl2) = SysWord.andb(fl1, fl2) <> 0w0 - fun clear (fl1, fl2) = SysWord.andb(SysWord.notb fl1, fl2) - - (* Window styles. *) - val WS_OVERLAPPED: flags = 0wx00000000 - val WS_POPUP: flags = 0wx80000000 - val WS_CHILD: flags = 0wx40000000 - val WS_MINIMIZE: flags = 0wx20000000 - val WS_VISIBLE: flags = 0wx10000000 - val WS_DISABLED: flags = 0wx08000000 - val WS_CLIPSIBLINGS: flags = 0wx04000000 - val WS_CLIPCHILDREN: flags = 0wx02000000 - val WS_MAXIMIZE: flags = 0wx01000000 - val WS_CAPTION: flags = 0wx00C00000 (* WS_BORDER | WS_DLGFRAME *) - val WS_BORDER: flags = 0wx00800000 - val WS_DLGFRAME: flags = 0wx00400000 - val WS_VSCROLL: flags = 0wx00200000 - val WS_HSCROLL: flags = 0wx00100000 - val WS_SYSMENU: flags = 0wx00080000 - val WS_THICKFRAME: flags = 0wx00040000 - val WS_GROUP: flags = 0wx00020000 - val WS_TABSTOP: flags = 0wx00010000 - val WS_MINIMIZEBOX: flags = 0wx00020000 - val WS_MAXIMIZEBOX: flags = 0wx00010000 - val WS_TILED: flags = WS_OVERLAPPED - val WS_ICONIC: flags = WS_MINIMIZE - val WS_SIZEBOX: flags = WS_THICKFRAME - val WS_OVERLAPPEDWINDOW = - flags[WS_OVERLAPPED, WS_CAPTION, WS_SYSMENU, - WS_THICKFRAME, WS_MINIMIZEBOX, WS_MAXIMIZEBOX] - val WS_TILEDWINDOW = WS_OVERLAPPEDWINDOW - val WS_POPUPWINDOW = - flags[WS_POPUP, WS_BORDER, WS_SYSMENU] - val WS_CHILDWINDOW = WS_CHILD - - val all = flags[WS_OVERLAPPED, WS_POPUP, WS_CHILD, WS_MINIMIZE, WS_VISIBLE, - WS_DISABLED, WS_CLIPSIBLINGS, WS_CLIPCHILDREN, WS_MAXIMIZE, - WS_CAPTION, WS_BORDER, WS_DLGFRAME, WS_VSCROLL, WS_HSCROLL, - WS_SYSMENU, WS_THICKFRAME, WS_GROUP, WS_TABSTOP, WS_MINIMIZEBOX, - WS_MAXIMIZEBOX] - - val intersect = List.foldl (fn (a, b) => SysWord.andb(a,b)) all - end - - structure ExStyle:> - sig - include BIT_FLAGS - val WS_EX_DLGMODALFRAME: flags and WS_EX_NOPARENTNOTIFY: flags and WS_EX_TOPMOST: flags - and WS_EX_ACCEPTFILES : flags and WS_EX_TRANSPARENT: flags and WS_EX_MDICHILD: flags - and WS_EX_TOOLWINDOW: flags and WS_EX_WINDOWEDGE: flags and WS_EX_CLIENTEDGE: flags - and WS_EX_CONTEXTHELP: flags and WS_EX_RIGHT: flags and WS_EX_LEFT: flags - and WS_EX_RTLREADING: flags and WS_EX_LTRREADING: flags and WS_EX_LEFTSCROLLBAR: flags - and WS_EX_RIGHTSCROLLBAR: flags and WS_EX_CONTROLPARENT: flags and WS_EX_STATICEDGE: flags - and WS_EX_APPWINDOW: flags and WS_EX_OVERLAPPEDWINDOW: flags and WS_EX_PALETTEWINDOW: flags - end = - struct - type flags = SysWord.word - fun toWord f = f - fun fromWord f = f - val flags = List.foldl (fn (a, b) => SysWord.orb(a,b)) 0w0 - fun allSet (fl1, fl2) = SysWord.andb(fl1, fl2) = fl1 - fun anySet (fl1, fl2) = SysWord.andb(fl1, fl2) <> 0w0 - fun clear (fl1, fl2) = SysWord.andb(SysWord.notb fl1, fl2) - val WS_EX_DLGMODALFRAME = 0wx00000001 - val WS_EX_NOPARENTNOTIFY = 0wx00000004 - val WS_EX_TOPMOST = 0wx00000008 - val WS_EX_ACCEPTFILES = 0wx00000010 - val WS_EX_TRANSPARENT = 0wx00000020 - val WS_EX_MDICHILD = 0wx00000040 - val WS_EX_TOOLWINDOW = 0wx00000080 - val WS_EX_WINDOWEDGE = 0wx00000100 - val WS_EX_CLIENTEDGE = 0wx00000200 - val WS_EX_CONTEXTHELP = 0wx00000400 - - val WS_EX_RIGHT = 0wx00001000 - val WS_EX_LEFT = 0wx00000000 - val WS_EX_RTLREADING = 0wx00002000 - val WS_EX_LTRREADING = 0wx00000000 - val WS_EX_LEFTSCROLLBAR = 0wx00004000 - val WS_EX_RIGHTSCROLLBAR = 0wx00000000 - - val WS_EX_CONTROLPARENT = 0wx00010000 - val WS_EX_STATICEDGE = 0wx00020000 - val WS_EX_APPWINDOW = 0wx00040000 - - - val WS_EX_OVERLAPPEDWINDOW = flags[WS_EX_WINDOWEDGE, WS_EX_CLIENTEDGE] - val WS_EX_PALETTEWINDOW = flags[WS_EX_WINDOWEDGE, WS_EX_TOOLWINDOW, WS_EX_TOPMOST] - - val all = flags[WS_EX_DLGMODALFRAME, WS_EX_NOPARENTNOTIFY, WS_EX_TOPMOST, WS_EX_ACCEPTFILES, - WS_EX_TRANSPARENT, WS_EX_MDICHILD, WS_EX_TOOLWINDOW, WS_EX_WINDOWEDGE, - WS_EX_CLIENTEDGE, WS_EX_CONTEXTHELP, WS_EX_RIGHT, WS_EX_LEFT, WS_EX_RTLREADING, - WS_EX_LTRREADING, WS_EX_LEFTSCROLLBAR, WS_EX_RIGHTSCROLLBAR, WS_EX_CONTROLPARENT, - WS_EX_STATICEDGE, WS_EX_APPWINDOW] - - val intersect = List.foldl (fn (a, b) => SysWord.andb(a,b)) all - end - - datatype WindowPositionStyle = - SWP_ASYNCWINDOWPOS - | SWP_DEFERERASE - | SWP_FRAMECHANGED - | SWP_HIDEWINDOW - | SWP_NOACTIVATE - | SWP_NOCOPYBITS - | SWP_NOMOVE - | SWP_NOOWNERZORDER - | SWP_NOREDRAW - | SWP_NOSENDCHANGING - | SWP_NOSIZE - | SWP_NOZORDER - | SWP_SHOWWINDOW - | SWP_OTHER of Word32.word - - local - val tab = [ - (SWP_NOSIZE, 0wx0001), - (SWP_NOMOVE, 0wx0002), - (SWP_NOZORDER, 0wx0004), - (SWP_NOREDRAW, 0wx0008), - (SWP_NOACTIVATE, 0wx0010), - (SWP_FRAMECHANGED, 0wx0020), (* The frame changed: send WM_NCCALCSIZE *) - (SWP_SHOWWINDOW, 0wx0040), - (SWP_HIDEWINDOW, 0wx0080), - (SWP_NOCOPYBITS, 0wx0100), - (SWP_NOOWNERZORDER, 0wx0200), (* Don't do owner Z ordering *) - (SWP_NOSENDCHANGING, 0wx0400), (* Don't send WM_WINDOWPOSCHANGING *) - (SWP_DEFERERASE, 0wx2000), - (SWP_ASYNCWINDOWPOS, 0wx4000)] - - (* It seems that some other bits are set although they're not defined. *) - fun toWord (SWP_OTHER i) = i | toWord _ = raise Match - in - val cWINDOWPOSITIONSTYLE = tableSetConversion(tab, SOME(SWP_OTHER, toWord)) - end - - (* In C the parent and menu arguments are combined in a rather odd way. *) - datatype ParentType = - PopupWithClassMenu (* Popup or overlapped window using class menu. *) - | PopupWindow of HMENU (* Popup or overlapped window with supplied menu. *) - | ChildWindow of { parent: HWND, id: int } (* Child window. *) - - (* This function is used whenever windows are created. *) - local - open Style - in - (* In the case of a child window the "menu" is actually an integer - which identifies the child in notification messages to the parent. - We silently set or clear the WS_CHILD bit depending on the argument. *) - fun unpackWindowRelation(relation: ParentType, style) = - case relation of - PopupWithClassMenu => - (hwndNull, Memory.null, toWord(clear(WS_CHILD, style))) - | PopupWindow hm => - (hwndNull, voidStarOfHandle hm, toWord(clear(WS_CHILD, style))) - | ChildWindow{parent, id} => - (parent, Memory.sysWord2VoidStar(SysWord.fromInt id), toWord(flags[WS_CHILD, style])) - end - - end -end; diff --git a/mlsource/extra/Win/WinSystem.sml b/mlsource/extra/Win/WinSystem.sml deleted file mode 100644 index 8c2eb51e..00000000 --- a/mlsource/extra/Win/WinSystem.sml +++ /dev/null @@ -1,194 +0,0 @@ -(* - Copyright (c) 2001, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) -structure WinSystem : - sig - type SystemMetrics - val SM_ARRANGE : SystemMetrics - val SM_CLEANBOOT : SystemMetrics - val SM_CMOUSEBUTTONS : SystemMetrics - val SM_CXBORDER : SystemMetrics - val SM_CXCURSOR : SystemMetrics - val SM_CXDLGFRAME : SystemMetrics - val SM_CXDOUBLECLK : SystemMetrics - val SM_CXDRAG : SystemMetrics - val SM_CXEDGE : SystemMetrics - val SM_CXFIXEDFRAME : SystemMetrics - val SM_CXFRAME : SystemMetrics - val SM_CXFULLSCREEN : SystemMetrics - val SM_CXHSCROLL : SystemMetrics - val SM_CXHTHUMB : SystemMetrics - val SM_CXICON : SystemMetrics - val SM_CXICONSPACING : SystemMetrics - val SM_CXMAXIMIZED : SystemMetrics - val SM_CXMAXTRACK : SystemMetrics - val SM_CXMENUCHECK : SystemMetrics - val SM_CXMENUSIZE : SystemMetrics - val SM_CXMIN : SystemMetrics - val SM_CXMINIMIZED : SystemMetrics - val SM_CXMINSPACING : SystemMetrics - val SM_CXMINTRACK : SystemMetrics - val SM_CXSCREEN : SystemMetrics - val SM_CXSIZE : SystemMetrics - val SM_CXSIZEFRAME : SystemMetrics - val SM_CXSMICON : SystemMetrics - val SM_CXSMSIZE : SystemMetrics - val SM_CXVSCROLL : SystemMetrics - val SM_CYBORDER : SystemMetrics - val SM_CYCAPTION : SystemMetrics - val SM_CYCURSOR : SystemMetrics - val SM_CYDLGFRAME : SystemMetrics - val SM_CYDOUBLECLK : SystemMetrics - val SM_CYDRAG : SystemMetrics - val SM_CYEDGE : SystemMetrics - val SM_CYFIXEDFRAME : SystemMetrics - val SM_CYFRAME : SystemMetrics - val SM_CYFULLSCREEN : SystemMetrics - val SM_CYHSCROLL : SystemMetrics - val SM_CYICON : SystemMetrics - val SM_CYICONSPACING : SystemMetrics - val SM_CYKANJIWINDOW : SystemMetrics - val SM_CYMAXIMIZED : SystemMetrics - val SM_CYMAXTRACK : SystemMetrics - val SM_CYMENU : SystemMetrics - val SM_CYMENUCHECK : SystemMetrics - val SM_CYMENUSIZE : SystemMetrics - val SM_CYMIN : SystemMetrics - val SM_CYMINIMIZED : SystemMetrics - val SM_CYMINSPACING : SystemMetrics - val SM_CYMINTRACK : SystemMetrics - val SM_CYSCREEN : SystemMetrics - val SM_CYSIZE : SystemMetrics - val SM_CYSIZEFRAME : SystemMetrics - val SM_CYSMCAPTION : SystemMetrics - val SM_CYSMICON : SystemMetrics - val SM_CYSMSIZE : SystemMetrics - val SM_CYVSCROLL : SystemMetrics - val SM_CYVTHUMB : SystemMetrics - val SM_DBCSENABLED : SystemMetrics - val SM_DEBUG : SystemMetrics - val SM_MENUDROPALIGNMENT : SystemMetrics - val SM_MIDEASTENABLED : SystemMetrics - val SM_MOUSEPRESENT : SystemMetrics - val SM_MOUSEWHEELPRESENT : SystemMetrics - val SM_NETWORK : SystemMetrics - val SM_PENWINDOWS : SystemMetrics - val SM_RESERVED1 : SystemMetrics - val SM_RESERVED2 : SystemMetrics - val SM_RESERVED3 : SystemMetrics - val SM_RESERVED4 : SystemMetrics - val SM_SECURE : SystemMetrics - val SM_SHOWSOUNDS : SystemMetrics - val SM_SLOWMACHINE : SystemMetrics - val SM_SWAPBUTTON : SystemMetrics - val GetSystemMetrics : SystemMetrics -> int - end - = -struct -local - open Foreign - open Base -in - abstype SystemMetrics = ABS of int - with - val SM_CXSCREEN = ABS 0 - val SM_CYSCREEN = ABS 1 - val SM_CXVSCROLL = ABS 2 - val SM_CYHSCROLL = ABS 3 - val SM_CYCAPTION = ABS 4 - val SM_CXBORDER = ABS 5 - val SM_CYBORDER = ABS 6 - val SM_CXDLGFRAME = ABS 7 - val SM_CYDLGFRAME = ABS 8 - val SM_CYVTHUMB = ABS 9 - val SM_CXHTHUMB = ABS 10 - val SM_CXICON = ABS 11 - val SM_CYICON = ABS 12 - val SM_CXCURSOR = ABS 13 - val SM_CYCURSOR = ABS 14 - val SM_CYMENU = ABS 15 - val SM_CXFULLSCREEN = ABS 16 - val SM_CYFULLSCREEN = ABS 17 - val SM_CYKANJIWINDOW = ABS 18 - val SM_MOUSEPRESENT = ABS 19 - val SM_CYVSCROLL = ABS 20 - val SM_CXHSCROLL = ABS 21 - val SM_DEBUG = ABS 22 - val SM_SWAPBUTTON = ABS 23 - val SM_RESERVED1 = ABS 24 - val SM_RESERVED2 = ABS 25 - val SM_RESERVED3 = ABS 26 - val SM_RESERVED4 = ABS 27 - val SM_CXMIN = ABS 28 - val SM_CYMIN = ABS 29 - val SM_CXSIZE = ABS 30 - val SM_CYSIZE = ABS 31 - val SM_CXFRAME = ABS 32 - val SM_CYFRAME = ABS 33 - val SM_CXMINTRACK = ABS 34 - val SM_CYMINTRACK = ABS 35 - val SM_CXDOUBLECLK = ABS 36 - val SM_CYDOUBLECLK = ABS 37 - val SM_CXICONSPACING = ABS 38 - val SM_CYICONSPACING = ABS 39 - val SM_MENUDROPALIGNMENT = ABS 40 - val SM_PENWINDOWS = ABS 41 - val SM_DBCSENABLED = ABS 42 - val SM_CMOUSEBUTTONS = ABS 43 - val SM_SECURE = ABS 44 - val SM_CXEDGE = ABS 45 - val SM_CYEDGE = ABS 46 - val SM_CXMINSPACING = ABS 47 - val SM_CYMINSPACING = ABS 48 - val SM_CXSMICON = ABS 49 - val SM_CYSMICON = ABS 50 - val SM_CYSMCAPTION = ABS 51 - val SM_CXSMSIZE = ABS 52 - val SM_CYSMSIZE = ABS 53 - val SM_CXMENUSIZE = ABS 54 - val SM_CYMENUSIZE = ABS 55 - val SM_ARRANGE = ABS 56 - val SM_CXMINIMIZED = ABS 57 - val SM_CYMINIMIZED = ABS 58 - val SM_CXMAXTRACK = ABS 59 - val SM_CYMAXTRACK = ABS 60 - val SM_CXMAXIMIZED = ABS 61 - val SM_CYMAXIMIZED = ABS 62 - val SM_NETWORK = ABS 63 - val SM_CLEANBOOT = ABS 67 - val SM_CXDRAG = ABS 68 - val SM_CYDRAG = ABS 69 - val SM_SHOWSOUNDS = ABS 70 - val SM_CXMENUCHECK = ABS 71 - val SM_CYMENUCHECK = ABS 72 - val SM_SLOWMACHINE = ABS 73 - val SM_MIDEASTENABLED = ABS 74 - val SM_MOUSEWHEELPRESENT = ABS 75 - - val SM_CXFIXEDFRAME = SM_CXDLGFRAME - val SM_CYFIXEDFRAME = SM_CYDLGFRAME - val SM_CXSIZEFRAME = SM_CXFRAME - val SM_CYSIZEFRAME = SM_CYFRAME - - local - val getSystemMetrics = winCall1 (user "GetSystemMetrics") (cInt) cInt - in - fun GetSystemMetrics(ABS i) = getSystemMetrics i - end - end -end -end; diff --git a/mlsource/extra/Win/Window.sml b/mlsource/extra/Win/Window.sml deleted file mode 100644 index ef4b0dbf..00000000 --- a/mlsource/extra/Win/Window.sml +++ /dev/null @@ -1,568 +0,0 @@ -(* - Copyright (c) 2001-7, 2015 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License version 2.1 as published by the Free Software Foundation. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -structure Window : -sig - type HWND and HINSTANCE and HMENU - type POINT = { x: int, y: int } - type RECT = { left: int, top: int, right: int, bottom: int } - - structure Style: - sig - include BIT_FLAGS - val WS_OVERLAPPED: flags and WS_POPUP: flags and WS_CHILD: flags and WS_MINIMIZE: flags - and WS_VISIBLE: flags and WS_DISABLED:flags and WS_CLIPSIBLINGS:flags - and WS_CLIPCHILDREN:flags and WS_MAXIMIZE:flags and WS_CAPTION:flags - and WS_BORDER:flags and WS_DLGFRAME:flags and WS_VSCROLL:flags and WS_HSCROLL:flags - and WS_SYSMENU:flags and WS_THICKFRAME:flags and WS_GROUP:flags and WS_TABSTOP:flags - and WS_MINIMIZEBOX:flags and WS_MAXIMIZEBOX:flags and WS_TILED:flags and WS_ICONIC:flags - and WS_SIZEBOX:flags and WS_OVERLAPPEDWINDOW:flags and WS_TILEDWINDOW:flags - and WS_POPUPWINDOW:flags and WS_CHILDWINDOW:flags - end - - structure ExStyle: - sig - include BIT_FLAGS - val WS_EX_DLGMODALFRAME: flags and WS_EX_NOPARENTNOTIFY: flags and WS_EX_TOPMOST: flags - and WS_EX_ACCEPTFILES : flags and WS_EX_TRANSPARENT: flags and WS_EX_MDICHILD: flags - and WS_EX_TOOLWINDOW: flags and WS_EX_WINDOWEDGE: flags and WS_EX_CLIENTEDGE: flags - and WS_EX_CONTEXTHELP: flags and WS_EX_RIGHT: flags and WS_EX_LEFT: flags - and WS_EX_RTLREADING: flags and WS_EX_LTRREADING: flags and WS_EX_LEFTSCROLLBAR: flags - and WS_EX_RIGHTSCROLLBAR: flags and WS_EX_CONTROLPARENT: flags and WS_EX_STATICEDGE: flags - and WS_EX_APPWINDOW: flags and WS_EX_OVERLAPPEDWINDOW: flags and WS_EX_PALETTEWINDOW: flags - end - - datatype WindowPositionStyle = - SWP_ASYNCWINDOWPOS - | SWP_DEFERERASE - | SWP_FRAMECHANGED - | SWP_HIDEWINDOW - | SWP_NOACTIVATE - | SWP_NOCOPYBITS - | SWP_NOMOVE - | SWP_NOOWNERZORDER - | SWP_NOREDRAW - | SWP_NOSENDCHANGING - | SWP_NOSIZE - | SWP_NOZORDER - | SWP_SHOWWINDOW - | SWP_OTHER of Word32.word - - datatype ShowWindowOptions = - SW_HIDE - | SW_MAXIMIZE - | SW_MINIMIZE - | SW_RESTORE - | SW_SHOW - | SW_SHOWDEFAULT - | SW_SHOWMAXIMIZED - | SW_SHOWMINIMIZED - | SW_SHOWMINNOACTIVE - | SW_SHOWNA - | SW_SHOWNOACTIVATE - | SW_SHOWNORMAL - - val SW_NORMAL: ShowWindowOptions - val SW_MAX: ShowWindowOptions - - val ShowWindow: HWND * ShowWindowOptions -> bool - - datatype GetWindowFlags = - GW_CHILD - | GW_HWNDFIRST - | GW_HWNDLAST - | GW_HWNDNEXT - | GW_HWNDPREV - | GW_OWNER - - datatype ParentType = - ChildWindow of {id: int, parent: HWND} - | PopupWindow of HMENU - | PopupWithClassMenu - - val GWL_EXSTYLE : int - val GWL_HINSTANCE : int - val GWL_HWNDPARENT : int - val GWL_ID : int - val GWL_STYLE : int - val GWL_USERDATA : int - - val AdjustWindowRect : RECT * Style.flags * bool -> RECT - val AdjustWindowRectEx : RECT * Style.flags * bool * int -> RECT - val ArrangeIconicWindows : HWND -> int - val BringWindowToTop : HWND -> unit - val CW_USEDEFAULT : int - val ChildWindowFromPoint : HWND * POINT -> HWND option - val CloseWindow : HWND -> unit - val CreateWindow : - {x: int, y: int, init: 'a, name: string, class: 'a Class.ATOM, - style: Style.flags, width: int, height: int, - instance: HINSTANCE, relation: ParentType} -> HWND - val CreateWindowEx : - {x: int, y: int, init: 'a, name: string, class: 'a Class.ATOM, - style: Style.flags, width: int, height: int, - instance: HINSTANCE, relation: ParentType, exStyle: ExStyle.flags} -> HWND - val CreateMDIClient: { - relation: ParentType, style: Style.flags, instance: HINSTANCE, windowMenu: HMENU, - idFirstChild: int} -> HWND - val DefWindowProc: HWND * Message.Message -> Message.LRESULT - val DefFrameProc: HWND * HWND * Message.Message -> Message.LRESULT - val DefMDIChildProc: HWND * Message.Message -> Message.LRESULT - val DestroyWindow: HWND -> unit - val FindWindow: string option * string option -> HWND - val FindWindowEx: HWND option * HWND option * string option * string option -> HWND - val GetClassName : HWND -> string - val GetClientRect : HWND -> RECT - val GetDesktopWindow : unit -> HWND - val GetForegroundWindow : unit -> HWND - val GetLastActivePopup : HWND -> HWND - val GetNextWindow : HWND * GetWindowFlags -> HWND - val GetParent : HWND -> HWND option - val GetTopWindow : HWND option -> HWND option - val GetWindow : HWND * GetWindowFlags -> HWND option - val GetWindowContextHelpId : HWND -> int - val GetWindowLongPtr : HWND * int -> int - val GetWindowRect : HWND -> RECT - val GetWindowText : HWND -> string - val GetWindowTextLength : HWND -> int - val IsChild : HWND * HWND -> bool - val IsIconic : HWND -> bool - val IsWindow : HWND -> bool - val IsWindowVisible : HWND -> bool - val IsZoomed : HWND -> bool - val MoveWindow : {x: int, y: int, hWnd: HWND, width: int, height: int, repaint: bool} -> unit - val OpenIcon : HWND -> unit - val SetForegroundWindow : HWND -> bool - val SetParent : HWND * HWND option -> HWND - val SetWindowContextHelpId : HWND * int -> unit - val SetWindowLongPtr : HWND * int * int -> int - val SetWindowPos : HWND * HWND * int * int * int * int * WindowPositionStyle list -> unit - val SetWindowText : HWND * string -> unit - val SubclassWindow : - HWND * - (HWND * Message.Message * 'a -> Message.LRESULT * 'a) * 'a -> - (HWND * Message.Message) -> Message.LRESULT - val WindowFromPoint : POINT -> HWND option - -end = -struct -local - open Foreign - open Globals - open Base - open Resource - open Class - - fun checkWindow c = (checkResult(not(isHNull c)); c) -in - type HWND = HWND and HINSTANCE = HINSTANCE and RECT = RECT and POINT = POINT - and HMENU = HMENU - - open WinBase (* Get Style and SetWindowPositionStyle *) - - datatype ShowWindowOptions = - SW_HIDE - | SW_MAXIMIZE - | SW_MINIMIZE - | SW_RESTORE - | SW_SHOW - | SW_SHOWDEFAULT - | SW_SHOWMAXIMIZED - | SW_SHOWMINIMIZED - | SW_SHOWMINNOACTIVE - | SW_SHOWNA - | SW_SHOWNOACTIVATE - | SW_SHOWNORMAL - - val SW_NORMAL = SW_SHOWNORMAL - val SW_MAX = SW_SHOWDEFAULT - - local - val showWindow = winCall2 (user "ShowWindow")(cHWND,cInt) (cBool) - in - fun ShowWindow (win, opt) = - let - val cmd = - case opt of - SW_HIDE => 0 - | SW_SHOWNORMAL => 1 - | SW_SHOWMINIMIZED => 2 - | SW_SHOWMAXIMIZED => 3 - | SW_MAXIMIZE => 3 - | SW_SHOWNOACTIVATE => 4 - | SW_SHOW => 5 - | SW_MINIMIZE => 6 - | SW_SHOWMINNOACTIVE => 7 - | SW_SHOWNA => 8 - | SW_RESTORE => 9 - | SW_SHOWDEFAULT => 10 - - in - showWindow (win, cmd) - end - end - - val CloseWindow = - winCall1 (user "CloseWindow") (cHWND) (successState "CloseWindow") - val FindWindow = - checkWindow o - winCall2 (user "FindWindowA") (STRINGOPT, STRINGOPT) cHWND - val FindWindowEx = - checkWindow o - winCall4 (user "FindWindowExA") (cHWNDOPT, cHWNDOPT, STRINGOPT, STRINGOPT) cHWND - val GetDesktopWindow = winCall0 (user "GetDesktopWindow") () cHWND - val GetForegroundWindow = winCall0 (user "GetForegroundWindow") () cHWND - val GetLastActivePopup = winCall1 (user "GetLastActivePopup") cHWND cHWND - val GetParent = winCall1 (user "GetParent") cHWND cHWNDOPT - val GetTopWindow = winCall1 (user "GetTopWindow") cHWNDOPT cHWNDOPT - - val GetWindowTextLength = winCall1 (user "GetWindowTextLengthA") cHWND cInt - val SetWindowText = - winCall2 (user "SetWindowTextA") (cHWND, cString) (successState "SetWindowText") - - local - val getTextCall = winCall3 (user "GetWindowTextA") (cHWND, cPointer, cInt) cInt - in - fun GetWindowText(hwnd: HWND): string = - let - val baseLen = GetWindowTextLength hwnd - (* The length returned by GetWindowTextLength may be larger than the text - but we have to add one for the terminating null. *) - open Memory - val buff = malloc (Word.fromInt(baseLen+1)) - val size = getTextCall(hwnd, buff, baseLen+1) - in - (if size = 0 then "" - else fromCstring buff) before free buff - end - end - - (* Get the class name of a window. *) - local - val getClassName = winCall3 (user "GetClassNameA") (cHWND, cPointer, cInt) cInt - in - (* Unfortunately we can't pass NULL here to get the length. *) - fun GetClassName hwnd = - getStringCall(fn (v, i) => getClassName(hwnd, v, i)) - end - - datatype GetWindowFlags = - GW_CHILD - | GW_HWNDFIRST - | GW_HWNDLAST - | GW_HWNDNEXT - | GW_HWNDPREV - | GW_OWNER - - local - fun winFlag GW_HWNDFIRST = 0 - | winFlag GW_HWNDLAST = 1 - | winFlag GW_HWNDNEXT = 2 - | winFlag GW_HWNDPREV = 3 - | winFlag GW_OWNER = 4 - | winFlag GW_CHILD = 5 - - val getWindow = winCall2 (user "GetWindow") (cHWND, cUint) cHWNDOPT - val getNextWindow = winCall2 (user "GetNextWindow") (cHWND,cUint) cHWND - in - fun GetWindow (win, gwFlag) = getWindow (win, winFlag gwFlag) - (* Only GW_HWNDNEXT and GW_HWNDPREV are allowed here but it's probably not - worth making it a special case. *) - fun GetNextWindow(win: HWND, gwFlag) = - checkWindow (getNextWindow (win, winFlag gwFlag)) - end - - val IsChild = winCall2 (user "IsChild") (cHWND,cHWND) cBool - val IsIconic = winCall1 (user "IsIconic") (cHWND) cBool - val IsWindow = winCall1 (user "IsWindow") (cHWND) cBool - val IsWindowVisible = winCall1 (user "IsWindowVisible") (cHWND) cBool - val IsZoomed = winCall1 (user "IsZoomed") (cHWND) cBool - - local - val getClientRect = winCall2 (user "GetClientRect") (cHWND, cStar cRect) cBool - and getWindowRect = winCall2 (user "GetWindowRect") (cHWND, cStar cRect) cBool - and adjustWindowRect = winCall3 (user "AdjustWindowRect") (cStar cRect, cDWORD, cBool) cBool - and adjustWindowRectEx = winCall4 (user "AdjustWindowRectEx") (cStar cRect, cDWORD, cBool, cDWORD) cBool - in - fun GetClientRect(hWnd: HWND): RECT = - let - val v = ref{bottom=0, top=0, left=0, right=0} - val res = getClientRect (hWnd, v) - in - checkResult res; - !v - end - - fun GetWindowRect(hWnd: HWND): RECT = - let - val v = ref{bottom=0, top=0, left=0, right=0} - val res = getWindowRect (hWnd, v) - in - checkResult res; - !v - end - - fun AdjustWindowRect(rect: RECT, style: Style.flags, bMenu: bool): RECT = - let - val v = ref rect - val res = adjustWindowRect(v, LargeWord.toInt(Style.toWord style), bMenu) - in - checkResult res; - !v - end - - fun AdjustWindowRectEx(rect: RECT, style: Style.flags, bMenu: bool, exStyle: int): RECT = - let - val v = ref rect - val res = adjustWindowRectEx(v, LargeWord.toInt(Style.toWord style), bMenu, exStyle) - in - checkResult res; - !v - end - end - - val ArrangeIconicWindows = winCall1 (user "ArrangeIconicWindows") (cHWND) cUint - val BringWindowToTop = - winCall1 (user "BringWindowToTop") (cHWND) (successState "BringWindowToTop") - val OpenIcon = winCall1 (user "OpenIcon") (cHWND) (successState "OpenIcon") - val SetForegroundWindow = winCall1 (user "SetForegroundWindow") (cHWND) cBool - - local - val setParent = winCall2 (user "SetParent") (cHWND, cHWND) cHWND - in - fun SetParent(child: HWND, new: HWND option): HWND = - let - val old = setParent(child, getOpt(new, hwndNull)) - in - checkResult(not(isHNull old)); - old - end - end - - local - val createWindowEx = - winCall12 (user "CreateWindowExA") (cDWORD, cString, cString, cDWORD, cInt, cInt, cInt, cInt, - cHWND, cPointer, cHINSTANCE, cPointer) cHWND - in - fun CreateWindowEx{class: 'a Class.ATOM, (* Window class *) - name: string, (* Window name *) - style: Style.flags, (* window style *) - exStyle: ExStyle.flags, (* extended style *) - x: int, (* horizontal position of window *) - y: int, (* vertical position of window *) - width: int, (* window width *) - height: int, (* window height *) - relation: ParentType, (* parent or owner window *) - instance: HINSTANCE, (* application instance *) - init: 'a}: HWND = - let - (* Set up a winCallback for ML classes and return the class name. *) - val className: string = - case class of - Registered { proc, className} => - (Message.setCallback(proc, init); className) - | SystemClass s => s - - val (parent, menu, styleWord) = WinBase.unpackWindowRelation(relation, style) - - (* Create a window. *) - val res = createWindowEx - (LargeWord.toInt(ExStyle.toWord exStyle), className, name, LargeWord.toInt styleWord, - x, y, width, height, parent, menu, instance, Memory.null) - in - checkResult(not(isHNull res)); - res - end - end - - fun CreateWindow{class: 'a Class.ATOM, name: string, style: Style.flags, x: int, - y: int, width: int, height: int, relation: ParentType, instance: HINSTANCE, - init: 'a}: HWND = - CreateWindowEx{exStyle=ExStyle.flags[], class=class, name=name, style=style, x=x, - y=y, width=width, height=height,relation=relation, instance=instance, - init=init} - - local - val cCLIENTCREATESTRUCT = cStruct2(cHMENU, cUint) - val createMDIClient = - winCall12 (user "CreateWindowExA") (cDWORD, cString, cPointer, cDWORD, cInt, cInt, cInt, cInt, - cHWND, cPointer, cHINSTANCE, cConstStar cCLIENTCREATESTRUCT) cHWND - in - fun CreateMDIClient{ - relation: ParentType, (* This should always be ChildWindow *) - style: Style.flags, - instance: HINSTANCE, (* application instance *) - windowMenu: HMENU, (* Window menu to which children are added. *) - idFirstChild: int (* Id of first child when it's created. *) - }: HWND = - let - val (parent, menu, styleWord) = - unpackWindowRelation(relation, style) - val createS = (windowMenu, idFirstChild) - val res = createMDIClient - (0, "MDICLIENT", Memory.null, LargeWord.toInt styleWord, 0, 0, 0, 0, parent, menu, - instance, createS) - in - checkResult(not(isHNull res)); - res - end - end - - local - val defWindowProc = - winCall4 (user "DefWindowProcA") (cHWND, cUint, cUINT_PTRw, cUINT_PTRw) cUINT_PTRw - and defFrameProc = - winCall5 (user "DefFrameProcA") (cHWND, cHWND, cUint, cUINT_PTRw, cUINT_PTRw) cUINT_PTRw - and defMDIChildProc = - winCall4 (user "DefMDIChildProcA") (cHWND, cUint, cUINT_PTRw, cUINT_PTRw) cUINT_PTRw - in - fun DefWindowProc (hWnd: HWND, msg: Message.Message): Message.LRESULT = - let - val (wMsg, wParam, lParam, freeMsg) = Message.compileMessage msg - val res = defWindowProc(hWnd, wMsg, wParam, lParam) - in - Message.messageReturnFromParams(msg, wParam, lParam, res) - before freeMsg() - end - - fun DefFrameProc (hWnd: HWND, hWndMDIClient: HWND, msg: Message.Message): Message.LRESULT = - let - val (wMsg, wParam, lParam, freeMsg) = Message.compileMessage msg - val res = defFrameProc(hWnd, hWndMDIClient, wMsg, wParam, lParam) - in - (* Write back any changes the function has made. *) - Message.messageReturnFromParams(msg, wParam, lParam, res) - before freeMsg() - end - - fun DefMDIChildProc (hWnd: HWND, msg: Message.Message): Message.LRESULT = - let - val (wMsg, wParam, lParam, freeMsg) = Message.compileMessage msg - val res = defMDIChildProc(hWnd, wMsg, wParam, lParam) - in - Message.messageReturnFromParams(msg, wParam, lParam, res) - before freeMsg() - end - end - - val CW_USEDEFAULT = ~0x80000000 (* Default value for size and/ot position. *) - - local - val destroyWindow = winCall1 (user "DestroyWindow") (cHWND) (successState "DestroyWindow") - in - fun DestroyWindow(hWnd: HWND) = - ( - destroyWindow hWnd; - Message.removeCallback hWnd - ) - end - - (*val GWL_WNDPROC = ~4*) - val GWL_HINSTANCE = ~6 - val GWL_HWNDPARENT = ~8 - val GWL_STYLE = ~16 - val GWL_EXSTYLE = ~20 - val GWL_USERDATA = ~21 - val GWL_ID = ~12 - - val GetWindowLongPtr = winCall2 (user "GetWindowLongPtrA") (cHWND, cInt) cLONG_PTR - - (* SetWindowLong is a dangerous function to export. *) - val SetWindowLongPtr = winCall3 (user "SetWindowLongPtrA") (cHWND, cInt, cLONG_PTR) cLONG_PTR - - (* ML extension. This replaces the GetWindowLong and SetWindowLong calls. *) - val SubclassWindow = Message.subclass - - local - val moveWindow = - winCall6(user "MoveWindow") (cHWND,cInt,cInt,cInt,cInt,cBool) (successState "MoveWindow") - in - fun MoveWindow{hWnd: HWND, x: int, y: int, height: int, width: int, repaint: bool} = - moveWindow(hWnd, x, y, width, height, repaint) - end - - val SetWindowPos = winCall7 (user "SetWindowPos") - (cHWND, cHWND, cInt, cInt, cInt, cInt, cWINDOWPOSITIONSTYLE) - (successState "SetWindowPos") - - val SetWindowContextHelpId = - winCall2 (user "SetWindowContextHelpId") (cHWND, cDWORD) - (successState "SetWindowContextHelpId") - - val GetWindowContextHelpId = winCall1 (user "GetWindowContextHelpId") (cHWND) cDWORD - - val ChildWindowFromPoint = - winCall2 (user "ChildWindowFromPoint") (cHWND, cPoint) cHWNDOPT - and WindowFromPoint = - winCall1 (user "WindowFromPoint") (cPoint) cHWNDOPT -(* -TODO: -AnimateWindow - Only Win98/NT 5.0 -BeginDeferWindowPos -CascadeWindows -ChildWindowFromPointEx -DeferWindowPos -EndDeferWindowPos -EnumChildProc -EnumChildWindows -EnumThreadWindows -EnumThreadWndProc -EnumWindows -EnumWindowsProc -GetWindowPlacement -GetWindowThreadProcessId -IsWindowUnicode -SetWindowPlacement -ShowOwnedPopups -ShowWindowAsync -TileWindows -*) - -end -end; - -(* Because we're using opaque matching we have to install pretty printers - outside the structure. *) -local - open Window.Style - - val flagTable = - [(WS_POPUP, "WS_POPUP"), - (WS_CHILD, "WS_CHILD"), - (WS_MINIMIZE, "WS_MINIMIZE"), - (WS_VISIBLE, "WS_VISIBLE"), - (WS_DISABLED, "WS_DISABLED"), - (WS_CLIPSIBLINGS, "WS_CLIPSIBLINGS"), - (WS_CLIPCHILDREN, "WS_CLIPCHILDREN"), - (WS_MAXIMIZE, "WS_MAXIMIZE"), - (WS_CAPTION, "WS_CAPTION"), - (WS_BORDER, "WS_BORDER"), - (WS_DLGFRAME, "WS_DLGFRAME"), - (WS_VSCROLL, "WS_VSCROLL"), - (WS_HSCROLL, "WS_HSCROLL"), - (WS_SYSMENU, "WS_SYSMENU"), - (WS_THICKFRAME, "WS_THICKFRAME"), - (WS_GROUP, "WS_GROUP"), - (WS_TABSTOP, "WS_TABSTOP"), - (WS_MINIMIZEBOX, "WS_MINIMIZEBOX"), - (WS_MAXIMIZEBOX, "WS_MAXIMIZEBOX")] - - structure FlagP = FlagPrint(structure BITS = Window.Style) -in - val _ = PolyML.addPrettyPrinter (FlagP.createFlagPrinter flagTable) -end; diff --git a/mlsource/extra/Win/Windows.pyp b/mlsource/extra/Win/Windows.pyp deleted file mode 100644 index e0570fbc..00000000 --- a/mlsource/extra/Win/Windows.pyp +++ /dev/null @@ -1,56 +0,0 @@ -[Files] -NFiles=53 -File0=ROOT.sml -Root=ROOT.sml -File1=Base.sml -File2=Bitmap.sml -File3=Brush.sml -File4=Button.sml -File5=Caret.sml -File6=Class.sml -File7=Clipboard.sml -File8=Clipping.sml -File9=Color.sml -File10=ComboBase.sml -File11=Combobox.sml -File12=CommonControls.sml -File13=CommonDialog.sml -File14=Cursor.sml -File15=DeviceBase.sml -File16=DeviceContext.sml -File17=Dialog.sml -File18=DragDrop.sml -File19=Edit.sml -File20=FlagPrint.sml -File21=Font.sml -File22=FontBase.sml -File23=GdiBase.sml -File24=Globals.sml -File25=Icon.sml -File26=Keyboard.sml -File27=Line.sml -File28=Listbox.sml -File29=Locale.sml -File30=LocaleBase.sml -File31=Menu.sml -File32=MenuBase.sml -File33=Message.sml -File34=MessageBox.sml -File35=Metafile.sml -File36=Mouse.sml -File37=Painting.sml -File38=Path.sml -File39=Pen.sml -File40=Printing.sml -File41=Rectangle.sml -File42=Region.sml -File43=Resource.sml -File44=Scrollbar.sml -File45=ScrollBase.sml -File46=Shape.sml -File47=Static.sml -File48=Transform.sml -File49=WinBase.sml -File50=Window.sml -File51=WinSystem.sml -File52=MESSAGE.signature.sml diff --git a/mlsource/extra/Win/clean.sml b/mlsource/extra/Win/clean.sml deleted file mode 100644 index d5de77d6..00000000 --- a/mlsource/extra/Win/clean.sml +++ /dev/null @@ -1,27 +0,0 @@ -(* - Copyright (c) 2000 - Cambridge University Technical Services Limited - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* Clean up the name space by removing unnecessary declarations. *) - -val _ = List.app PolyML.Compiler.forgetStructure - [ "Base", "ComboBase", "FontBase", "MenuBase", "ScrollBase", "WinBase", - "MessageBase", "GdiBase", "DeviceBase", "LocaleBase" ]; - -val _ = List.app PolyML.Compiler.forgetFunctor ["FlagPrint"]; - diff --git a/mlsource/extra/Win/ml_bind.sml b/mlsource/extra/Win/ml_bind.sml deleted file mode 100644 index b2e0774e..00000000 --- a/mlsource/extra/Win/ml_bind.sml +++ /dev/null @@ -1,52 +0,0 @@ -(* - Copyright (c) 2001-7 - David C.J. Matthews - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(* Build everything. *) -local - structure d = Dialog - structure g = Globals - structure c = Cursor - structure i = Icon - structure m = Menu - structure cl = Class - structure e = Edit - structure w = Window - structure o = CommonDialog - structure b = MessageBox - structure t = Caret - structure cb = Clipboard - structure mf = Metafile - structure r = Rectangle - structure t = Transform - structure p = Printing - structure p = Path (* Includes Line *) - structure d = DeviceContext (* Includes Pen, Font, Brush, Color *) - structure p = Painting - structure s = Shape - structure l = Line - structure b = Bitmap - structure c = Clipping - structure dd = DragDrop - structure k = Keyboard - structure m = Mouse - structure ws = WinSystem - structure lo = Locale - structure cc = CommonControls -in -end;