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