(* 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; *)