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
19(* Scrollbars. *)
20structure Scrollbar:
21sig
22    type HWND and HDC and HRGN
23    type RECT =  { left: int, top: int, right: int, bottom: int }
24
25    structure Style:
26    sig
27        include BIT_FLAGS where type flags = Window.Style.flags
28        val WS_OVERLAPPED: flags and WS_POPUP: flags and WS_CHILD: flags and WS_MINIMIZE: flags
29        and WS_VISIBLE: flags and WS_DISABLED:flags and WS_CLIPSIBLINGS:flags
30        and WS_CLIPCHILDREN:flags and WS_MAXIMIZE:flags and WS_CAPTION:flags
31        and WS_BORDER:flags and WS_DLGFRAME:flags and WS_VSCROLL:flags and WS_HSCROLL:flags
32        and WS_SYSMENU:flags and WS_THICKFRAME:flags and WS_GROUP:flags and WS_TABSTOP:flags
33        and WS_MINIMIZEBOX:flags and WS_MAXIMIZEBOX:flags and WS_TILED:flags and WS_ICONIC:flags
34        and WS_SIZEBOX:flags and WS_OVERLAPPEDWINDOW:flags and WS_TILEDWINDOW:flags
35        and WS_POPUPWINDOW:flags and WS_CHILDWINDOW:flags
36        and SBS_HORZ:flags and SBS_VERT:flags and SBS_TOPALIGN:flags and SBS_LEFTALIGN:flags
37        and SBS_BOTTOMALIGN:flags and SBS_RIGHTALIGN:flags and SBS_SIZEBOXTOPLEFTALIGN:flags
38        and SBS_SIZEBOXBOTTOMRIGHTALIGN:flags and SBS_SIZEBOX:flags and SBS_SIZEGRIP:flags
39    end
40
41    type enableArrows = { enableLeftUp: bool, enableRightDown: bool }
42
43    val ESB_ENABLE_BOTH: enableArrows
44    val ESB_DISABLE_BOTH: enableArrows
45    val ESB_DISABLE_LEFT: enableArrows
46    val ESB_DISABLE_RIGHT: enableArrows
47    val ESB_DISABLE_UP: enableArrows
48    val ESB_DISABLE_DOWN: enableArrows
49
50    type SCROLLINFO =
51        { minPos: int, maxPos: int, pageSize: int, pos: int, trackPos: int }
52
53    datatype ScrollInfoOption =
54        SIF_RANGE | SIF_PAGE | SIF_POS | SIF_DISABLENOSCROLL | SIF_TRACKPOS
55
56    val SIF_ALL : ScrollInfoOption list
57
58    datatype ScrollBarType = SB_BOTH | SB_CTL | SB_HORZ | SB_VERT
59    datatype ScrollWindowFlag = SW_ERASE | SW_INVALIDATE | SW_SCROLLCHILDREN
60
61    val EnableScrollBar : HWND * ScrollBarType * enableArrows -> unit
62    val GetScrollInfo : HWND * ScrollBarType * ScrollInfoOption list -> SCROLLINFO
63    val GetScrollPos : HWND * ScrollBarType -> int
64    val ScrollDC : HDC * int * int * RECT * RECT * HRGN -> RECT
65    val ScrollWindow : HWND * int * int * RECT * RECT -> unit
66    val ScrollWindowEx : HWND * int * int * RECT * RECT * HRGN * ScrollWindowFlag list -> RECT
67    val SetScrollInfo :
68        HWND * ScrollBarType * ScrollInfoOption list * SCROLLINFO * bool -> int
69    val SetScrollPos : HWND * ScrollBarType * int * bool -> int
70    val SetScrollRange : HWND * ScrollBarType * int * int * bool -> bool
71    val ShowScrollBar : HWND * ScrollBarType * bool -> unit
72end
73=
74struct
75    local
76        open Foreign Base
77    in
78        open ScrollBase
79        type HDC = HDC and HWND = HWND and HRGN = HRGN and RECT = RECT
80    
81        structure Style =
82        struct
83            open Window.Style (* Include all the windows styles. *)
84    
85            val SBS_HORZ                    = fromWord 0wx0000
86            val SBS_VERT                    = fromWord 0wx0001
87            val SBS_TOPALIGN                = fromWord 0wx0002
88            val SBS_LEFTALIGN               = fromWord 0wx0002
89            val SBS_BOTTOMALIGN             = fromWord 0wx0004
90            val SBS_RIGHTALIGN              = fromWord 0wx0004
91            val SBS_SIZEBOXTOPLEFTALIGN     = fromWord 0wx0002
92            val SBS_SIZEBOXBOTTOMRIGHTALIGN = fromWord 0wx0004
93            val SBS_SIZEBOX                 = fromWord 0wx0008
94            val SBS_SIZEGRIP                = fromWord 0wx0010
95    
96            val all = flags[Window.Style.all, SBS_HORZ, SBS_VERT, SBS_TOPALIGN, SBS_BOTTOMALIGN,
97                            SBS_SIZEBOX, SBS_SIZEGRIP]
98    
99            val intersect =
100                List.foldl (fn (a, b) => fromWord(SysWord.andb(toWord a, toWord b))) all
101        end
102    
103        datatype ScrollBarType = SB_CTL | SB_HORZ | SB_VERT | SB_BOTH
104        
105        local
106            val tab = [
107                (SB_HORZ,             0),
108                (SB_VERT,             1),
109                (SB_CTL,              2),
110                (SB_BOTH,             3)
111            ]
112        in
113            val cSCROLLBARTYPE = tableConversion(tab, NONE) cUint
114                (* It's a UINT for EnableScrollBar and int for GetScrollInfo *)
115        end
116    
117        datatype ScrollWindowFlag =
118            SW_SCROLLCHILDREN | SW_INVALIDATE | SW_ERASE
119        
120        local
121            val tab = [
122                (SW_SCROLLCHILDREN,   0wx0001),
123                (SW_INVALIDATE,       0wx0002),
124                (SW_ERASE,            0wx0004) ]
125        in
126            val cSCROLLWINDOWFLAG = tableSetConversion(tab, NONE)
127        end
128    
129    
130        local
131            open Foreign
132            open Base
133        in
134            val EnableScrollBar = winCall3(user "EnableScrollBar") (cHWND, cSCROLLBARTYPE, cENABLESCROLLBARFLAG)
135                    (successState "EnableScrollBar")
136            val GetScrollPos = winCall2 (user "GetScrollPos") (cHWND,cSCROLLBARTYPE) cInt
137            val SetScrollRange = winCall5(user "SetScrollRange") (cHWND,cSCROLLBARTYPE,cInt,cInt,cBool) cBool 
138            val SetScrollPos = winCall4(user "SetScrollPos") (cHWND,cSCROLLBARTYPE,cInt,cBool) cInt
139            val ShowScrollBar = winCall3(user "ShowScrollBar") (cHWND,cSCROLLBARTYPE,cBool) (successState "ShowScrollBar")
140    
141            val ScrollWindow = winCall5(user "ScrollWindow") (cHWND,cInt,cInt,cConstStar cRect,cConstStar cRect)
142                    (successState "ScrollWindow")
143    
144            local
145                val scrollDC =
146                    winCall7 (user "ScrollDC") (cHDC,cInt,cInt,cConstStar cRect,cConstStar cRect,cHRGN,cStar cRect)
147                        (successState "ScrollDC")
148    
149                val scrollWindowEx = winCall8(user "ScrollWindowEx")
150                                             (cHWND,cInt,cInt,cConstStar cRect,cConstStar cRect,cHRGN,cStar cRect,cSCROLLWINDOWFLAG)
151                                             (successState "ScrollWindowEx")
152            in
153                fun ScrollDC(hDC, dx, dy, prcScroll, prcClip, hrgnUpdate): RECT =
154                let
155                    val v = ref{top=0, bottom=0, left=0, right=0}
156                    val () = scrollDC(hDC, dx, dy, prcScroll, prcClip, hrgnUpdate, v)
157                in
158                    ! v
159                end
160                and ScrollWindowEx(hWnd, dx, dy, prcScroll, prcClip, hrgnUpdate, flags) =
161                let
162                    val v = ref{top=0, bottom=0, left=0, right=0}
163                    val () =
164                        scrollWindowEx(hWnd, dx, dy, prcScroll, prcClip, hrgnUpdate, v, flags)
165                in
166                    ! v
167                end
168            end
169
170            local
171                val {ctype = {size=sizeStruct, ...}, ...} = breakConversion cSCROLLINFOSTRUCT
172                
173                val getScrollInfo =
174                    winCall3 (user "GetScrollInfo") (cHWND, cSCROLLBARTYPE, cStar cSCROLLINFOSTRUCT)
175                                (successState "GetScrollInfo")
176                and setScrollInfo =
177                    winCall4 (user "SetScrollInfo") (cHWND, cSCROLLBARTYPE, cConstStar cSCROLLINFOSTRUCT, cBool) cInt
178            in
179                fun GetScrollInfo(hwnd, sbt, options): SCROLLINFO =
180                let
181                    val v = ref(Word.toInt sizeStruct, options, 0, 0, 0, 0, 0)
182                    val _: unit = getScrollInfo(hwnd, sbt, v)
183                    val (_, _, minPos, maxPos, pageSize, pos, trackPos) = ! v
184                in
185                    {minPos = minPos, maxPos = maxPos, pageSize = pageSize,
186                      pos = pos, trackPos = trackPos}
187                end
188                
189                and SetScrollInfo(hwnd, sbt, options,
190                        { minPos, maxPos, pageSize, pos, trackPos}, redraw): int =
191                    setScrollInfo(hwnd, sbt,
192                        (Word.toInt sizeStruct, options, minPos, maxPos, pageSize, pos, trackPos), redraw)
193            end
194        end
195    end
196end;
197
198(*
199let
200    open Scrollbar.Style
201
202    (* The same values are used with different names for horizontal and vertical bars.
203       Maybe we should generate different names according to whether the SBS_VERT flag
204       is set. *)
205    val flagTable =
206        [(SBS_VERT,             "SBS_VERT"),
207         (SBS_TOPALIGN,         "SBS_TOPALIGN"),
208         (SBS_BOTTOMALIGN,      "SBS_BOTTOMALIGN"),
209         (SBS_SIZEBOX,          "SBS_SIZEBOX"),
210         (SBS_SIZEGRIP,         "SBS_SIZEGRIP"),
211         (WS_POPUP,             "WS_POPUP"),
212         (WS_CHILD,             "WS_CHILD"),
213         (WS_MINIMIZE,          "WS_MINIMIZE"),
214         (WS_VISIBLE,           "WS_VISIBLE"),
215         (WS_DISABLED,          "WS_DISABLED"),
216         (WS_CLIPSIBLINGS,      "WS_CLIPSIBLINGS"),
217         (WS_CLIPCHILDREN,      "WS_CLIPCHILDREN"),
218         (WS_MAXIMIZE,          "WS_MAXIMIZE"),
219         (WS_CAPTION,           "WS_CAPTION"),
220         (WS_BORDER,            "WS_BORDER"),
221         (WS_DLGFRAME,          "WS_DLGFRAME"),
222         (WS_VSCROLL,           "WS_VSCROLL"),
223         (WS_HSCROLL,           "WS_HSCROLL"),
224         (WS_SYSMENU,           "WS_SYSMENU"),
225         (WS_THICKFRAME,        "WS_THICKFRAME"),
226         (WS_GROUP,             "WS_GROUP"),
227         (WS_TABSTOP,           "WS_TABSTOP"),
228         (WS_MINIMIZEBOX,       "WS_MINIMIZEBOX"),
229         (WS_MAXIMIZEBOX,       "WS_MAXIMIZEBOX")]
230
231    fun accumulateFlags f [] = []
232     |  accumulateFlags f ((w, s)::t) =
233        if allSet(w, f) then s :: accumulateFlags(clear(w, f)) t
234        else accumulateFlags f t
235
236    fun printFlags(put, beg, brk, nd) depth _ x =
237        (* This is just the code to print a list. *)
238        let
239        
240          val stringFlags = accumulateFlags x flagTable
241          fun plist [] depth = ()
242           |  plist _ 0 = put "..."
243           |  plist [h]    depth = put h 
244           |  plist (h::t) depth =
245                  ( put (h^",");
246                    brk (1, 0);
247                    plist t (depth - 1)
248                  )
249        in
250          beg (3, false);
251          put "[";
252          if depth <= 0 then put "..." else plist stringFlags depth;
253          put "]";
254          nd ()
255        end
256in
257    PolyML.install_pp printFlags
258end;
259*)
260