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