Commit 3cb3e377 authored by Peter Achten's avatar Peter Achten
Browse files

(PA): moveWindowViewFrame now takes advantage of system look.

parent 42aafe76
...@@ -3,7 +3,7 @@ implementation module controlpos ...@@ -3,7 +3,7 @@ implementation module controlpos
// Clean Object I/O library version 1.2 // Clean Object I/O library version 1.2
import StdBool, StdFunc, StdMisc, StdTuple import StdBool, StdFunc, StdInt, StdList, StdMisc, StdTuple
import commondef, windowaccess import commondef, windowaccess
from controllayout import layoutControls, getWindowContentRect from controllayout import layoutControls, getWindowContentRect
from controlrelayout import relayoutControls from controlrelayout import relayoutControls
...@@ -11,65 +11,108 @@ from windowclipstate import forceValidWindowClipState ...@@ -11,65 +11,108 @@ from windowclipstate import forceValidWindowClipState
from windowdefaccess import isWindowItemSpace, getWindowItemSpaceAtt, from windowdefaccess import isWindowItemSpace, getWindowItemSpaceAtt,
isWindowHMargin, getWindowHMarginAtt, isWindowHMargin, getWindowHMarginAtt,
isWindowVMargin, getWindowVMarginAtt isWindowVMargin, getWindowVMarginAtt
from windowdraw import drawwindowlook from windowdraw import drawwindowlook`
from windowupdate import updatewindowbackgrounds from windowupdate import updatewindowbackgrounds
from ospicture import pictscroll
from osrgn import osgetrgnbox
from ostypes import Rect from ostypes import Rect
from ostoolbox import OSToolbox from ostoolbox import OSToolbox
from oswindow import OSWindowMetrics, OSscrollbarsAreVisible, OSsetWindowSliderThumb, toOSscrollbarRange, OSMinWindowSize from oswindow import OSWindowMetrics, OSscrollbarsAreVisible, OSsetWindowSliderThumb, toOSscrollbarRange, OSMinWindowSize
controlposFatalError :: String String -> .x
controlposFatalError function error
= FatalError function "controlpos" error
/* movewindowviewframe moves the current view frame of the WindowHandle by the given Vector2. /* movewindowviewframe moves the current view frame of the WindowHandle by the given Vector2.
movewindowviewframe assumes that the argument WindowHandle is a Window. movewindowviewframe assumes that the argument WindowHandle is a Window.
*/ */
movewindowviewframe :: !OSWindowMetrics !Vector2 !WIDS !(WindowHandle .ls .pst) !*OSToolbox -> (!WindowHandle .ls .pst,!*OSToolbox) movewindowviewframe :: !OSWindowMetrics !Vector2 !WIDS !(WindowHandle .ls .pst) !*OSToolbox -> (!WindowHandle .ls .pst,!*OSToolbox)
movewindowviewframe wMetrics v wids=:{wPtr} wH tb movewindowviewframe wMetrics v wids=:{wPtr} wH=:{whWindowInfo,whItems=oldItems,whSize,whAtts,whSelect} tb
# visScrolls = OSscrollbarsAreVisible wMetrics (RectangleToRect domain) (toTuple wSize) (hasHScroll,hasVScroll)
contentRect = getWindowContentRect wMetrics visScrolls (SizeToRect wSize)
contentSize = RectSize contentRect
(minx,maxx,viewx) = (domainRect.rleft,domainRect.rright, contentSize.w)
(miny,maxy,viewy) = (domainRect.rtop, domainRect.rbottom,contentSize.h)
newOrigin = movePoint v oldOrigin
newOrigin = {x=SetBetween newOrigin.x minx (maxx-viewx),y=SetBetween newOrigin.y miny (maxy-viewy)}
| newOrigin==oldOrigin | newOrigin==oldOrigin
= (wH,tb) = (wH,tb)
| otherwise | otherwise
# tb = setsliderthumb hasHScroll wMetrics wPtr True (minx,newOrigin.x,maxx) viewx (toTuple wSize) tb # tb = setsliderthumb hasHScroll wMetrics wPtr True (minx,newOrigin.x,maxx) vieww (toTuple whSize) tb
# tb = setsliderthumb hasVScroll wMetrics wPtr False (miny,newOrigin.y,maxy) viewy (toTuple wSize) tb # tb = setsliderthumb hasVScroll wMetrics wPtr False (miny,newOrigin.y,maxy) viewh (toTuple whSize) tb
(defHSpace,defVSpace) = (wMetrics.osmHorItemSpace,wMetrics.osmVerItemSpace)
hMargins = getWindowHMarginAtt (snd (Select isWindowHMargin (WindowHMargin 0 0) atts))
vMargins = getWindowVMarginAtt (snd (Select isWindowVMargin (WindowVMargin 0 0) atts))
spaces = getWindowItemSpaceAtt (snd (Select isWindowItemSpace (WindowItemSpace defHSpace defVSpace) atts))
reqSize = {w=contentSize.w-fst hMargins-snd hMargins,h=contentSize.h-fst vMargins-snd vMargins} reqSize = {w=contentSize.w-fst hMargins-snd hMargins,h=contentSize.h-fst vMargins-snd vMargins}
# (_,newItems,tb) = layoutControls wMetrics hMargins vMargins spaces reqSize minSize [(domain,newOrigin)] oldItems tb # (_,newItems,tb) = layoutControls wMetrics hMargins vMargins spaces reqSize minSize [(domain,newOrigin)] oldItems tb
windowInfo = {windowInfo & windowOrigin=newOrigin} windowInfo = {windowInfo & windowOrigin=newOrigin}
// wH = {wH & whItems=newItems,whWindowInfo=Just windowInfo} Mike: changed Just into WindowInfo
wH = {wH & whItems=newItems,whWindowInfo=WindowInfo windowInfo} wH = {wH & whItems=newItems,whWindowInfo=WindowInfo windowInfo}
# (wH,tb) = forceValidWindowClipState wMetrics True wPtr wH tb # (wH,tb) = forceValidWindowClipState wMetrics True wPtr wH tb
# (updRgn,tb) = relayoutControls wMetrics whSelect contentRect contentRect zero zero wPtr whDefaultId oldItems wH.whItems tb # (isRect,areaRect,tb) = case wH.whWindowInfo of
WindowInfo {windowClip={clipRgn}} -> osgetrgnbox clipRgn tb
_ -> controlposFatalError "movewindowviewframe" "unexpected whWindowInfo field"
# (updRgn,tb) = relayoutControls wMetrics whSelect contentRect contentRect zero zero wPtr wH.whDefaultId oldItems wH.whItems tb
# (wH,tb) = updatewindowbackgrounds wMetrics updRgn wids wH tb # (wH,tb) = updatewindowbackgrounds wMetrics updRgn wids wH tb
newFrame = PosSizeToRectangle newOrigin contentSize // PA: drawinwindow might be redundant because of updatewindowbackgrounds newFrame = PosSizeToRectangle newOrigin contentSize
updState = {oldFrame=PosSizeToRectangle oldOrigin contentSize,newFrame=newFrame,updArea=[newFrame]} toMuch = (abs (newOrigin.x-oldOrigin.x)>=w`) || (abs (newOrigin.y-oldOrigin.y)>=h`)
# (wH,tb) = drawwindowlook wMetrics wPtr id updState wH tb (updArea,updAction) = if (not lookInfo.lookSysUpdate || toMuch || not isRect)
([newFrame],return []) (calcScrollUpdateArea oldOrigin newOrigin areaRect)
updState = {oldFrame=PosSizeToRectangle oldOrigin contentSize,newFrame=newFrame,updArea=updArea}
# (wH,tb) = drawwindowlook` wMetrics wPtr updAction updState wH tb
= (wH,tb) = (wH,tb)
where where
wSize = wH.whSize windowInfo = getWindowInfoWindowData whWindowInfo
// windowInfo = fromJust wH.whWindowInfo Mike: changed fromJust into getWindowInfoWindowData (oldOrigin,domainRect,hasHScroll,hasVScroll,lookInfo)
windowInfo = getWindowInfoWindowData wH.whWindowInfo = (windowInfo.windowOrigin,windowInfo.windowDomain,isJust windowInfo.windowHScroll,isJust windowInfo.windowVScroll,windowInfo.windowLook)
domainRect = windowInfo.windowDomain
domain = RectToRectangle domainRect domain = RectToRectangle domainRect
oldOrigin = windowInfo.windowOrigin visScrolls = OSscrollbarsAreVisible wMetrics domainRect (toTuple whSize) (hasHScroll,hasVScroll)
hasHScroll = isJust windowInfo.windowHScroll contentRect = getWindowContentRect wMetrics visScrolls (SizeToRect whSize)
hasVScroll = isJust windowInfo.windowVScroll contentSize = RectSize contentRect
atts = wH.whAtts {w=w`,h=h`} = contentSize
oldItems = wH.whItems (minx,maxx,vieww) = (domainRect.rleft,domainRect.rright, contentSize.w)
whSelect = wH.whSelect (miny,maxy,viewh) = (domainRect.rtop, domainRect.rbottom,contentSize.h)
whDefaultId = wH.whDefaultId newOrigin = { x = SetBetween (oldOrigin.x+v.vx) minx (max minx (maxx-vieww))
, y = SetBetween (oldOrigin.y+v.vy) miny (max miny (maxy-viewh))
}
(defMinW,defMinH) = OSMinWindowSize (defMinW,defMinH) = OSMinWindowSize
minSize = {w=defMinW,h=defMinH} minSize = {w=defMinW,h=defMinH}
(defHSpace,defVSpace) = (wMetrics.osmHorItemSpace,wMetrics.osmVerItemSpace)
hMargins = getWindowHMarginAtt (snd (Select isWindowHMargin (WindowHMargin 0 0) whAtts))
vMargins = getWindowVMarginAtt (snd (Select isWindowVMargin (WindowVMargin 0 0) whAtts))
spaces = getWindowItemSpaceAtt (snd (Select isWindowItemSpace (WindowItemSpace defHSpace defVSpace) whAtts))
setsliderthumb :: !Bool OSWindowMetrics OSWindowPtr Bool (Int,Int,Int) Int (Int,Int) !*OSToolbox -> *OSToolbox setsliderthumb :: !Bool !OSWindowMetrics !OSWindowPtr !Bool !(!Int,!Int,!Int) !Int !(!Int,!Int) !*OSToolbox -> *OSToolbox
setsliderthumb hasScroll wMetrics wPtr isHScroll scrollValues viewSize maxcoords tb setsliderthumb hasScroll wMetrics wPtr isHScroll scrollValues viewSize maxcoords tb
| hasScroll = OSsetWindowSliderThumb wMetrics wPtr isHScroll osThumb maxcoords True tb | hasScroll = OSsetWindowSliderThumb wMetrics wPtr isHScroll osThumb maxcoords True tb
| otherwise = tb | otherwise = tb
where where
(_,osThumb,_,_) = toOSscrollbarRange scrollValues viewSize (_,osThumb,_,_) = toOSscrollbarRange scrollValues viewSize
/* calcScrollUpdateArea p1 p2 area calculates the new update area that has to be updated.
Assumptions: p1 is the origin before scrolling,
p2 is the origin after scrolling,
area is the visible area of the window view frame.
*/
calcScrollUpdateArea :: !Point2 !Point2 !Rect -> (![Rectangle],!St *Picture [Rect])
calcScrollUpdateArea oldOrigin newOrigin areaRect
= (map RectToRectangle updArea,scroll {newOriginAreaRect & rright=rright+1,rbottom=rbottom+1} restArea v)
where
newOriginAreaRect = addVector (toVector newOrigin) areaRect
{rleft,rtop,rright,rbottom} = newOriginAreaRect
v = toVector (oldOrigin-newOrigin)
{vx,vy} = v
(updArea,restArea) = if (vx<=0 && vy<=0)
( [{newOriginAreaRect & rleft=rright+vx,rbottom=rbottom+vy},{newOriginAreaRect & rtop=rbottom+vy}]
, {newOriginAreaRect & rright=rright+vx,rbottom=rbottom+vy}
)
(if (vx<=0 && vy>=0)
( [{newOriginAreaRect & rbottom=rtop+vy},{newOriginAreaRect & rleft=rright+vx,rtop=rtop+vy}]
, {newOriginAreaRect & rtop=rtop+vy,rright=rright+vx}
)
(if (vx>=0 && vy<=0)
( [{newOriginAreaRect & rright=rleft+vx,rbottom=rbottom+vy},{newOriginAreaRect & rtop=rbottom+vy}]
, {newOriginAreaRect & rleft=rleft+vx,rbottom=rbottom+vy}
)
// if (vx>=0 && vy>=0)
( [{newOriginAreaRect & rbottom=rtop+vy},{newOriginAreaRect & rtop=rtop+vy,rright=rleft+vx}]
, {newOriginAreaRect & rleft=rleft+vx,rtop=rtop+vy}
)))
scroll :: !Rect !Rect !Vector2 !*Picture -> (![Rect],!*Picture)
scroll scrollRect restRect v picture
# (updRect,picture) = pictscroll scrollRect v picture
| updRect==zero
= ([],picture)
| otherwise
= ([restRect],picture)
definition module documentinterface
// Clean Object I/O library, version 1.2
from iostate import PSt, IOSt
from osdocumentinterface import OSDInfo
/* setOSDInfoInMenuDevice stores process document interface information in the menu device.
*/
setOSDInfoInMenuDevice :: !OSDInfo !(PSt .l .p) -> PSt .l .p
/* closeOSDInfo is the final call needed to close the proper document interface resources.
It should be called only after all other devices have been closed.
*/
closeOSDInfo :: !(IOSt .l .p) -> IOSt .l .p
implementation module documentinterface
// Clean Object I/O library, version 1.2
import StdBool, StdFunc, StdMisc
import osdocumentinterface, osmenu
import commondef, iostate, menudevice, menuevent
documentinterfaceFatalError :: String String -> .x
documentinterfaceFatalError function error
= FatalError function "documentinterface" error
/* setOSDInfoInMenuDevice stores process document interface information in the menu device.
*/
setOSDInfoInMenuDevice :: !OSDInfo !(PSt .l .p) -> PSt .l .p
setOSDInfoInMenuDevice OSNoInfo pState
= pState
setOSDInfoInMenuDevice osdinfo pState
# pState = MenuFunctions.dOpen pState
# (mDevice,ioState) = IOStGetDevice MenuDevice pState.io
mHs = MenuSystemStateGetMenuHandles mDevice
mHs = {mHs & mOSMenuBar=OSMenuBarNew frame client menubar}
# ioState = IOStSetDevice (MenuSystemState mHs) ioState
= {pState & io=ioState}
where
(frame,client,menubar) = case osdinfo of
OSMDInfo info -> (info.osmdFrame,info.osmdClient,info.osmdMenubar)
OSSDInfo info -> (info.ossdFrame,info.ossdClient,info.ossdMenubar)
OSNoInfo -> documentinterfaceFatalError "setOSDInfoInMenuDevice" "unexpected OSDInfo argument"
closeOSDInfo :: !(IOSt .l .p) -> IOSt .l .p
closeOSDInfo ioState
# (osdinfo,ioState) = IOStGetOSDInfo ioState
close = case osdinfo of
OSMDInfo info -> OScloseMDI info
OSSDInfo info -> OScloseSDI info
_ -> id
= appIOToolbox close ioState
...@@ -1387,33 +1387,29 @@ where ...@@ -1387,33 +1387,29 @@ where
= (wH,tb) = (wH,tb)
| otherwise | otherwise
# (_,newOSThumb,_,_) = toOSscrollbarRange (min`,newThumb,max`) viewSize # (_,newOSThumb,_,_) = toOSscrollbarRange (min`,newThumb,max`) viewSize
newOrigin = if isHorizontal {origin & x=newThumb} {origin & y=newThumb} newOrigin = if isHorizontal {oldOrigin & x=newThumb} {oldOrigin & y=newThumb}
# tb = OSsetWindowSliderThumb wMetrics wPtr isHorizontal newOSThumb (toTuple whSize) True tb # tb = OSsetWindowSliderThumb wMetrics wPtr isHorizontal newOSThumb (toTuple whSize) True tb
# (_,newItems,tb) = layoutControls wMetrics hMargins vMargins spaces contentSize minSize [(domain,newOrigin)] oldItems tb # (_,newItems,tb) = layoutControls wMetrics hMargins vMargins spaces contentSize minSize [(domain,newOrigin)] oldItems tb
wH = { wH & whWindowInfo = WindowInfo {windowInfo & windowOrigin=newOrigin} wH = { wH & whWindowInfo = WindowInfo {windowInfo & windowOrigin=newOrigin}
, whItems = newItems , whItems = newItems
} }
# (wH,tb) = forceValidWindowClipState wMetrics True wPtr wH tb # (wH,tb) = forceValidWindowClipState wMetrics True wPtr wH tb
(scrollWindowInfo,wH) = (\wH=:{whWindowInfo}->(whWindowInfo,wH)) wH # (isRect,areaRect,tb) = case wH.whWindowInfo of
# (isRect,areaRect,tb) = case scrollWindowInfo of
WindowInfo {windowClip={clipRgn}} -> osgetrgnbox clipRgn tb WindowInfo {windowClip={clipRgn}} -> osgetrgnbox clipRgn tb
_ -> windowdeviceFatalError "windowScrollActionIO" "unexpected empty whWindowInfo field" _ -> windowdeviceFatalError "windowScrollActionIO" "unexpected whWindowInfo field"
# (updRgn,tb) = relayoutControls wMetrics whSelect contentRect contentRect zero zero wPtr wH.whDefaultId oldItems wH.whItems tb # (updRgn,tb) = relayoutControls wMetrics whSelect contentRect contentRect zero zero wPtr wH.whDefaultId oldItems wH.whItems tb
# (wH,tb) = updatewindowbackgrounds wMetrics updRgn info.wsaWIDS wH tb # (wH,tb) = updatewindowbackgrounds wMetrics updRgn info.wsaWIDS wH tb
newFrame = PosSizeToRectangle newOrigin contentSize newFrame = PosSizeToRectangle newOrigin contentSize
toMuch = if isHorizontal (abs (newOrigin.x-origin.x)>=w`) (abs (newOrigin.y-origin.y)>=h`) toMuch = if isHorizontal (abs (newOrigin.x-oldOrigin.x)>=w`) (abs (newOrigin.y-oldOrigin.y)>=h`)
(updArea,updAction) = if (not lookInfo.lookSysUpdate || toMuch || not isRect) (updArea,updAction) = if (not lookInfo.lookSysUpdate || toMuch || not isRect)
(newFrame,\s->(zero,s)) (calcScrollUpdateArea origin newOrigin areaRect) (newFrame,return []) (calcScrollUpdateArea oldOrigin newOrigin areaRect)
updState = { oldFrame=oldFrame updState = {oldFrame=oldFrame,newFrame=newFrame,updArea=[updArea]}
, newFrame=newFrame
, updArea =[updArea]
}
# (wH,tb) = drawwindowlook` wMetrics wPtr updAction updState wH tb # (wH,tb) = drawwindowlook` wMetrics wPtr updAction updState wH tb
# tb = OSvalidateWindowRect wPtr (SizeToRect whSize) tb // # tb = OSvalidateWindowRect wPtr (SizeToRect whSize) tb
= (wH,tb) = (wH,tb)
where where
windowInfo = getWindowInfoWindowData whWindowInfo windowInfo = getWindowInfoWindowData whWindowInfo
(origin,domainRect,hasHScroll,hasVScroll,lookInfo) (oldOrigin,domainRect,hasHScroll,hasVScroll,lookInfo)
= (windowInfo.windowOrigin,windowInfo.windowDomain,isJust windowInfo.windowHScroll,isJust windowInfo.windowVScroll,windowInfo.windowLook) = (windowInfo.windowOrigin,windowInfo.windowDomain,isJust windowInfo.windowHScroll,isJust windowInfo.windowVScroll,windowInfo.windowLook)
isHorizontal = info.wsaDirection==Horizontal isHorizontal = info.wsaDirection==Horizontal
domain = RectToRectangle domainRect domain = RectToRectangle domainRect
...@@ -1421,11 +1417,11 @@ where ...@@ -1421,11 +1417,11 @@ where
contentRect = getWindowContentRect wMetrics visScrolls (SizeToRect whSize) contentRect = getWindowContentRect wMetrics visScrolls (SizeToRect whSize)
contentSize = RectSize contentRect contentSize = RectSize contentRect
{w=w`,h=h`} = contentSize {w=w`,h=h`} = contentSize
oldFrame = PosSizeToRectangle origin contentSize oldFrame = PosSizeToRectangle oldOrigin contentSize
(min`,oldThumb,max`,viewSize) (min`,oldThumb,max`,viewSize)
= if isHorizontal = if isHorizontal
(domain.corner1.x,origin.x,domain.corner2.x,w`) (domain.corner1.x,oldOrigin.x,domain.corner2.x,w`)
(domain.corner1.y,origin.y,domain.corner2.y,h`) (domain.corner1.y,oldOrigin.y,domain.corner2.y,h`)
sliderState = {sliderMin=min`,sliderThumb=oldThumb,sliderMax=max`-viewSize} sliderState = {sliderMin=min`,sliderThumb=oldThumb,sliderMax=max`-viewSize}
scrollInfo = fromJust (if isHorizontal windowInfo.windowHScroll windowInfo.windowVScroll) scrollInfo = fromJust (if isHorizontal windowInfo.windowHScroll windowInfo.windowVScroll)
scrollFun = scrollInfo.scrollFunction scrollFun = scrollInfo.scrollFunction
...@@ -1444,28 +1440,28 @@ where ...@@ -1444,28 +1440,28 @@ where
area is the visible area of the window view frame, area is the visible area of the window view frame,
scrolling occurs either horizontally or vertically. scrolling occurs either horizontally or vertically.
*/ */
calcScrollUpdateArea :: !Point2 !Point2 !Rect -> (!Rectangle,!St *Picture Rect) calcScrollUpdateArea :: !Point2 !Point2 !Rect -> (!Rectangle,!St *Picture [Rect])
calcScrollUpdateArea oldOrigin newOrigin areaRect calcScrollUpdateArea oldOrigin newOrigin areaRect
= (updArea,scroll {originAreaRect & rright=rright+1,rbottom=rbottom+1} restArea v) = (updArea,scroll {newOriginAreaRect & rright=rright+1,rbottom=rbottom+1} restArea v)
where where
originAreaRect = addVector (toVector newOrigin) areaRect newOriginAreaRect = addVector (toVector newOrigin) areaRect
{rleft,rtop,rright,rbottom} = originAreaRect {rleft,rtop,rright,rbottom} = newOriginAreaRect
originAreaRectangle = RectToRectangle originAreaRect newOriginAreaRectangle = RectToRectangle newOriginAreaRect
v = toVector (oldOrigin-newOrigin) v = toVector (oldOrigin-newOrigin)
{vx,vy} = v {vx,vy} = v
(updArea,restArea) = if (vx<0) ({originAreaRectangle & corner1={x=rright+vx,y=rtop}}, {originAreaRect & rright =rright +vx}) (updArea,restArea) = if (vx<0) ({newOriginAreaRectangle & corner1={x=rright+vx,y=rtop}}, {newOriginAreaRect & rright =rright +vx})
(if (vx>0) ({originAreaRectangle & corner2={x=rleft+vx, y=rbottom}}, {originAreaRect & rleft =rleft +vx}) (if (vx>0) ({newOriginAreaRectangle & corner2={x=rleft+vx, y=rbottom}}, {newOriginAreaRect & rleft =rleft +vx})
(if (vy<0) ({originAreaRectangle & corner1={x=rleft, y=rbottom+vy}},{originAreaRect & rbottom=rbottom+vy}) (if (vy<0) ({newOriginAreaRectangle & corner1={x=rleft, y=rbottom+vy}},{newOriginAreaRect & rbottom=rbottom+vy})
(if (vy>0) ({originAreaRectangle & corner2={x=rright, y=rbottom+vy}},{originAreaRect & rtop =rtop +vy}) (if (vy>0) ({newOriginAreaRectangle & corner2={x=rright, y=rtop+vy}}, {newOriginAreaRect & rtop =rtop +vy})
(windowdeviceFatalError "calcUpdateArea (scrolling window)" "assumption violation")))) (windowdeviceFatalError "calcScrollUpdateArea (scrolling window)" "assumption violation"))))
scroll :: !Rect !Rect !Vector2 !*Picture -> (!Rect,!*Picture) scroll :: !Rect !Rect !Vector2 !*Picture -> (![Rect],!*Picture)
scroll scrollRect restRect v picture scroll scrollRect restRect v picture
# (updRect,picture) = pictscroll scrollRect v picture # (updRect,picture) = pictscroll scrollRect v picture
| updRect==zero | updRect==zero
= (zero,picture) = ([],picture)
| otherwise | otherwise
= (restRect,picture) = ([restRect],picture)
windowStateScrollActionIO _ _ _ _ windowStateScrollActionIO _ _ _ _
= windowdeviceFatalError "windowStateScrollActionIO" "unexpected window placeholder" = windowdeviceFatalError "windowStateScrollActionIO" "unexpected window placeholder"
......
...@@ -16,11 +16,11 @@ import windowhandle ...@@ -16,11 +16,11 @@ import windowhandle
drawinwindow applies the drawing function to the given WindowHandle. drawinwindow applies the drawing function to the given WindowHandle.
These functions assume that WindowHandle refers to a Window with a valid ClipState. These functions assume that WindowHandle refers to a Window with a valid ClipState.
*/ */
drawwindowlook :: !OSWindowMetrics !OSWindowPtr !(IdFun *Picture) !UpdateState !(WindowHandle .ls .pst) !*OSToolbox drawwindowlook :: !OSWindowMetrics !OSWindowPtr !(IdFun *Picture) !UpdateState !(WindowHandle .ls .pst) !*OSToolbox
-> (!WindowHandle .ls .pst, !*OSToolbox) -> (!WindowHandle .ls .pst, !*OSToolbox)
drawwindowlook` :: !OSWindowMetrics !OSWindowPtr !(St *Picture Rect) !UpdateState !(WindowHandle .ls .pst) !*OSToolbox drawwindowlook` :: !OSWindowMetrics !OSWindowPtr !(St *Picture [Rect]) !UpdateState !(WindowHandle .ls .pst) !*OSToolbox
-> (!WindowHandle .ls .pst, !*OSToolbox) -> (!WindowHandle .ls .pst, !*OSToolbox)
drawinwindow :: !OSWindowMetrics !OSWindowPtr !.(St *Picture .x) !(WindowHandle .ls .pst) !*OSToolbox drawinwindow :: !OSWindowMetrics !OSWindowPtr !.(St *Picture .x) !(WindowHandle .ls .pst) !*OSToolbox
-> (.x, !WindowHandle .ls .pst, !*OSToolbox) -> (.x,!WindowHandle .ls .pst, !*OSToolbox)
...@@ -43,34 +43,34 @@ where ...@@ -43,34 +43,34 @@ where
{w,h} = RectSize (getWindowContentRect wMetrics visScrolls (SizeToRect whSize)) {w,h} = RectSize (getWindowContentRect wMetrics visScrolls (SizeToRect whSize))
wFrame = {corner1=origin,corner2={x=origin.x+w,y=origin.y+h}} wFrame = {corner1=origin,corner2={x=origin.x+w,y=origin.y+h}}
drawwindowlook` :: !OSWindowMetrics !OSWindowPtr !(St *Picture Rect) !UpdateState !(WindowHandle .ls .pst) !*OSToolbox drawwindowlook` :: !OSWindowMetrics !OSWindowPtr !(St *Picture [Rect]) !UpdateState !(WindowHandle .ls .pst) !*OSToolbox
-> (!WindowHandle .ls .pst, !*OSToolbox) -> (!WindowHandle .ls .pst, !*OSToolbox)
drawwindowlook` wMetrics wPtr drawFirst updState wH=:{whSelect,whSize,whWindowInfo} tb drawwindowlook` wMetrics wPtr drawFirst updState wH=:{whSelect,whSize,whWindowInfo} tb
#! (osPict,tb) = OSgrabWindowPictContext wPtr tb #! (osPict,tb) = OSgrabWindowPictContext wPtr tb
#! picture = packPicture origin (copyPen look.lookPen) True osPict tb #! picture = packPicture origin (copyPen look.lookPen) True osPict tb
#! picture = pictsetcliprgn clipRgn picture #! picture = pictsetcliprgn clipRgn picture
#! (additionalUpdateRect,picture) #! (additionalUpdateArea,picture)
= drawFirst picture = drawFirst picture
updState = if (additionalUpdateRect==zero) updState {updState & updArea=[RectToRectangle additionalUpdateRect:updState.updArea]} updState = {updState & updArea = [RectToRectangle r \\ r<-additionalUpdateArea | not (IsEmptyRect r)] ++ updState.updArea}
#! picture = appClipPicture (toRegion wFrame) (look.lookFun select updState) picture #! picture = appClipPicture (toRegion wFrame) (look.lookFun select updState) picture
#! (_,pen,_,osPict,tb)= unpackPicture picture #! (_,pen,_,osPict,tb) = unpackPicture picture
#! tb = OSreleaseWindowPictContext wPtr osPict tb #! tb = OSreleaseWindowPictContext wPtr osPict tb
#! tb = OSvalidateWindowRgn wPtr clipRgn tb // PA: added to eliminate update of window (in drawing part) #! tb = OSvalidateWindowRgn wPtr clipRgn tb // PA: added to eliminate update of window (in drawing part)
#! look = {look & lookPen=pen} #! look = {look & lookPen=pen}
#! info = {info & windowLook=look} #! info = {info & windowLook=look}
= ({wH & whWindowInfo=WindowInfo info},tb) = ({wH & whWindowInfo=WindowInfo info},tb)
where where
select = if whSelect Able Unable select = if whSelect Able Unable
info = getWindowInfoWindowData whWindowInfo info = getWindowInfoWindowData whWindowInfo
domainRect = info.windowDomain domainRect = info.windowDomain
origin = info.windowOrigin origin = info.windowOrigin
look = info.windowLook look = info.windowLook
clip = info.windowClip clip = info.windowClip
clipRgn = clip.clipRgn clipRgn = clip.clipRgn
hasScrolls = (isJust info.windowHScroll,isJust info.windowVScroll) hasScrolls = (isJust info.windowHScroll,isJust info.windowVScroll)
visScrolls = OSscrollbarsAreVisible wMetrics domainRect (toTuple whSize) hasScrolls visScrolls = OSscrollbarsAreVisible wMetrics domainRect (toTuple whSize) hasScrolls
{w,h} = RectSize (getWindowContentRect wMetrics visScrolls (SizeToRect whSize)) {w,h} = RectSize (getWindowContentRect wMetrics visScrolls (SizeToRect whSize))
wFrame = {corner1=origin,corner2={x=origin.x+w,y=origin.y+h}} wFrame = {corner1=origin,corner2={x=origin.x+w,y=origin.y+h}}
/* drawinwindow wPtr drawfun window /* drawinwindow wPtr drawfun window
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment