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*)
18
19structure Cursor:
20  sig
21    type HCURSOR and HINSTANCE
22    type POINT = { x : int, y: int }
23    type RECT =  { left: int, top: int, right: int, bottom: int }
24    val hcursorNull : HCURSOR
25    val isHcursorNull : HCURSOR -> bool
26
27    datatype
28      CursorId =
29          OCR_APPSTARTING
30        | OCR_CROSS
31        | OCR_IBEAM
32        | OCR_NO
33        | OCR_NORMAL
34        | OCR_SIZEALL
35        | OCR_SIZENESW
36        | OCR_SIZENS
37        | OCR_SIZENWSE
38        | OCR_SIZEWE
39        | OCR_UP
40        | OCR_WAIT
41
42    val ClipCursor : RECT -> unit
43    val CopyCursor : HCURSOR -> HCURSOR
44    val DestroyCursor : HCURSOR -> unit
45    val GetClipCursor : unit -> RECT
46    val GetCursor : unit -> HCURSOR
47    val GetCursorPos : unit -> POINT
48    val LoadCursor : HINSTANCE * Resource.RESID -> HCURSOR
49    val LoadCursorFromFile : string -> HCURSOR
50    val LoadSystemCursor : CursorId -> HCURSOR
51    val LoadSystemCursorFromFile : CursorId -> HCURSOR
52    val SetCursor : HCURSOR -> HCURSOR
53    val SetCursorPos : int * int -> unit
54    val SetSystemCursor : HCURSOR * CursorId -> unit
55    val ShowCursor : bool -> int
56  end
57 =
58struct
59    local
60        open Foreign
61        open Base
62        open Resource
63    in
64        type HCURSOR = HCURSOR and HINSTANCE = HINSTANCE
65        type RECT = RECT and POINT = POINT
66        val hcursorNull = hgdiObjNull
67        and isHcursorNull = isHgdiObjNull
68
69        datatype CursorId =
70            OCR_APPSTARTING     (* Standard arrow and small hourglass *)
71        |   OCR_NORMAL          (* Standard arrow *)
72        |   OCR_CROSS           (* Crosshair *)
73        |   OCR_IBEAM           (* I-beam  *)
74        |   OCR_NO              (* Slashed circle *)
75        |   OCR_SIZEALL         (* Four-pointed arrow pointing north, south, east, and west *)
76        |   OCR_SIZENESW        (* Double-pointed arrow pointing northeast and southwest *)
77        |   OCR_SIZENS          (* Double-pointed arrow pointing north and south *)
78        |   OCR_SIZENWSE        (* Double-pointed arrow pointing northwest and southeast *)
79        |   OCR_SIZEWE          (* Double-pointed arrow pointing west and east *)
80        |   OCR_UP              (* Vertical arrow *)
81        |   OCR_WAIT            (* Hourglass *)
82
83        local
84            fun idToInt OCR_APPSTARTING = 32650
85            |   idToInt OCR_NORMAL = 32512
86            |   idToInt OCR_CROSS = 32515
87            |   idToInt OCR_IBEAM = 32513
88            |   idToInt OCR_NO = 32648
89            |   idToInt OCR_SIZEALL = 32646
90            |   idToInt OCR_SIZENESW = 32643
91            |   idToInt OCR_SIZENS = 32645
92            |   idToInt OCR_SIZENWSE = 32642
93            |   idToInt OCR_SIZEWE = 32644
94            |   idToInt OCR_UP = 32516
95            |   idToInt OCR_WAIT = 32514
96
97            fun intToId _ = raise Fail "intToId"
98        in
99            val CURSORID = absConversion {abs=intToId, rep=idToInt} cDWORD
100        end
101
102        val SetSystemCursor =
103            winCall2 (user "SetSystemCursor") (cHCURSOR, CURSORID) (successState "SetSystemCursor")
104
105        fun checkCursor c = (checkResult(not(isHcursorNull c)); c)
106
107        val LoadCursorFromFile =
108            checkCursor o
109            winCall1 (user "LoadCursorFromFileA") (cString) cHCURSOR
110
111        (* ML extension - simpler than having a separate function. *)
112        (* I found a note suggesting that it was better to use the Unicode version
113           because not all implementations handle this properly. *)
114        val LoadSystemCursorFromFile =
115            checkCursor o
116            winCall1 (user "LoadCursorFromFileW") (CURSORID) cHCURSOR
117
118        val ClipCursor =
119            winCall1 (user "ClipCursor") (cConstStar cRect) (successState "ClipCursor")
120
121        val CopyCursor =
122            checkCursor o
123            winCall1 (user "CopyCursor") (cHCURSOR) cHCURSOR
124
125        val DestroyCursor =
126            winCall1 (user "DestroyCursor") (cHCURSOR) (successState "DestroyCursor")
127
128        local
129            val getClipCursor =
130                winCall1 (user "GetClipCursor") (cStar cRect) (successState "GetClipCursor")
131        in
132            fun GetClipCursor (): RECT =
133            let
134                val r = ref { top = 0, bottom = 0, left = 0, right = 0 }
135            in
136                getClipCursor r;
137                !r
138            end
139        end
140
141        val GetCursor = winCall0 (user "GetCursor") () cHCURSOR
142
143        local
144            val getCursorPos =
145                winCall1 (user "GetCursorPos") (cStar cPoint) (successState "GetCursorPos")
146        in
147            fun GetCursorPos (): POINT =
148            let
149                val r = ref { x = 0, y = 0 }
150            in
151                getCursorPos r;
152                !r
153            end
154        end
155
156        val SetCursor = winCall1 (user "SetCursor") cHCURSOR cHCURSOR
157
158        val SetCursorPos =
159            winCall2 (user "SetCursorPos") (cInt, cInt) (successState "SetCursorPos")
160
161        val ShowCursor = winCall1 (user "ShowCursor") cBool cInt
162
163        (* Superseded by LoadImage *)
164        val LoadCursor =
165            checkCursor o
166                winCall2 (user "LoadCursorA") (cHINSTANCE, cRESID) cHCURSOR
167
168        local
169            val loadCursor =
170                checkCursor o winCall2 (user "LoadCursorA") (cHINSTANCE, CURSORID) cHCURSOR
171        in
172            fun LoadSystemCursor(id: CursorId) = loadCursor(hinstanceNull, id)
173        end
174(*
175TODO:
176CreateCursor
177    a little complicated because it includes bit maps.
178*)
179    end
180end;
181