packages feed

ObjectIO (empty) → 1.0.1.1

raw patch · 115 files changed

+28804/−0 lines, 115 filesbuild-type:Customsetup-changed

Files

+ Graphics/UI/ObjectIO.hs view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  ObjectIO+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- ObjectIO contains all definition modules of the Object I\/O library.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO+		( module Graphics.UI.ObjectIO.StdId+             	, module Graphics.UI.ObjectIO.StdIOBasic+             	, module Graphics.UI.ObjectIO.StdIOCommon+             	, module Graphics.UI.ObjectIO.StdKey+             	, module Graphics.UI.ObjectIO.StdGUI+             	, module Graphics.UI.ObjectIO.StdPicture+             	, module Graphics.UI.ObjectIO.StdBitmap+             	, module Graphics.UI.ObjectIO.StdProcess+             	, module Graphics.UI.ObjectIO.StdControl             	+	     	, module Graphics.UI.ObjectIO.StdControlReceiver+             	, module Graphics.UI.ObjectIO.StdReceiver+             	, module Graphics.UI.ObjectIO.StdWindow+             	, module Graphics.UI.ObjectIO.StdMenu+             	, module Graphics.UI.ObjectIO.StdMenuReceiver+             	, module Graphics.UI.ObjectIO.StdMenuElement+             	, module Graphics.UI.ObjectIO.StdTimer+             	, module Graphics.UI.ObjectIO.StdTimerReceiver+             	, module Graphics.UI.ObjectIO.StdFileSelect+             	, module Graphics.UI.ObjectIO.StdSound+             	, module Graphics.UI.ObjectIO.StdClipboard+             	, module Graphics.UI.ObjectIO.StdSystem+             	) where++import Graphics.UI.ObjectIO.StdId		-- The operations that generate identification values+import Graphics.UI.ObjectIO.StdIOBasic		-- Function and type definitions used in the library+import Graphics.UI.ObjectIO.StdIOCommon		-- Function and type definitions used in the library+import Graphics.UI.ObjectIO.StdKey		-- Function and type definitions on keyboard+import Graphics.UI.ObjectIO.StdGUI		-- Type definitions used in the library++import Graphics.UI.ObjectIO.StdPicture		-- Picture handling operations+import Graphics.UI.ObjectIO.StdBitmap		-- Defines an instance for drawing bitmaps++import Graphics.UI.ObjectIO.StdProcess		-- Process handling operations++import Graphics.UI.ObjectIO.StdControl		-- Control handling operations+import Graphics.UI.ObjectIO.StdControlReceiver++import Graphics.UI.ObjectIO.StdReceiver		-- Receiver handling operations++import Graphics.UI.ObjectIO.StdWindow		-- Window handling operations++import Graphics.UI.ObjectIO.StdMenu+import Graphics.UI.ObjectIO.StdMenuReceiver+import Graphics.UI.ObjectIO.StdMenuElement++import Graphics.UI.ObjectIO.StdTimer+import Graphics.UI.ObjectIO.StdTimerReceiver++import Graphics.UI.ObjectIO.StdFileSelect++import Graphics.UI.ObjectIO.StdSound++import Graphics.UI.ObjectIO.StdClipboard++import Graphics.UI.ObjectIO.StdSystem
+ Graphics/UI/ObjectIO/CommonDef.hs view
@@ -0,0 +1,571 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  CommonDef+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- CommonDef defines common types for the Object I\/O library and access-rules.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.CommonDef		+		(+		-- * Common definitions+		+		-- ** Type declarations+                  St, Cond, UCond,+                  +                -- ** Function declarations+		  toSt, setBetween, isBetween, minmax+		, fst3snd3, fst3thd3, snd3thd3, eqfst2id, eqfst3id,+		  +		-- * Bound type+		  Bound(..),+		  +		-- ** Operations+		  zeroBound, decBound, incBound,+		  +		-- * Calculation rules on Point2s, Sizes, Rectangles and Vector2s:+		  Graphics.UI.ObjectIO.OS.Types.Rect(..),+		  +		-- ** Function declarations+		  addPointSize+		, rectangleToRect, rectToRectangle+		, isEmptyRect, isEmptyRectangle+		, pointInRect, pointInRectangle+		, posSizeToRect, posSizeToRectangle+		, sizeToRect, sizeToRectangle, rectSize+		, disjointRects, intersectRects, subtractRects,+		  +		-- ** Class declarations+		  AddVector(..), SubVector(..), ToTuple(..), FromTuple(..)+		, ToTuple4(..), FromTuple4(..),		++		-- * List operations		+		  isSingleton, initLast, split, condMap, uspan+		, filterMap, stateMap, ucontains, cselect, access, accessList+		, remove, uremove, creplace, ucreplace, replaceOrAppend, ureplaceOrAppend+		, removeCheck, removeSpecialChars, disjointLists, noDuplicates, unzip4+		, stateMapM, foldrM, sequenceMap, ssequence, gather,++		-- * Error generation+		  dumpFatalError, dummy,+		  +                -- * A visible module+                  module Graphics.UI.ObjectIO.StdIOCommon+                ) where+++import Graphics.UI.ObjectIO.OS.Types (Rect(..))+import Graphics.UI.ObjectIO.StdIOCommon++-- | State transformer+type St s a = s -> (a,s)++-- | Simple predicate+type	Cond  x = x -> Bool++-- | Predicate which returns its updated argument+type	UCond x = x -> (Bool,x)++-- | This function is convenient for lifting a function to a 'St' transformer.+toSt :: (x -> y) -> St x y+toSt acc x = (acc x,x)++setBetween :: Int -> Int -> Int -> Int+setBetween x low up+	| x<=low     = low+	| x>=up      = up+	| otherwise  = x++isBetween :: Int -> Int -> Int -> Bool+isBetween x low up+	| x<low      = False+	| otherwise  = x<=up++minmax :: Int -> Int -> (Int,Int)+minmax a b+	| a<=b       = (a,b)+	| otherwise  = (b,a)+++{-	Calculation rules on Point2s, Sizes, and Vector2s:+-}+addPointSize :: Size -> Point2 -> Point2+addPointSize size point = Point2 {x=x point+w size,y=y point+h size}+++instance Zero Rect where+	zero = Rect {rleft=0,rtop=0,rright=0,rbottom=0}++class AddVector a where+	addVector :: Vector2 -> a -> a		-- add the vector argument to the second argument++instance AddVector Point2 where+	addVector v p+		= Point2 {x=x p+vx v,y=y p+vy v}+instance AddVector Rect where+	addVector v r+		= Rect {rleft=rleft r+vx v,rtop=rtop r+vy v,rright=rright r+vx v,rbottom=rbottom r+vy v}+instance AddVector Rectangle where+	addVector v r+		= Rectangle {corner1=addVector v (corner1 r),corner2=addVector v (corner2 r)}+++class SubVector a where+	subVector :: Vector2 -> a -> a		-- subtract the vector argument from the second argument++instance SubVector Point2 where+	subVector v p+		= Point2 {x=x p-vx v,y=y p-vy v}+instance SubVector Rect where+	subVector v r+		= Rect {rleft=rleft r-vx v,rtop=rtop r-vy v,rright=rright r-vx v,rbottom=rbottom r-vy v}+instance SubVector Rectangle where+	subVector v r+		= Rectangle {corner1=subVector v (corner1 r),corner2=subVector v (corner2 r)}++rectangleToRect :: Rectangle -> Rect+rectangleToRect r+	| x_less_x' && y_less_y' = Rect {rleft=a,  rtop=b,  rright=a', rbottom=b'}+	| x_less_x'              = Rect {rleft=a,  rtop=b', rright=a', rbottom=b }+	| y_less_y'              = Rect {rleft=a', rtop=b,  rright=a,  rbottom=b'}+	| otherwise              = Rect {rleft=a', rtop=b', rright=a,  rbottom=b }+	where+		c1               = corner1 r+		c2               = corner2 r+		a                = x c1+		b                = y c1+		a'               = x c2+		b'               = y c2+		x_less_x'        = a<=a'+		y_less_y'        = b<=b'++rectToRectangle :: Rect -> Rectangle+rectToRectangle r+	= Rectangle {corner1=Point2 {x=rleft r,y=rtop r},corner2=Point2 {x=rright r,y=rbottom r}}++isEmptyRect :: Rect -> Bool+isEmptyRect r+	= rleft r==rright r || rtop r==rbottom r++isEmptyRectangle :: Rectangle -> Bool+isEmptyRectangle r+	= x (corner1 r) == x (corner2 r) || y (corner1 r) == y (corner2 r)++pointInRect :: Point2 -> Rect -> Bool+pointInRect p r+	= isBetween (x p) (rleft r) (rright r) && isBetween (y p) (rtop r) (rbottom r)++pointInRectangle :: Point2 -> Rectangle -> Bool+pointInRectangle point rectangle+	= pointInRect point (rectangleToRect rectangle)++posSizeToRect :: Point2 -> Size -> Rect+posSizeToRect point size+	= let+		(left,right) = minmax (x point) (x point+w size)+		(top,bottom) = minmax (y point) (y point+h size)+	in	Rect {rleft=left,rtop=top, rright=right,rbottom=bottom}++posSizeToRectangle :: Point2 -> Size -> Rectangle+posSizeToRectangle pos size+	= Rectangle {corner1=pos,corner2=Point2 {x=x pos+w size,y=y pos+h size}}++sizeToRect :: Size -> Rect+sizeToRect size+	= posSizeToRect zero size++sizeToRectangle :: Size -> Rectangle+sizeToRectangle size+	= zero {corner2=Point2 {x=w size,y=h size}}++disjointRects :: Rect -> Rect -> Bool+disjointRects rect1 rect2+	= isEmptyRect rect1 || +	  isEmptyRect rect2 || +	  rleft rect1>=rright rect2 || rbottom rect1<=rtop rect2 || rright rect1<=rleft rect2 || rtop rect1>=rbottom rect2++intersectRects :: Rect -> Rect -> Rect+intersectRects rect1 rect2+	| disjointRects rect1 rect2	= zero+	| otherwise			= Rect	{ rleft  = max (rleft   rect1) (rleft   rect2)+						, rtop   = max (rtop    rect1) (rtop    rect2)+						, rright = min (rright  rect1) (rright  rect2)+						, rbottom= min (rbottom rect1) (rbottom rect2)+						}++subtractRects :: Rect -> Rect -> [Rect]+subtractRects rect1 rect2+	= let+	--	subtractFittingRect r1 r2 subtracts r2 from r1 assuming that r2 fits inside r1+		subtractFittingRect :: Rect -> Rect -> [Rect]+		subtractFittingRect rect1 rect2+			= let+				l1 = rleft rect1;	t1 = rtop rect1;	r1 = rright rect1;	b1 = rbottom rect1+				l2 = rleft rect2;	t2 = rtop rect2;	r2 = rright rect2;	b2 = rbottom rect2+			in	filter (not . isEmptyRect) (map fromTuple4 [(l1,t1,r1,t2),(l1,t2,l2,b2),(r2,t2,r1,b2),(l1,b2,r1,b1)])+	in	subtractFittingRect rect1 (intersectRects rect1 rect2)+++rectSize :: Rect -> Size+rectSize r+	= Size {w=abs (rright r-rleft r),h=abs (rbottom r-rtop r)}+++{-	Conversion of Size, Point2, and Vector2 to tuples (toTuple) and from tuples (fromTuple):+-}+class ToTuple a where+	toTuple :: a -> (Int,Int)+class FromTuple a where+	fromTuple :: (Int,Int) -> a++instance ToTuple Size where+	toTuple size = (w size,h size)+instance ToTuple Point2 where+	toTuple point = (x point,y point)+instance ToTuple Vector2 where+	toTuple v = (vx v,vy v)++instance FromTuple Size where+	fromTuple (w,h) = Size {w=w,h=h}+instance FromTuple Point2 where+	fromTuple (x,y) = Point2 {x=x,y=y}+instance FromTuple Vector2 where+	fromTuple (vx,vy) = Vector2 {vx=vx,vy=vy}++{-	Conversion of Rect, and Rectangle to 4-tuples (toTuple4) and from 4-tuples (fromTuple4):+-}+class ToTuple4 a where+	toTuple4 :: a -> (Int,Int,Int,Int)+class FromTuple4 a where+	fromTuple4 :: (Int,Int,Int,Int) -> a++instance ToTuple4 Rect where+	toTuple4 r = (rleft r,rtop r,rright r,rbottom r)+instance ToTuple4 Rectangle where+	toTuple4 r = toTuple4 (rectangleToRect r)+instance FromTuple4 Rect where+	fromTuple4 r = rectangleToRect (fromTuple4 r)+instance FromTuple4 Rectangle where+	fromTuple4 (l,t,r,b) = Rectangle {corner1=Point2 {x=l,y=t},corner2=Point2 {x=r,y=b}}+++-- | Error generation rule.+-- Evaluation causes termination with the message:+--	Fatal error in rule \<rule\> \[module\] \<message\> .++dumpFatalError :: String -> String -> String -> x+dumpFatalError rule moduleName msg+	= error ("Fatal error in rule " ++ rule ++ " [" ++ moduleName ++ "]: " ++ msg ++ ".\n")+++-- | Universal dummy value.+-- Evaluation causes termination with the message:+-- 	Fatal error: dummy evaluated! \<message\> .++dummy :: String -> x+dummy msg = error ("Fatal error: dummy evaluated! " ++ msg ++ ".\n")++{-	Bound data type:+-}+data	Bound+	= Finite Int		-- Fix a finite positive bound of N+	| Infinite		-- No bound++instance Eq Bound where+	(==) (Finite i) (Finite j) = i==j || i<=0 && j<=0+	(==) Infinite   Infinite   = True+	(==) _          _          = False++zeroBound:: Bound -> Bool+zeroBound (Finite i) = i<=0+zeroBound _          = False++decBound :: Bound -> Bound+decBound (Finite i)+	| i<=0       = Finite 0+	| otherwise  = Finite (i-1)+decBound bound+	= bound++incBound :: Bound -> Bound+incBound (Finite i)+	| i<=0       = Finite 1+	| otherwise  = Finite (i+1)+incBound bound+	= bound+++{-	List operations:+-}++isSingleton :: [x] -> Bool+isSingleton [x] = True+isSingleton _   = False++initLast :: [x] -> ([x],x)+initLast [x]+	= ([],x)+initLast (x:xs)+	= let (init,last) = initLast xs+	  in  (x:init,last)++split :: Int -> [x] -> ([x],[x])+split _ []+	= ([],[])+split n xs+	| n<=0+		= ([],xs)+	| otherwise+		= let	(x:xs1) = xs+			(ys,zs)  = split (n-1) xs1+		  in	(x:ys,zs)++condMap :: Cond x -> IdFun x -> [x] -> (Bool,[x])+condMap c f (x:xs)+	| c x           = (True,f x:xs1)+	| otherwise     = (b,x:xs1)+	where+		(b,xs1) = condMap c f xs+condMap _ _ _+	= (False, [])++uspan :: (UCond a) -> [a] -> ([a],[a])	-- Same as span (StdList), but preserving uniqueness+uspan c (x:xs)+	| keep+		= let	(ys,zs) = uspan c xs+	  	  in	(x1:ys,zs)+	| otherwise+		= ([],x1:xs)+	where+		(keep,x1) = c x+uspan _ _+	= ([],[])++filterMap :: (x -> (Bool,y)) -> [x] -> [y]+filterMap f (x:xs)+	| keep           = y:ys+	| otherwise      = ys+	where+		(keep,y) = f x+		ys       = filterMap f xs+filterMap _ _+	= []++stateMap :: (x -> s -> (y,s)) -> [x] -> s -> ([y],s)+stateMap f (x:xs) s+	= (y:ys,s2)+	where+		(y, s1) = f x s+		(ys,s2) = stateMap f xs s1+stateMap _ _ s+	= ([],s)++ucontains :: (UCond x) -> [x] -> (Bool,[x])+ucontains c (x:xs)+	| cond+		= (True,x1:xs)+	| otherwise+		= let (b,xs1) = ucontains c xs+		  in  (b,x1:xs1)+	where+		(cond,x1) = c x+ucontains _ _+	= (False,[])++cselect :: (Cond x) -> x -> [x] -> (Bool, x)+cselect c n (x:xs)+	| c x		= (True,x)+	| otherwise	= cselect c n xs+cselect _ n _+	= (False,n)++access :: (St x (Bool,y)) -> y -> [x] -> (Bool,y,[x])+access acc n (x:xs)+	| cond+	  	= (True,y,x1:xs)+	| otherwise+		= let (b,y1,xs1) = access acc n xs+		  in  (b,y1,x1:xs1)+	where+		((cond,y),x1) = acc x+access _ n _+	= (False,n,[])++accessList :: (St x y) -> [x] -> ([y],[x])+accessList acc (x:xs)+	= (y:ys, x1:xs1)+	where+		(y, x1)  = acc x+		(ys,xs1) = accessList acc xs+accessList _ _+	= ([],[])++remove :: (Cond x) -> x -> [x] -> (Bool,x,[x])+remove c n (x:xs)+	| c x+		= (True,x,xs)+	| otherwise+		= let	(b,y,xs1) = remove c n xs+		  in	(b,y,x:xs1)+remove _ n _+	= (False,n,[])++uremove :: (UCond x) -> x -> [x] -> (Bool,x,[x])+uremove c n (x:xs)+	| cond+		= (True,x1,xs)+	| otherwise+		= let (b,y,xs1) = uremove c n xs+		  in  (b,y,x1:xs1)+	where+		(cond,x1) = c x+uremove _ n _+	= (False,n,[])++creplace :: (Cond x) -> x -> [x] -> (Bool,[x])+creplace c y (x:xs)+	| c x+		= (True,y:xs)+	| otherwise+		= let	(b,xs1) = creplace c y xs+		  in	(b,x:xs1)+creplace _ _ _+	= (False,[])++ucreplace :: (UCond x) -> x -> [x] -> (Bool,[x])+ucreplace c y (x:xs)+	| cond+		= (True,y:xs)+	| otherwise+		= let (b,xs1) = ucreplace c y xs+		  in  (b,x1:xs1)+	where+		(cond,x1) = c x+ucreplace _ _ _+	= (False,[])++replaceOrAppend :: (Cond x) -> x -> [x] -> [x]+replaceOrAppend c y (x:xs)+	| c x+		= y:xs+	| otherwise+		= x:replaceOrAppend c y xs+replaceOrAppend _ y _+	= [y]++ureplaceOrAppend :: (UCond x) -> x -> [x] -> [x]+ureplaceOrAppend c y (x:xs)+	| cond+		= y:xs+	| otherwise+		= x1:ureplaceOrAppend c y xs+	where+		(cond,x1) = c x+ureplaceOrAppend _ y _+	= [y]++removeCheck :: (Eq x) => x -> [x] -> (Bool, [x])+removeCheck y (x:xs)+	| y==x+		= (True,xs)+	| otherwise+		= let	(b,xs1) = removeCheck y xs+		  in	(b,x:xs1)+removeCheck _ _+	= (False,[])++removeSpecialChars :: [Char] -> String -> String+removeSpecialChars sc (c1:cs1@(c2:cs2))+	| c1 `elem` sc = c2:removeSpecialChars sc cs2+	| otherwise    = c1:removeSpecialChars sc cs1+removeSpecialChars sc [c]+	| c `elem` sc  = []+	| otherwise    = [c]+removeSpecialChars _ _+	= []++disjointLists :: (Eq x) => [x] -> [x] -> Bool+disjointLists xs ys+	| null xs || null ys = True+	| shorter xs ys      = disjointLists' xs ys+	| otherwise          = disjointLists' ys xs+	where+		shorter :: [x] -> [x] -> Bool+		shorter []     _      = True+		shorter (_:xs) (_:ys) = shorter xs ys+		shorter _      _      = False+		+		disjointLists' :: (Eq x) => [x] -> [x] -> Bool+		disjointLists' (x:xs) ys = not (x `elem` ys) && disjointLists' xs ys+		disjointLists' _      _  = True++noDuplicates :: (Eq x) => [x] -> Bool+noDuplicates (x:xs) = not (x `elem` xs) && noDuplicates xs+noDuplicates _      = True++unzip4 :: [(a,b,c,d)]	-> ([a],[b],[c],[d])+unzip4 xs = foldr (\(a,b,c,d) ~(as,bs,cs,ds) -> (a:as,b:bs,c:cs,d:ds)) ([],[],[],[]) xs+++--	A number of useful monadic combinators:++stateMapM :: (Monad m) => (x -> s -> m (y,s)) -> [x] -> s -> m ([y],s)	-- the monadic version of stateMap+stateMapM f xs s+	= ssequence (map f xs) s++foldrM :: (Monad m) => (x -> s -> m s) -> s -> [x] -> m s		-- the monadic version of stateMap2+foldrM _ s []     = return s+foldrM f s (x:xs) = f x s >>= (\s -> foldrM f s xs)+++sequenceMap :: (Monad m) => (x -> m a) -> [x] -> m [a]			-- frequently occurring combination+sequenceMap f xs = sequence (map f xs)++ssequence :: (Monad m) => [s -> m (a,s)] -> s -> m ([a],s)		-- state version of sequence+ssequence (m:ms) s+	= do {+		(a, s1) <- m s;+		(as,s2) <- ssequence ms s1;+		return (a:as,s2)+	  }+ssequence [] s+	= return ([],s)+	+	+--	gather collects all first elements that belong to the same second element.++gather :: Eq b => [(a,b)] -> [([a],b)]+gather ((d,x):xs) = ((d:ds),x) : gather xs'+	where+		(ds,xs') = gatherElements x xs++		gatherElements :: Eq b => b -> [(a,b)] -> ([a],[(a,b)])+		gatherElements x ((d,x'):xs)+			| x==x'	    = (d:ds,xs')+			| otherwise = (ds,(d,x'):xs')+			where+				(ds,xs')	= gatherElements x xs+		gatherElements _ [] = ([],[])+gather [] = []+++fst3snd3 :: (a,b,c) -> (a,b)+fst3snd3 (t1,t2,_ ) = (t1,t2)++fst3thd3 :: (a,b,c) -> (a,c)+fst3thd3 (t1,_ ,t3) = (t1,t3)++snd3thd3 :: (a,b,c) -> (b,c)+snd3thd3 (_ ,t2,t3) = (t2,t3)++eqfst2id :: Eq a => a -> (a,b) -> Bool+eqfst2id id1 (id2,_)	= id1==id2++eqfst3id :: Eq a => a -> (a,b,c) -> Bool+eqfst3id id1 (id2,_,_)	= id1==id2
+ Graphics/UI/ObjectIO/Control/Access.hs view
@@ -0,0 +1,437 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Access+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Control.Access contains all read functions on controls.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Control.Access+		( getcontrolslayouts, getcontrolsviewsizes+		, getcontrolsoutersizes, getcontrolsselects+	      	, getcontrolsshowstates, getcontrolstexts+	      	, getcontrolsnrlines, getcontrolslooks+	      	, getcontrolsminsizes, getcontrolsresizes+	      	, getcontrolitems, getcontrolsselections+	      	, getcontrolsmarks+	      	, getslidersdirections, getslidersstates+	      	, getcontrolsframes, getcontrolsdomains+	      	, getscrollfunctions+	      	) where		     +++import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.StdIOCommon as C+import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.StdControlAttribute+import Graphics.UI.ObjectIO.Window.Access+import Graphics.UI.ObjectIO.OS.Window(OSWindowMetrics, osGetEditControlText, osScrollbarsAreVisible, osGetCompoundContentRect)+++{-	Higher order access on [WElementHandle ls ps].+	Although statemapWElementHandles has (... WElementHandle ls ps ...) function arguments,+	these will only be applied to WItemHandle alternatives.+-}++type MapFunction ps x = forall ls . WElementHandle ls ps -> x -> IO (WElementHandle ls ps, x)++statemapWElementHandles :: MapFunction ps x -> [Id] -> [WElementHandle ls ps] -> x -> IO ([Id], [WElementHandle ls ps], x)+statemapWElementHandles f ids [] s = return (ids, [], s)+statemapWElementHandles f ids (itemH:itemHs) s+	| null ids      = return (ids, (itemH:itemHs), s)+	| otherwise   = do+		(ids, itemH,  s) <- statemapWElementHandle  f ids itemH  s+		(ids, itemHs, s) <- statemapWElementHandles f ids itemHs s+		return (ids, itemH:itemHs, s)+	where+		statemapWElementHandle :: MapFunction ps x -> [Id] -> WElementHandle ls ps -> x -> IO ([Id], WElementHandle ls ps, x)+		statemapWElementHandle f ids (WListLSHandle itemHs) s = do+			(ids, itemHs, s) <- statemapWElementHandles f ids itemHs s+			return (ids, WListLSHandle itemHs, s)+		statemapWElementHandle f ids (WChangeLSHandle chLS itemHs) s = do+			(ids, itemHs, s) <- statemapWElementHandles f ids itemHs s+			return (ids, WChangeLSHandle chLS itemHs, s)+		statemapWElementHandle f ids (WExtendLSHandle exLS itemHs) s = do+			(ids, itemHs, s) <- statemapWElementHandles f ids itemHs s+			return (ids, WExtendLSHandle exLS itemHs, s)+		statemapWElementHandle f ids itemH s = do+			(ids, itemH, s) <- statemapWElementHandle' f ids itemH s+			(if isRecursiveControl (wItemKind itemH)+			 then do+				(ids, itemHs, s) <- statemapWElementHandles f ids (wItems itemH) s+				return (ids, itemH{wItems=itemHs}, s)+			 else return (ids, itemH, s))+			where+				statemapWElementHandle' :: MapFunction ps x -> [Id] -> WElementHandle ls ps -> x -> IO ([Id], WElementHandle ls ps, x)+				statemapWElementHandle' f ids itemH@(WItemHandle {wItemId=wItemId}) s+					| isNothing wItemId = return (ids, itemH, s)+					| not hadId			= return (ids, itemH, s)+					| otherwise			= do+						(itemH, s) <- f itemH s+						return (ids1, itemH, s)+					where				+						itemId			= fromJust wItemId+						(hadId,ids1)	= removeCheck itemId ids+++--	Access operations on WElementHandle.++getcontrolslayouts :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,(Maybe ItemPos,Vector2))] -> IO (WindowHandle ls ps, [(Id,Bool,(Maybe ItemPos,Vector2))])+getcontrolslayouts ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) layouts = do+	(ids, itemHs, layouts) <- statemapWElementHandles getlayouts ids itemHs layouts+	return (wH{whItems=itemHs}, layouts)+	where+		getlayouts :: WElementHandle ls ps -> [(Id,Bool,(Maybe ItemPos,Vector2))] -> IO (WElementHandle ls ps, [(Id,Bool,(Maybe ItemPos,Vector2))])+		getlayouts itemH@(WItemHandle {wItemAtts=atts,wItemPos=wItemPos}) layouts =+			return (itemH, layouts1)+			where+				itemPos			= if hasAtt then Just (getControlPosAtt posAtt) else Nothing+				(hasAtt,posAtt)	= cselect isControlPos (ControlPos (C.Left,zero)) atts+				layout			= (itemId,True,(itemPos,toVector wItemPos))+				(_,layouts1)	= creplace (eqfst3id itemId) layout layouts+				itemId          = fromJust (wItemId itemH)++getcontrolsviewsizes :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Size)] -> IO (WindowHandle ls ps , [(Id,Bool,Size)])+getcontrolsviewsizes ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) sizes = do+		(ids, itemHs, sizes) <- statemapWElementHandles (getsizes wMetrics) ids itemHs sizes+		return (wH{whItems=itemHs}, sizes)+		where+			getsizes :: OSWindowMetrics -> WElementHandle ls ps -> [(Id,Bool,Size)] -> IO (WElementHandle ls ps, [(Id,Bool,Size)])+			getsizes wMetrics itemH@(WItemHandle {wItemKind=wItemKind}) sizes =+				return (itemH, sizes1)+				where+					itemSize		= wItemSize itemH+					info			= getWItemCompoundInfo (wItemInfo itemH)+					(domainRect,hasScrolls)+									= (compoundDomain info,(isJust (compoundHScroll info),isJust (compoundVScroll info)))+					visScrolls		= osScrollbarsAreVisible wMetrics domainRect (toTuple itemSize) hasScrolls+					size			= if (wItemKind/=IsCompoundControl)+ 									  then itemSize+									  else rectSize (getCompoundContentRect wMetrics visScrolls (sizeToRect itemSize))+					(_,sizes1)		= creplace (eqfst3id itemId) (itemId,True,size) sizes+					itemId          = fromJust (wItemId itemH)++getcontrolsoutersizes :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Size)] -> IO (WindowHandle ls ps , [(Id,Bool,Size)])+getcontrolsoutersizes ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) sizes = do+	(ids, itemHs, sizes) <- statemapWElementHandles (getsizes wMetrics) ids itemHs sizes+	return (wH{whItems=itemHs}, sizes)+	where+		getsizes :: OSWindowMetrics -> WElementHandle ls ps -> [(Id,Bool,Size)] -> IO (WElementHandle ls ps, [(Id,Bool,Size)])+		getsizes wMetrics itemH@(WItemHandle {}) sizes =+			return (itemH, sizes1)+			where+				size			= wItemSize itemH+				(_,sizes1)		= creplace (eqfst3id itemId) (itemId,True,size) sizes+				itemId          = fromJust (wItemId itemH)++getcontrolsselects :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,SelectState)] -> IO (WindowHandle ls ps , [(Id,Bool,SelectState)])+getcontrolsselects ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) selects = do+	(ids, itemHs, selects) <- statemapWElementHandles getselects ids itemHs selects+	return (wH{whItems=itemHs}, selects)+	where+		getselects :: WElementHandle ls ps -> [(Id,Bool,SelectState)] -> IO (WElementHandle ls ps, [(Id,Bool,SelectState)])+		getselects itemH@(WItemHandle {wItemSelect=wItemSelect}) selects =+			return (itemH, selects1)+			where+				selectstate		= if wItemSelect then Able else Unable+				select			= (itemId,True,selectstate)+				(_,selects1)	= creplace (eqfst3id itemId) select selects+				itemId          = fromJust (wItemId itemH)+				++getcontrolsshowstates :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Bool)] -> IO (WindowHandle ls ps, [(Id,Bool,Bool)])+getcontrolsshowstates ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) shows = do+	(ids, itemHs, shows) <- statemapWElementHandles getshowstates ids itemHs shows+	return (wH{whItems=itemHs}, shows)+	where+		getshowstates :: WElementHandle ls ps -> [(Id,Bool,Bool)] -> IO (WElementHandle ls ps, [(Id,Bool,Bool)])+		getshowstates itemH@(WItemHandle {wItemShow=wItemShow}) shows =+			return (itemH, shows1)+			where+				show			= (itemId,True,wItemShow)+				(_,shows1)		= creplace (eqfst3id itemId) show shows+				itemId          = fromJust (wItemId itemH)++getcontrolstexts :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Maybe String)] -> IO (WindowHandle ls ps, [(Id,Bool,Maybe String)])+getcontrolstexts ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) texts = do+	(ids, itemHs, texts) <- statemapWElementHandles gettext ids itemHs texts+	return (wH{whItems=itemHs}, texts)+	where+		gettext :: WElementHandle ls ps -> [(Id,Bool,Maybe String)] -> IO (WElementHandle ls ps, [(Id,Bool,Maybe String)])+		gettext itemH@(WItemHandle {}) texts =			+			case wItemKind itemH of+					IsPopUpControl  -> do+							(textline, popUpInfo) <- getPopUpText (getWItemPopUpInfo  info)+							return (itemH{wItemInfo=WPopUpInfo popUpInfo}, snd (creplace (eqfst3id itemId) (itemId,True,Just textline) texts))+					IsTextControl  -> do+							let textline = textInfoText   (getWItemTextInfo   info)+							return (itemH, snd (creplace (eqfst3id itemId) (itemId,True,Just textline) texts))+					IsEditControl  -> do+							textline <- osGetEditControlText (wPtr wids) (wItemPtr itemH)+							return (itemH{wItemInfo=WEditInfo ((getWItemEditInfo info){editInfoText=textline})}, snd (creplace (eqfst3id itemId) (itemId,True,Just textline) texts))+					IsButtonControl -> do+							let textline = buttonInfoText (getWItemButtonInfo info)+							return (itemH, snd (creplace (eqfst3id itemId) (itemId,True,Just textline) texts))+					_ -> return (itemH, texts)+			where+				info                 = wItemInfo itemH+				itemId               = fromJust (wItemId itemH)+				+				getPopUpText :: PopUpInfo ls ps -> IO (String, PopUpInfo ls ps)+				getPopUpText popUpInfo@(PopUpInfo {popUpInfoEdit=popUpInfoEdit,popUpInfoItems=popUpInfoItems}) =+					case popUpInfoEdit of+						Nothing -> +							if null popUpInfoItems+							then return ("", popUpInfo)+							else return (fst (popUpInfoItems!!(max 0 (popUpInfoIndex popUpInfo - 1))), popUpInfo)+						Just info -> do+							content <- osGetEditControlText (wItemPtr itemH) (popUpEditPtr info)+							return (content, popUpInfo{popUpInfoEdit=Just (info{popUpEditText=content})})+++getcontrolsnrlines :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Maybe Int)] -> IO (WindowHandle ls ps,[(Id,Bool,Maybe Int)])+getcontrolsnrlines ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) nrlines = do+	(ids, itemHs, nrlines) <- statemapWElementHandles getnrlines ids itemHs nrlines+	return (wH{whItems=itemHs}, nrlines)+	where+		getnrlines :: WElementHandle ls ps -> [(Id,Bool,Maybe Int)] -> IO (WElementHandle ls ps,[(Id,Bool,Maybe Int)])+		getnrlines itemH@(WItemHandle {wItemKind=itemKind}) nrlines+			| itemKind /= IsEditControl = return (itemH,nrlines)+			| otherwise		    = return (itemH,nrlines1)+			where+				info	= getWItemEditInfo (wItemInfo itemH)+				itemId  = fromJust (wItemId itemH)+				nrline	= (itemId,True,Just (editInfoNrLines info))+				(_,nrlines1) = creplace (eqfst3id itemId) nrline nrlines+++getcontrolslooks :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Maybe (Bool,Look))] -> IO (WindowHandle ls ps, [(Id,Bool,Maybe (Bool,Look))])+getcontrolslooks ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) looks = do+	(ids, itemHs, looks) <- statemapWElementHandles getlooks ids itemHs looks+	return (wH{whItems=itemHs}, looks)+	where+		getlooks :: WElementHandle ls ps -> [(Id,Bool,Maybe (Bool,Look))] -> IO (WElementHandle ls ps, [(Id,Bool,Maybe (Bool,Look))])+		getlooks itemH@(WItemHandle {wItemKind=itemKind,wItemInfo=info}) looks+			| not haslook	= return (itemH, looks )+			| otherwise	= return (itemH, looks1)+			where+				itemId			= fromJust (wItemId itemH)+				(haslook,lookInfo)	= getLookInfo itemKind info+				look 			= Just (lookSysUpdate lookInfo,lookFun lookInfo)+				(_,looks1)		= creplace (eqfst3id itemId) (itemId,True,look) looks++				getLookInfo :: ControlKind -> WItemInfo ls ps -> (Bool,LookInfo)+				getLookInfo IsCustomButtonControl info =+					(True,cButtonInfoLook (getWItemCustomButtonInfo info))+				getLookInfo IsCustomControl info =+					(True,customInfoLook (getWItemCustomInfo info))+				getLookInfo IsCompoundControl info =+					(True,compoundLook (compoundLookInfo (getWItemCompoundInfo info)))+				getLookInfo _ _ = (False,undefined)+++getcontrolsminsizes :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Maybe Size)] -> IO (WindowHandle ls ps,[(Id,Bool,Maybe Size)])+getcontrolsminsizes ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) sizes = do+	(ids, itemHs, sizes) <- statemapWElementHandles getsizes ids itemHs sizes+	return (wH{whItems=itemHs}, sizes)+	where+		getsizes :: WElementHandle ls ps -> [(Id,Bool,Maybe Size)] -> IO (WElementHandle ls ps, [(Id,Bool,Maybe Size)])+		getsizes itemH@(WItemHandle {wItemAtts=atts,wItems=itemHs}) sizes = return (itemH, sizes1)+			where+				itemId		     = fromJust (wItemId itemH)+				(has_minsize,minatt) = cselect isControlMinimumSize (dummy "getcontrolsminsizes") atts+				size		     = (itemId,True,if has_minsize then (Just (getControlMinimumSizeAtt minatt)) else Nothing)+				(_,sizes1)	     = creplace (eqfst3id itemId) size sizes+++getcontrolsresizes :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Maybe ControlResizeFunction)] -> IO (WindowHandle ls ps,[(Id,Bool,Maybe ControlResizeFunction)])+getcontrolsresizes ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) resizes = do+	(ids, itemHs, resizes) <- statemapWElementHandles getresizes ids itemHs resizes+	return (wH{whItems=itemHs}, resizes)+	where+		getresizes :: WElementHandle ls ps -> [(Id,Bool,Maybe ControlResizeFunction)] -> IO (WElementHandle ls ps, [(Id,Bool,Maybe ControlResizeFunction)])+		getresizes itemH@(WItemHandle {wItemAtts=atts,wItems=itemHs}) resizes+			| not hasResize		= return (itemH, resizes )+			| otherwise		= return (itemH, resizes1)+			where+				itemId			= fromJust (wItemId itemH)+				resize			= (itemId,True,Just (getControlResizeFun resizeAtt))+				(_,resizes1)    	= creplace (eqfst3id itemId) resize resizes+				(hasResize,resizeAtt)	= cselect isControlResize (dummy "getresizes") atts+++getcontrolitems :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Maybe [String])] -> IO (WindowHandle ls ps, [(Id,Bool,Maybe [String])])+getcontrolitems ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) titles = do+	(ids, itemHs, titles) <- statemapWElementHandles gettitle ids itemHs titles+	return (wH{whItems=itemHs}, titles)+	where+		gettitle :: WElementHandle ls ps -> [(Id,Bool,Maybe [String])] -> IO (WElementHandle ls ps, [(Id,Bool,Maybe [String])])+		gettitle itemH@(WItemHandle {wItemKind=itemKind,wItemInfo=info}) titles			+			| Just title <- mb_title = +				let (_,titles1)	= creplace (eqfst3id itemId) title titles+				in return (itemH, titles1)+			| otherwise		 = return (itemH, titles)+			where+				fst3 (a,b,c)	= a+				fst4 (a,b,c,d)	= a+				itemId		= fromJust (wItemId itemH)+				mb_title 	= case itemKind of+					IsPopUpControl	-> Just (itemId,True,Just (map fst  (popUpInfoItems (getWItemPopUpInfo info))))+					IsListBoxControl-> Just (itemId,True,Just (map fst3 (listBoxInfoItems (getWItemListBoxInfo info))))+					IsRadioControl	-> Just (itemId,True,Just [fst3 (radioItem item) | item<-radioItems (getWItemRadioInfo info)])+					IsCheckControl	-> Just (itemId,True,Just [fst4 (checkItem item) | item<-checkItems (getWItemCheckInfo info)])+					_		-> Nothing+					+getcontrolsselections :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Maybe Index)] -> IO (WindowHandle ls ps, [(Id,Bool,Maybe Index)])+getcontrolsselections ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) marks = do+	(ids, itemHs, marks) <- statemapWElementHandles getselection ids itemHs marks+	return (wH{whItems=itemHs}, marks)+	where+		getselection :: WElementHandle ls ps -> [(Id,Bool,Maybe Index)] -> IO (WElementHandle ls ps, [(Id,Bool,Maybe Index)])+		getselection itemH@(WItemHandle {wItemKind=itemKind,wItemInfo=info}) indices+			| Just index <- mb_index =+				let (_,indices1) = creplace (eqfst3id itemId) index indices+				in return (itemH,indices1)+			| otherwise 	  = return (itemH,indices)+			where+				itemId		= fromJust (wItemId itemH)+				mb_index = case itemKind of+					IsRadioControl  -> Just (itemId,True,Just (radioIndex (getWItemRadioInfo info)))+					IsPopUpControl  -> Just (itemId,True,Just (popUpInfoIndex (getWItemPopUpInfo info)))+					IsListBoxControl-> Just (itemId,True,Just (findSelIndex 1 (listBoxInfoItems (getWItemListBoxInfo info))))+					_	        -> Nothing+					+				findSelIndex n [] = 0+				findSelIndex n ((title,mark,f):items)+					| marked mark = n+					| otherwise   = findSelIndex (n+1) items+				+				+getcontrolsmarks :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Maybe [Index])] -> IO (WindowHandle ls ps, [(Id,Bool,Maybe [Index])])+getcontrolsmarks ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) marks = do+	(ids, itemHs, marks) <- statemapWElementHandles getmarks ids itemHs marks+	return (wH{whItems=itemHs}, marks)+	where+		getmarks :: WElementHandle ls ps -> [(Id,Bool,Maybe [Index])] -> IO (WElementHandle ls ps, [(Id,Bool,Maybe [Index])])+		getmarks itemH@(WItemHandle {wItemKind=IsCheckControl,wItemInfo=info}) marks = return (itemH,marks1)+			where+				itemId		= fromJust (wItemId itemH)+				indices		= getMarkIndices 1 (checkItems (getWItemCheckInfo info))+				mark		= (itemId,True,Just indices)+				(_,marks1)	= creplace (eqfst3id itemId) mark marks++				getMarkIndices :: Index -> [CheckItemInfo ls ps] -> [Index]+				getMarkIndices index (CheckItemInfo {checkItem=(_,_,mark,_)}:items) =+					let+						indexs	= getMarkIndices (index+1) items+					in+						if marked mark then index:indexs+						else indexs+				getMarkIndices _ _ = []+		getmarks itemH@(WItemHandle {wItemKind=IsListBoxControl,wItemInfo=info}) marks = return (itemH,marks1)+			where+				itemId		= fromJust (wItemId itemH)+				indices		= getIndices 1 (listBoxInfoItems (getWItemListBoxInfo info))+				mark		= (itemId,True,Just indices)+				(_,marks1)	= creplace (eqfst3id itemId) mark marks++				getIndices :: Index -> [ListBoxControlItem ls ps] -> [Index]+				getIndices index ((_,mark,_):items) =+					let+						indices	= getIndices (index+1) items+					in+						if marked mark then index:indices+						else indices+				getIndices _ _ = []+		getmarks itemH marks = return (itemH,marks)+++getslidersdirections :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Maybe Direction)] -> IO (WindowHandle ls ps,[(Id,Bool,Maybe Direction)])+getslidersdirections ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) sliders = do+	(ids, itemHs, sliders) <- statemapWElementHandles getdirections ids itemHs sliders+	return (wH{whItems=itemHs}, sliders)+	where+		getdirections :: WElementHandle ls ps -> [(Id,Bool,Maybe Direction)] -> IO (WElementHandle ls ps, [(Id,Bool,Maybe Direction)])+		getdirections itemH@(WItemHandle {wItemKind=itemKind,wItemInfo=info}) sliders+			| itemKind /= IsSliderControl	= return (itemH,sliders )+			| otherwise			= return (itemH,sliders1)+			where+				itemId		= fromJust (wItemId itemH)+				slider		= (itemId,True,Just (sliderInfoDir (getWItemSliderInfo info)))+				(_,sliders1)	= creplace (eqfst3id itemId) slider sliders+		++getslidersstates :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Maybe SliderState)] -> IO (WindowHandle ls ps,[(Id,Bool,Maybe SliderState)])+getslidersstates ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) states = do+	(ids, itemHs, states) <- statemapWElementHandles getstates ids itemHs states+	return (wH{whItems=itemHs}, states)+	where+		getstates :: WElementHandle ls ps -> [(Id,Bool,Maybe SliderState)] -> IO (WElementHandle ls ps, [(Id,Bool,Maybe SliderState)])+		getstates itemH@(WItemHandle {wItemKind=itemKind,wItemInfo=info}) states+			| itemKind /= IsSliderControl	= return (itemH,states )+			| otherwise			= return (itemH,states1)+			where+				itemId		= fromJust (wItemId itemH)+				state		= (itemId,True,Just (sliderInfoState (getWItemSliderInfo info)))+				(_,states1)	= creplace (eqfst3id itemId) state states+++getcontrolsframes :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Maybe ViewFrame)] -> IO (WindowHandle ls ps,[(Id,Bool,Maybe ViewFrame)])+getcontrolsframes ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) frames = do+	(ids, itemHs, frames) <- statemapWElementHandles getframes ids itemHs frames+	return (wH{whItems=itemHs}, frames)+	where+		getframes :: WElementHandle ls ps -> [(Id,Bool,Maybe ViewFrame)] -> IO (WElementHandle ls ps, [(Id,Bool,Maybe ViewFrame)])+		getframes itemH@(WItemHandle {wItemKind=itemKind,wItemSize=itemSize,wItemInfo=wItemInfo}) frames+			| itemKind /= IsCompoundControl	= return (itemH,frames )+			| otherwise			= return (itemH,frames1)+			where+				itemId		= fromJust (wItemId itemH)+				info		= getWItemCompoundInfo wItemInfo+				(origin,domainRect,hasScrolls) = (compoundOrigin info,compoundDomain info,(isJust (compoundHScroll info),isJust (compoundVScroll info)))+				visScrolls	= osScrollbarsAreVisible wMetrics domainRect (toTuple itemSize) hasScrolls+				itemRect	= osGetCompoundContentRect wMetrics visScrolls (posSizeToRect origin itemSize)+				frame		= (itemId,True,Just (rectToRectangle itemRect))+				(_,frames1)	= creplace (eqfst3id itemId) frame frames+		++getcontrolsdomains :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Maybe ViewDomain)] -> IO (WindowHandle ls ps,[(Id,Bool,Maybe ViewDomain)])+getcontrolsdomains ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) domains = do+	(ids, itemHs, domains) <- statemapWElementHandles getdomains ids itemHs domains+	return (wH{whItems=itemHs}, domains)+	where+		getdomains :: WElementHandle ls ps -> [(Id,Bool,Maybe ViewDomain)] -> IO (WElementHandle ls ps, [(Id,Bool,Maybe ViewDomain)])+		getdomains itemH@(WItemHandle {wItemKind=itemKind,wItemInfo=info}) domains+			| itemKind /= IsCompoundControl	= return (itemH,domains )+			| otherwise			= return (itemH,domains1)+			where+				itemId		= fromJust (wItemId itemH)+				domain		= (itemId,True,Just (rectToRectangle (compoundDomain (getWItemCompoundInfo info))))+				(_,domains1) 	= creplace (eqfst3id itemId) domain domains+++getscrollfunctions :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> [(Id,Bool,Maybe ((Direction,Maybe ScrollFunction),(Direction,Maybe ScrollFunction)))] -> IO (WindowHandle ls ps,[(Id,Bool,Maybe ((Direction,Maybe ScrollFunction),(Direction,Maybe ScrollFunction)))])+getscrollfunctions ids wMetrics wids wH@(WindowHandle {whItems=itemHs}) funcs = do+	(ids, itemHs, funcs) <- statemapWElementHandles getfuncs ids itemHs funcs+	return (wH{whItems=itemHs}, funcs)+	where+		getfuncs :: WElementHandle ls ps -> [(Id,Bool,Maybe ((Direction,Maybe ScrollFunction),(Direction,Maybe ScrollFunction)))] -> IO (WElementHandle ls ps, [(Id,Bool,Maybe ((Direction,Maybe ScrollFunction),(Direction,Maybe ScrollFunction)))])+		getfuncs itemH@(WItemHandle {wItemKind=itemKind,wItemInfo=wItemInfo}) funcs+			| itemKind /= IsCompoundControl = return (itemH,funcs )+			| otherwise			= return (itemH,funcs1)+			where+				itemId		= fromJust (wItemId itemH)+				info		= getWItemCompoundInfo wItemInfo+				hScroll		= compoundHScroll info+				vScroll		= compoundVScroll info+				func		= (itemId,True,Just ((Horizontal,fmap scrollFunction hScroll)+								    ,(Vertical,  fmap scrollFunction vScroll)+								    ))+				(_,funcs1)	= creplace (eqfst3id itemId) func funcs
+ Graphics/UI/ObjectIO/Control/Create.hs view
@@ -0,0 +1,324 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Create+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Control.Create contains all control creation functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Control.Create ( createControls, createCompoundControls ) where++++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.StdControlAttribute+import Graphics.UI.ObjectIO.Control.Layout+import Graphics.UI.ObjectIO.Control.Validate+import Graphics.UI.ObjectIO.Window.Access+import Graphics.UI.ObjectIO.OS.Window+import Graphics.UI.ObjectIO.OS.ToolTip(osAddControlToolTip)++++{-	createControls generates the proper system resources for all given WElementHandles of the window.+-}+createControls :: OSWindowMetrics -> Maybe Id -> Maybe Id -> Bool -> OSWindowPtr -> [WElementHandle ls ps]+                                                                              -> IO [WElementHandle ls ps]+createControls wMetrics okId cancelId ableContext wPtr itemHs+	= sequenceMap (createWElementHandle wMetrics okId cancelId True ableContext zero wPtr) itemHs+++{-	createCompoundControls generates the proper system resources for those controls that are part of the +	CompoundControl with the given Id, skipping its first nr of controls given by the Int argument.+	The WElementHandles must be the complete list of controls of the window.+-}+createCompoundControls :: OSWindowMetrics -> Id -> Int -> Maybe Id -> Maybe Id -> Bool -> OSWindowPtr -> [WElementHandle ls ps] -> IO [WElementHandle ls ps]+createCompoundControls wMetrics compoundId nrSkip okId cancelId ableContext wPtr itemHs =+	mapM (createCompoundWElementHandle wMetrics compoundId nrSkip okId cancelId True ableContext zero wPtr) itemHs+	where+		createCompoundWElementHandle :: OSWindowMetrics -> Id -> Int -> Maybe Id -> Maybe Id -> Bool -> Bool -> Point2 -> OSWindowPtr -> WElementHandle ls ps -> IO (WElementHandle ls ps)+		createCompoundWElementHandle wMetrics compoundId nrSkip okId cancelId showContext ableContext parentPos wPtr itemH@(WItemHandle {wItemKind=itemKind,wItemId=itemId,wItems=itemHs})+			| itemKind /= IsCompoundControl =+				if isRecursiveControl itemKind+				then do+					itemHs <- mapM (createCompoundWElementHandle wMetrics compoundId nrSkip okId cancelId showContext1 ableContext parentPos wPtr) itemHs+					return itemH{wItems=itemHs}+				else return itemH+			| not (identifyMaybeId compoundId itemId) = do+				itemHs <- mapM (createCompoundWElementHandle wMetrics compoundId nrSkip okId cancelId showContext1 ableContext1 itemPos itemPtr) itemHs+				return itemH{wItems=itemHs}+			| otherwise = do+				let (oldItems,newItems)	= split nrSkip itemHs+				newItems <- mapM (createWElementHandle wMetrics okId cancelId showContext1 ableContext1 itemPos itemPtr) newItems+				osInvalidateCompound itemPtr+				return itemH{wItems=oldItems++newItems}+			where+				showContext1	= showContext && wItemShow   itemH+				ableContext1	= ableContext && wItemSelect itemH+				itemPos		= wItemPos itemH+				itemPtr		= wItemPtr itemH++		createCompoundWElementHandle wMetrics compoundId nrSkip okId cancelId showContext ableContext parentPos wPtr (WListLSHandle itemHs) = do+			itemHs <- mapM (createCompoundWElementHandle wMetrics compoundId nrSkip okId cancelId showContext ableContext parentPos wPtr) itemHs+			return (WListLSHandle itemHs)++		createCompoundWElementHandle wMetrics compoundId nrSkip okId cancelId showContext ableContext parentPos wPtr (WExtendLSHandle exLS itemHs) = do+			itemHs <- mapM (createCompoundWElementHandle wMetrics compoundId nrSkip okId cancelId showContext ableContext parentPos wPtr) itemHs+			return (WExtendLSHandle exLS itemHs)++		createCompoundWElementHandle wMetrics compoundId nrSkip okId cancelId showContext ableContext parentPos wPtr (WChangeLSHandle chLS itemHs) = do+			itemHs <- mapM (createCompoundWElementHandle wMetrics compoundId nrSkip okId cancelId showContext ableContext parentPos wPtr) itemHs+			return (WChangeLSHandle chLS itemHs)+		++{-	toOKorCANCEL okId cancelId controlId+		checks if the optional Id of a control (controlId) is the OK control (OK), the CANCEL control (CANCEL), or a normal button (NORMAL).+-}+toOKorCANCEL :: Maybe Id -> Maybe Id -> Maybe Id -> OKorCANCEL+toOKorCANCEL okId cancelId maybeControlId+	= case maybeControlId of+		Just id -> if      isJust okId     && fromJust okId    ==id then OK+		           else if isJust cancelId && fromJust cancelId==id then CANCEL+		                                                            else NORMAL+		nothing -> NORMAL+++{-	createWElementHandle generates the proper system resources.+-}+createWElementHandle :: OSWindowMetrics -> Maybe Id -> Maybe Id -> Bool -> Bool -> Point2 -> OSWindowPtr -> WElementHandle ls ps+                                                                                                     -> IO (WElementHandle ls ps)++createWElementHandle wMetrics okId cancelId showContext ableContext parentPos wPtr (WListLSHandle itemHs)+	= do {	itemHs1 <- sequenceMap (createWElementHandle wMetrics okId cancelId showContext ableContext parentPos wPtr) itemHs;+	  	return (WListLSHandle itemHs1)+	  }++createWElementHandle wMetrics okId cancelId showContext ableContext parentPos wPtr (WExtendLSHandle addLS itemHs)+	= do {	itemHs1 <- sequenceMap (createWElementHandle wMetrics okId cancelId showContext ableContext parentPos wPtr) itemHs;+		return (WExtendLSHandle addLS itemHs1)+	  }++createWElementHandle wMetrics okId cancelId showContext ableContext parentPos wPtr (WChangeLSHandle newLS itemHs)+	= do {	itemHs1 <- sequenceMap (createWElementHandle wMetrics okId cancelId showContext ableContext parentPos wPtr) itemHs;+	  	return (WChangeLSHandle newLS itemHs1)+	  }++createWElementHandle wMetrics okId cancelId showContext ableContext parentPos wPtr itemH@(WItemHandle {wItemKind=wItemKind})+	| wItemKind==IsRadioControl+		= let+			radioInfo = getWItemRadioInfo (wItemInfo itemH)++			createRadioItem :: Bool -> Bool -> (Int,Int) -> OSWindowPtr -> Index -> RadioItemInfo ls ps -> Index+											 -> IO (RadioItemInfo ls ps,   Index)+			createRadioItem show able parentPos wPtr index item@(RadioItemInfo {radioItem=(title,_,_),radioItemPos=pos,radioItemSize=size}) itemNr+				= do {+					radioPtr <- osCreateRadioControl wPtr parentPos title show able (toTuple pos) (toTuple size) (index==itemNr) (itemNr==1);+					let itemH1 = item {radioItemPtr=radioPtr}+					in  if   hasTip+					    then osAddControlToolTip wPtr radioPtr tip >> return (itemH1,itemNr+1)+					    else return (itemH1,itemNr+1)+		  		}+		  in+			do {+				(items,_) <- stateMapM (createRadioItem show able (toTuple parentPos) wPtr (radioIndex radioInfo)) (radioItems radioInfo) 1;+				return itemH {wItemInfo=WRadioInfo (radioInfo{radioItems=items})}+		  	}++	| wItemKind==IsCheckControl+ 		= let+ 			checkInfo = getWItemCheckInfo (wItemInfo itemH)++			createCheckItem :: Bool -> Bool -> (Int,Int) -> OSWindowPtr -> CheckItemInfo ls ps -> Index+					                                                        -> IO (CheckItemInfo ls ps,   Index)+			createCheckItem show able parentPos wPtr item@(CheckItemInfo {checkItem=(title,_,mark,_),checkItemPos=pos,checkItemSize=size}) itemNr+				= do {+					checkPtr <- osCreateCheckControl wPtr parentPos title show able (toTuple pos) (toTuple size) (marked mark) (itemNr==1);+					let itemH1 = item {checkItemPtr=checkPtr}+					in  if   hasTip+					    then osAddControlToolTip wPtr checkPtr tip >> return (itemH1,itemNr+1)+					    else return (itemH1,itemNr+1)+		  		}+		  in+ 			do {+				(items,n) <- stateMapM (createCheckItem show able (toTuple parentPos) wPtr) (checkItems checkInfo) 1;+				return itemH {wItemInfo=WCheckInfo (checkInfo{checkItems=items})}+		  	}+++	| wItemKind==IsPopUpControl+		= let+			info            = getWItemPopUpInfo (wItemInfo itemH)+			items           = popUpInfoItems info+			isEditable      = any isControlKeyboard atts++			appendPopUp :: OSWindowPtr -> Index -> PopUpControlItem ps (ls,ps) -> Int -> IO Int+			appendPopUp popUpPtr index (title,_) itemNr+				= osAddPopUpControlItem popUpPtr title (index==itemNr) >> return (itemNr+1)+		  in+			do {+				(popUpPtr,editPtr) <- osCreateEmptyPopUpControl wPtr (toTuple parentPos) show able pos' size' (length items) isEditable;+				foldrM (appendPopUp popUpPtr (popUpInfoIndex info)) 1 items;+				let info1  = if isEditable then info {popUpInfoEdit=Just (PopUpEditInfo{popUpEditText="",popUpEditPtr=editPtr})} else info+			    	    itemH1 = itemH {wItemPtr=popUpPtr, wItemInfo=WPopUpInfo info1}+				in  if   hasTip+				then osAddControlToolTip wPtr popUpPtr tip >> return itemH1+			    	else return itemH1+			}+	| wItemKind==IsListBoxControl+		= let+			info            = getWItemListBoxInfo (wItemInfo itemH)+			items           = listBoxInfoItems info++			appendListBox :: OSWindowPtr -> ListBoxControlItem ps (ls,ps) -> IO ()+			appendListBox listBoxPtr (title,isMarked,_)+				= osAddListBoxControlItem listBoxPtr title (isMarked==Mark) >> return ()+		  in+			do {+				listBoxPtr <- osCreateEmptyListBoxControl wPtr (toTuple parentPos) show able pos' size' (listBoxInfoMultiSel info);+				mapM_ (appendListBox listBoxPtr) items;+				let itemH1 = itemH {wItemPtr=listBoxPtr, wItemInfo=WListBoxInfo info}+				in  if   hasTip+				then osAddControlToolTip wPtr listBoxPtr tip >> return itemH1+				else return itemH1+		}++	| wItemKind==IsSliderControl+		= let+			info                              = getWItemSliderInfo (wItemInfo itemH)+			direction                         = sliderInfoDir info+			sliderState                       = sliderInfoState info+			min                               = sliderMin sliderState+			max                               = sliderMax sliderState+			(osMin,osThumb,osMax,osThumbSize) = toOSscrollbarRange (min,sliderThumb sliderState,max) 0+		  in+		  	do {+				sliderPtr <- osCreateSliderControl wPtr (toTuple parentPos) show able (direction==Horizontal) pos' size'+								   (osMin,osThumb,osMax,osThumbSize);+				let itemH1 = itemH {wItemPtr=sliderPtr}+				in  if   hasTip+				    then osAddControlToolTip wPtr sliderPtr tip >> return itemH1+				    else return itemH1+		  	}++	| wItemKind==IsTextControl+		= let	title = textInfoText $ getWItemTextInfo $ wItemInfo itemH+		  in	do {+				textPtr <- osCreateTextControl wPtr (toTuple parentPos) title show pos' size';+				let itemH1 = itemH {wItemPtr=textPtr}+				in  if   hasTip+				    then osAddControlToolTip wPtr textPtr tip >> return itemH1+				    else return itemH1+			}++	| wItemKind==IsEditControl+		= let	keySensitive = any isControlKeyboard atts+			text         = editInfoText $ getWItemEditInfo $ wItemInfo itemH+		  in	do {+				editPtr <- osCreateEditControl wPtr (toTuple parentPos) text show able keySensitive pos' size';+				let itemH1 = itemH {wItemPtr=editPtr}+				in  if   hasTip+				    then osAddControlToolTip wPtr editPtr tip >> return itemH1+				    else return itemH1+			}++	| wItemKind==IsButtonControl+		= let	itemId     = wItemId   itemH+			okOrCancel = toOKorCANCEL okId cancelId itemId+			title      = buttonInfoText $ getWItemButtonInfo $ wItemInfo itemH+		  in	do {+				buttonPtr <- osCreateButtonControl wPtr (toTuple parentPos) title show able pos' size' okOrCancel;+				let itemH1 = itemH {wItemPtr=buttonPtr}+				in  if   hasTip+				    then osAddControlToolTip wPtr buttonPtr tip >> return itemH1+				    else return itemH1+			}++	| wItemKind==IsCustomButtonControl+		= let 	itemId     = wItemId itemH+		      	okOrCancel = toOKorCANCEL okId cancelId itemId+		  in	do {+				buttonPtr <- osCreateCustomButtonControl wPtr (toTuple parentPos) show able pos' size' okOrCancel;+				let itemH1 = itemH {wItemPtr=buttonPtr}+				in  if   hasTip+				    then osAddControlToolTip wPtr buttonPtr tip >> return itemH1+				    else return itemH1+		  	}++	| wItemKind==IsCustomControl+		= do {+			customPtr <- osCreateCustomControl wPtr (toTuple parentPos) show able pos' size';+			let itemH1 = itemH {wItemPtr=customPtr}+			in  if   hasTip+			    then osAddControlToolTip wPtr customPtr tip >> return itemH1+			    else return itemH1+		  }++	| wItemKind==IsCompoundControl =+		let+		      info                    = getWItemCompoundInfo (wItemInfo itemH)+		      domainRect              = compoundDomain info+		      origin                  = compoundOrigin info+		      (hasHScroll,hasVScroll) = (isJust (compoundHScroll info),isJust (compoundVScroll info))+		      visScrolls              = osScrollbarsAreVisible wMetrics domainRect size' (hasHScroll,hasVScroll)+		      (Size {w=w',h=h'})      = rectSize (getCompoundContentRect wMetrics visScrolls (sizeToRect size))++		      hScroll :: ScrollbarInfo+		      hScroll+			      | hasHScroll    = ScrollbarInfo {cbiHasScroll=True, cbiPos=toTuple (scrollItemPos hInfo),cbiSize=toTuple hSize,cbiState=hState}+			      | otherwise     = ScrollbarInfo {cbiHasScroll=False,cbiPos=undefined,cbiSize=undefined,cbiState=undefined}+			      where+				      hInfo   = fromJust (compoundHScroll info)+				      hSize   = scrollItemSize hInfo+				      hState  = toOSscrollbarRange (rleft domainRect,x origin,rright domainRect) w'++		      vScroll :: ScrollbarInfo+		      vScroll+			      | hasVScroll    = ScrollbarInfo {cbiHasScroll=True, cbiPos=toTuple (scrollItemPos vInfo),cbiSize=toTuple vSize,cbiState=vState}+			      | otherwise     = ScrollbarInfo {cbiHasScroll=False,cbiPos=undefined,cbiSize=undefined,cbiState=undefined}+			      where+				      vInfo   = fromJust (compoundVScroll info)+				      vSize   = scrollItemSize vInfo+				      vState  = toOSscrollbarRange (rtop domainRect,y origin,rbottom domainRect) h'++		      setScrollbarPtr :: OSWindowPtr -> ScrollInfo -> ScrollInfo+		      setScrollbarPtr scrollPtr info+				= info {scrollItemPtr=scrollPtr}+		in+		  do {+			(compoundPtr,hPtr,vPtr) <- osCreateCompoundControl wMetrics wPtr (toTuple parentPos) show able False pos' size' hScroll vScroll;+			itemHs                  <- sequenceMap (createWElementHandle wMetrics okId cancelId show able pos compoundPtr) (wItems itemH);+			let compoundInfo = info { compoundHScroll=fmap (setScrollbarPtr hPtr) (compoundHScroll info)+			                        , compoundVScroll=fmap (setScrollbarPtr vPtr) (compoundVScroll info)+			                        }+			    itemH1       = itemH {wItemInfo=WCompoundInfo compoundInfo,wItemPtr=compoundPtr,wItems=itemHs}+			in  if   hasTip+			    then osAddControlToolTip wPtr compoundPtr tip >> return itemH1+			    else return itemH1+		  }+++	| wItemKind==IsLayoutControl+		= do {+			itemHs <- sequenceMap (createWElementHandle wMetrics okId cancelId show able parentPos wPtr) (wItems itemH);+			return itemH{wItems=itemHs}+		  }++	| otherwise+		= return itemH+	where+		show            = showContext && wItemShow   itemH+		able            = ableContext && wItemSelect itemH+		pos             = wItemPos itemH+		size            = wItemSize itemH+		pos'            = toTuple pos+		size'           = toTuple size+		atts            = wItemAtts itemH+		(hasTip,tipAtt) = cselect isControlTip undefined atts+		tip             = getControlTipAtt tipAtt
+ Graphics/UI/ObjectIO/Control/Draw.hs view
@@ -0,0 +1,150 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Draw+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Drawing in customised controls+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Control.Draw where+++import Graphics.UI.ObjectIO.StdPicture(toRegion, accClipPicture)+import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Window.Handle+import Graphics.UI.ObjectIO.Window.Access(getWItemCompoundInfo,  getWItemCustomButtonInfo,  getWItemCustomInfo, getCompoundContentRect)+import Graphics.UI.ObjectIO.OS.Picture(Draw(..), doDraw, pictSetClipRgn)+import Graphics.UI.ObjectIO.OS.Rgn(osNewRectRgn, osDisposeRgn, osSectRgn)+import Graphics.UI.ObjectIO.OS.System(OSWindowMetrics)+import Graphics.UI.ObjectIO.OS.Window(osGrabWindowPictContext, osReleaseWindowPictContext, osScrollbarsAreVisible)+import Graphics.UI.ObjectIO.StdControlAttribute(isControlDoubleBuffered)+++{-	The following functions apply the current Look function of the given control. -}++{-	drawCompoundLook able parentWindow contextClip itemH+		applies the Look function of the compound control given the current selectstate (True iff Able).+		Drawing is clipped inside contextClip (in window coordinates) and the content rectangle of the compound control. +		The function assumes that itemH refers to a CompoundControl(') which ClipState is valid.+	Note that drawCompoundLook draws in the graphics context of the parent window (os(Grab/Release)WindowPictContext).+		This is done because the ClipState of the CompoundControl is given relative to the left-top of the window.+-}+drawCompoundLook :: OSWindowMetrics -> Bool -> OSWindowPtr -> Rect -> WElementHandle ls ps -> IO (WElementHandle ls ps)+drawCompoundLook wMetrics able wPtr contextClip itemH@(WItemHandle {wItemInfo=wItemInfo, wItemAtts=attrs}) = do+    contextRgn <- osNewRectRgn contextClip+    clipRgn <- osSectRgn contextRgn (clipRgn itemClip)+    osPict <- osGrabWindowPictContext wPtr+    (_,_,pen,_) <- doDraw (origin-itemPos) (lookPen itemLook) True clipRgn osPict (any isControlDoubleBuffered attrs) (lookFun itemLook selectState updState)+    osReleaseWindowPictContext wPtr osPict+    mapM_ osDisposeRgn [contextRgn,clipRgn]+    let info1 = info{compoundLookInfo=compLookInfo{compoundLook=itemLook{lookPen=pen}}}+    return (itemH{wItemInfo=WCompoundInfo info1})+    where+	itemPos				= wItemPos itemH+	itemSize			= wItemSize itemH+	info				= getWItemCompoundInfo wItemInfo+	(origin,domainRect,hasScrolls)	= (compoundOrigin info,compoundDomain info,(isJust (compoundHScroll info),isJust (compoundVScroll info)))+	visScrolls			= osScrollbarsAreVisible wMetrics domainRect (toTuple itemSize) hasScrolls+	contentRect			= getCompoundContentRect wMetrics visScrolls (posSizeToRect origin itemSize)+	clipRectangle			= rectToRectangle (addVector (toVector (origin-itemPos)) (intersectRects (addVector (toVector (itemPos-origin)) contentRect) contextClip))+	viewFrame			= rectToRectangle contentRect+	updState			= UpdateState{oldFrame=viewFrame,newFrame=viewFrame,updArea=[clipRectangle]}+	compLookInfo			= compoundLookInfo info+	itemLook			= compoundLook compLookInfo+	itemClip			= compoundClip compLookInfo+	selectState			= if able then Able else Unable+	+{-	drawCustomButtonLook able parentWindow contextClip itemH+		applies the Look function of the custom button control given the current selectstate (True iff Able).+		Drawing is clipped inside contextClip and the content rectangle of the custom button control. +		The function assumes that itemH refers to a custom button control.+-}+drawCustomButtonLook :: Bool -> OSWindowPtr -> Rect -> WElementHandle ls ps -> IO (WElementHandle ls ps)+drawCustomButtonLook able wPtr contextClip itemH@(WItemHandle {wItemPtr=wItemPtr,wItemInfo=wItemInfo,wItemPos=wItemPos,wItemSize=wItemSize,wItemAtts=attrs}) = do+	clipRgn <- osNewRectRgn contextClip+	osPict <- osGrabWindowPictContext wPtr 		-- PA: use window OSPictContext instead of control HDC because of clipstate+	(x,_,pen,_) <- doDraw (zero-wItemPos) (lookPen itemLook) True clipRgn osPict (any isControlDoubleBuffered attrs) (accClipPicture (toRegion clipRectangle) (lookFun itemLook selectState updState))+	osReleaseWindowPictContext wPtr osPict+	osDisposeRgn clipRgn+	return (itemH{wItemInfo=WCustomButtonInfo info{cButtonInfoLook=itemLook{lookPen=pen}}})+	where+		info		= getWItemCustomButtonInfo wItemInfo+		itemLook	= cButtonInfoLook info+		viewFrame	= sizeToRectangle wItemSize+		selectState	= if able then Able else Unable+		clipRectangle	= rectToRectangle (intersectRects (subVector (toVector wItemPos) contextClip) (sizeToRect wItemSize))+		updState	= UpdateState{oldFrame=viewFrame,newFrame=viewFrame,updArea=[clipRectangle]}+++{-	drawCustomLook able parentWindow itemH+		applies the Look function of the custom control given the current selectstate (True iff Able).+		Drawing is clipped inside contextClip and the content rectangle of the custom button control. +		The function assumes that itemH refers to a custom control.+-}+drawCustomLook :: Bool -> OSWindowPtr -> Rect -> WElementHandle ls ps -> IO (WElementHandle ls ps)+drawCustomLook able wPtr contextClip itemH@(WItemHandle {wItemPtr=wItemPtr,wItemInfo=wItemInfo,wItemPos=wItemPos,wItemSize=wItemSize,wItemAtts=attrs}) = do+	clipRgn <- osNewRectRgn contextClip+	osPict <- osGrabWindowPictContext wPtr		-- PA: use window HDC instead of control OSPictContext because of clipstate	+	(x,_,pen,_) <- doDraw (zero-wItemPos) (lookPen itemLook) True clipRgn osPict (any isControlDoubleBuffered attrs) (accClipPicture (toRegion clipRectangle) (lookFun itemLook selectState updState))+	osReleaseWindowPictContext wPtr osPict+	osDisposeRgn clipRgn+	return (itemH{wItemInfo=WCustomInfo info{customInfoLook=itemLook{lookPen=pen}}})+	where+		info		= getWItemCustomInfo wItemInfo+		itemLook	= customInfoLook info+		viewFrame	= sizeToRectangle wItemSize+		selectState	= if able then Able else Unable+		clipRectangle	= rectToRectangle (intersectRects (subVector (toVector wItemPos) contextClip) (sizeToRect wItemSize))+		updState	= UpdateState{oldFrame=viewFrame,newFrame=viewFrame,updArea=[clipRectangle]}+++--	The following functions apply a picture access function to the given control picture.++{-	drawInCompound assumes that the WElementHandle argument refers to a non transparent compound control +	with a valid ClipState.+-}+drawInCompound :: OSWindowPtr -> Draw x -> Rect -> WElementHandle ls ps -> IO (x,WElementHandle ls ps)+drawInCompound wPtr drawfun contextClip itemH@(WItemHandle {wItemPtr=wItemPtr,wItemInfo=wItemInfo,wItemPos=wItemPos,wItemSize=wItemSize,wItemAtts=attrs}) = do+	contextRgn <- osNewRectRgn contextClip+	clipRgn <- osSectRgn contextRgn (clipRgn compoundClip)+	osPict <- osGrabWindowPictContext wPtr 		-- PA: use window OSPictContext instead of control OSPictContext because of clipstate	+	(x,_,pen,_) <- doDraw (origin-wItemPos) (lookPen compoundLook) True clipRgn osPict (any isControlDoubleBuffered attrs) drawfun+	osReleaseWindowPictContext wPtr osPict+	mapM_ osDisposeRgn [contextRgn,clipRgn]+	return (x, itemH{wItemInfo=WCompoundInfo info{compoundLookInfo=cLookInfo{compoundLook=compoundLook{lookPen=pen}}}})+	where+		info		= getWItemCompoundInfo wItemInfo+		origin		= compoundOrigin info+		cLookInfo 	= compoundLookInfo info+		CompoundLookInfo {compoundLook=compoundLook,compoundClip=compoundClip}	= cLookInfo++drawInCustomButton :: OSWindowPtr -> Draw x -> Rect -> WElementHandle ls ps -> IO (x,WElementHandle ls ps)+drawInCustomButton wPtr drawfun contextClip itemH@(WItemHandle {wItemPtr=wItemPtr,wItemInfo=wItemInfo,wItemPos=wItemPos,wItemSize=wItemSize,wItemAtts=attrs}) = do+	clipRgn <- osNewRectRgn contextClip 				-- PA+++: clip also inside contextClip+	osPict <- osGrabWindowPictContext wPtr+	(x,_,pen,_) <- doDraw (zero-wItemPos) (lookPen itemLook) True clipRgn osPict (any isControlDoubleBuffered attrs) (accClipPicture (toRegion (sizeToRectangle wItemSize)) drawfun)+	osReleaseWindowPictContext wPtr osPict+	osDisposeRgn clipRgn						-- PA+++: dispose clipping region+	return (x,itemH{wItemInfo=WCustomButtonInfo info{cButtonInfoLook=itemLook{lookPen=pen}}})+	where+		info		= getWItemCustomButtonInfo wItemInfo+		itemLook	= cButtonInfoLook info++drawInCustom :: OSWindowPtr -> Draw x -> Rect -> WElementHandle ls ps -> IO (x,WElementHandle ls ps)+drawInCustom wPtr drawfun contextClip itemH@(WItemHandle {wItemPtr=wItemPtr,wItemInfo=wItemInfo,wItemPos=wItemPos,wItemSize=wItemSize,wItemAtts=attrs}) = do+	clipRgn <- osNewRectRgn contextClip				-- PA+++: clip also inside contextClip+	osPict <- osGrabWindowPictContext wPtr+	(x,_,pen,_) <- doDraw (zero-wItemPos) (lookPen itemLook) True clipRgn osPict (any isControlDoubleBuffered attrs) (accClipPicture (toRegion (sizeToRectangle wItemSize)) drawfun)+	osReleaseWindowPictContext wPtr osPict+	osDisposeRgn clipRgn						-- PA+++: dispose clipping region+	return (x, itemH{wItemInfo=WCustomInfo info{customInfoLook=itemLook{lookPen=pen}}})+	where+		info		= getWItemCustomInfo wItemInfo+		itemLook	= customInfoLook info
+ Graphics/UI/ObjectIO/Control/Internal.hs view
@@ -0,0 +1,1541 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Internal+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Control.Internal contains all control update functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Control.Internal+		( enablecontrols, disablecontrols+		, setcontrolsshowstate, setcontrolsmarkstate+		, setcontroltexts, seteditcontrolcursor+		, setcontrolslook, drawincontrol+		, setsliderstates, selectcontrolitem+		, openpopupitems, closepopupitems+		, openlistboxitems, closelistboxitems +		, movecontrolviewframe+		, setcontrolviewdomain, setcontrolscrollfun+		) where++++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.StdPicture+import Graphics.UI.ObjectIO.StdControlAttribute+import Graphics.UI.ObjectIO.StdWindowAttribute+import Graphics.UI.ObjectIO.Control.Validate+import Graphics.UI.ObjectIO.Control.Relayout(relayoutControls)+import Graphics.UI.ObjectIO.Control.Layout(layoutControls)+import Graphics.UI.ObjectIO.Control.Draw+import Graphics.UI.ObjectIO.Window.Access+import Graphics.UI.ObjectIO.Window.ClipState(validateCompoundClipState, invalidateCompoundClipState, forceValidCompoundClipState)+import Graphics.UI.ObjectIO.Window.Update(updateWindowBackgrounds)+import Graphics.UI.ObjectIO.Window.Validate(validateViewDomain)+import Graphics.UI.ObjectIO.OS.Window+import Graphics.UI.ObjectIO.OS.ToolTip+import Graphics.UI.ObjectIO.OS.Rgn+import Control.Monad(when)+++--	General occurrence tests on Id.++maybeRemoveCheck :: (Eq x) => Maybe x -> [x] -> (Bool,[x])+maybeRemoveCheck (Just id) ids+	= removeCheck id ids+maybeRemoveCheck nothing ids+	= (False,ids)++removeOnIdOfPair :: Maybe Id -> [(Id,x)] -> (Bool,(Id,x),[(Id,x)])+removeOnIdOfPair (Just id) id_args+	= remove (\(id',_)->id'==id) undefined id_args+removeOnIdOfPair nothing id_args+	= (False,undefined,id_args)++removeOnIdOfTriple :: Maybe Id -> [(Id,x,y)] -> (Bool,(Id,x,y),[(Id,x,y)])+removeOnIdOfTriple (Just id) id_args+	= remove (\(id',_,_)->id'==id) undefined id_args+removeOnIdOfTriple nothing id_args+	= (False,undefined,id_args)+++{-	getContentRect returns the content rect of the window. +	Because WindowInfo is not yet incorporated it boils down to the second alternative.+-}+getContentRect :: OSWindowMetrics -> WindowInfo -> Size -> Rect+getContentRect wMetrics (WindowInfo {windowDomain=domainRect,windowHScroll=wHScroll,windowVScroll=wVScroll}) size =+	getWindowContentRect wMetrics visScrolls (sizeToRect size)+	where		+		hasScrolls = (isJust wHScroll,isJust wVScroll)+		visScrolls = osScrollbarsAreVisible wMetrics domainRect (toTuple size) hasScrolls+getContentRect _ NoWindowInfo size = sizeToRect size+++{-	Calculate the intersection of the given Rect with the content of a CompoundControl. -}++intersectRectContent :: OSWindowMetrics -> Rect -> CompoundInfo -> Point2 -> Size -> Rect+intersectRectContent wMetrics clipRect info itemPos itemSize =+	intersectRects clipRect contentRect+	where+		hasScrolls  = (isJust (compoundHScroll info),isJust (compoundVScroll info))+		domainRect  = compoundDomain info+		itemRect    = posSizeToRect itemPos itemSize+		visScrolls  = osScrollbarsAreVisible wMetrics domainRect (toTuple itemSize) hasScrolls+		contentRect = getCompoundContentRect wMetrics visScrolls itemRect+++{-	Enable the controls and provide proper feedback.+	The [Id] argument contains the Ids of the controls that should be enabled.+	The Boolean argument controls the new SelectState. +		If the Boolean argument is False, then SelectState is the new SelectState of the indicated controls.+		If the Boolean argument is True,  then SelectState is the new SelectState of the indicated controls +										  and  all other controls. +-}++enablecontrols :: [Id] -> Bool -> OSWindowMetrics -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+enablecontrols ids overrule wMetrics wPtr wH@(WindowHandle {whItems=whItems,whShow=whShow,whSelect=whSelect,whSize=whSize,whDefaultId=whDefaultId}) = do+	(itemHs,_) <- setAllWElements (enableWItemHandle wMetrics wPtr whDefaultId overrule whSelect whShow clipRect) whItems ids+	return (wH{whItems=itemHs})+	where+		clipRect = getContentRect wMetrics (whWindowInfo wH) whSize++		enableWItemHandle :: OSWindowMetrics -> OSWindowPtr -> Maybe Id -> Bool -> Bool -> Bool -> Rect -> WElementHandle ls ps -> [Id] -> IO (WElementHandle ls ps,[Id])+		enableWItemHandle wMetrics wPtr defId overrule contextSelect contextShow clipRect itemH ids+			| Just systemOSAction <- mb_action =+				let (found,ids1) = maybeRemoveCheck (wItemId itemH) ids+				in if found+				   then do+				   	systemOSAction contextSelect+				   	return (itemH{wItemSelect=True},ids1)+				   else if overrule+				   	then do+				   		systemOSAction (contextSelect && itemSelect)+				   		return (itemH,ids)+					else return (itemH,ids)+			where+				itemPtr		= wItemPtr itemH+				itemSelect	= wItemSelect itemH+				mb_action	= case wItemKind itemH of+					IsRadioControl	-> Just (\able->mapM_ (\itemH->osSetRadioControlSelect wPtr (radioItemPtr itemH) clipRect able) (radioItems (getWItemRadioInfo (wItemInfo itemH))))+					IsCheckControl	-> Just (\able->mapM_ (\itemH->osSetCheckControlSelect wPtr (checkItemPtr itemH) clipRect able) (checkItems (getWItemCheckInfo (wItemInfo itemH))))+					IsPopUpControl	-> Just (osSetPopUpControlSelect   wPtr itemPtr clipRect)+					IsListBoxControl-> Just (osSetListBoxControlSelect wPtr itemPtr clipRect)+					IsSliderControl	-> Just (osSetSliderControlSelect  wPtr itemPtr clipRect)+					IsTextControl	-> Just (osSetTextControlSelect    wPtr itemPtr clipRect)+					IsEditControl	-> Just (osSetEditControlSelect    wPtr itemPtr clipRect)+					IsButtonControl	-> Just (osSetButtonControlSelect  wPtr itemPtr clipRect)+					_		-> Nothing++		enableWItemHandle wMetrics wPtr defId overrule contextSelect contextShow clipRect itemH ids+			| customControl =+				let (found,ids1) = maybeRemoveCheck (wItemId itemH) ids+				in if found+				   then do+					customOSAction contextSelect+					itemH <- customDraw contextSelect wPtr clipRect itemH{wItemSelect=True}+					return (itemH,ids1)+				   else if overrule+				        then do+				        	let select = contextSelect && itemSelect+						itemH <- customDraw select wPtr clipRect itemH+						customOSAction select+						return (itemH,ids)+					else return (itemH,ids)+			where+				itemPtr		= wItemPtr itemH+				itemSelect	= wItemSelect itemH+				(customControl,customDraw,customOSAction) = case wItemKind itemH of+					IsCustomButtonControl	-> (True,drawCustomButtonLook,osSetCustomButtonControlSelect wPtr itemPtr clipRect)+					IsCustomControl		-> (True,drawCustomLook,      osSetCustomControlSelect       wPtr itemPtr clipRect)+					_			-> (False,undefined,undefined)++		enableWItemHandle wMetrics wPtr defId overrule contextSelect contextShow clipRect itemH ids+			| wItemKind itemH == IsCompoundControl =+				let (found,ids1) = maybeRemoveCheck (wItemId itemH) ids+				in if found+				   then do+					itemH <- validateCompoundClipState wMetrics False wPtr defId contextShow itemH+					itemH <- drawCompoundLook wMetrics contextSelect wPtr clipRect1 itemH+					(itemHs,ids2) <- setAllWElements (enableWItemHandle wMetrics wPtr defId True contextSelect contextShow1 clipRect1) (wItems itemH) ids1+					osSetCompoundSelect wPtr itemPtr clipRect scrollInfo contextSelect+				  	return (itemH{wItemSelect=True,wItems=itemHs}, ids2)+				   else if overrule+				        then do+						itemH <- validateCompoundClipState wMetrics False wPtr defId contextShow itemH+						itemH <- drawCompoundLook wMetrics contextSelect1 wPtr clipRect1 itemH+						(itemHs,ids2) <- setAllWElements (enableWItemHandle wMetrics wPtr defId overrule contextSelect1 contextShow1 clipRect1) (wItems itemH) ids1+						osSetCompoundSelect wPtr itemPtr clipRect scrollInfo contextSelect1+				  		return (itemH{wItems=itemHs},ids2)+					else do+						(itemHs,ids) <- setAllWElements (enableWItemHandle wMetrics wPtr defId overrule contextSelect1 contextShow1 clipRect1) (wItems itemH) ids+				  		return (itemH{wItems=itemHs},ids)+			where+				itemPtr		= wItemPtr itemH+				itemSelect	= wItemSelect itemH+				info		= getWItemCompoundInfo (wItemInfo itemH)+				scrollInfo	= (isJust (compoundHScroll info),isJust (compoundVScroll info))+				itemSize	= wItemSize itemH+				contextSelect1	= contextSelect && itemSelect+				contextShow1	= contextShow && wItemShow itemH+				clipRect1	= intersectRectContent wMetrics clipRect info (wItemPos itemH) itemSize++		enableWItemHandle wMetrics wPtr defId overrule contextSelect contextShow clipRect itemH ids+			| wItemKind itemH == IsLayoutControl =+				let +					(found,ids1) = maybeRemoveCheck (wItemId itemH) ids+			  		contextSelect1 = if found then contextSelect else contextSelect && itemSelect+			  	in do+			  		(itemHs,ids2) <- setAllWElements (enableWItemHandle wMetrics wPtr defId (overrule || found) contextSelect1 contextShow1 clipRect1) (wItems itemH) ids1+			  		return (itemH{wItemSelect=found || itemSelect,wItems=itemHs},ids)+			where+				itemSelect	= wItemSelect itemH+				contextShow1	= contextShow && (wItemShow itemH)+				clipRect1	= intersectRects clipRect (posSizeToRect (wItemPos itemH) (wItemSize itemH))++		enableWItemHandle _ _ _ _ _ _ _ itemH ids+			| wItemKind itemH == IsReceiverControl =+				let (found,ids1) = maybeRemoveCheck (wItemId itemH) ids+				in if found then return (itemH{wItemSelect=True},ids)+				   else return (itemH,ids)++{-	Disable the controls and provide proper feedback.+	The [Id] argument contains the Ids of the controls that should be (dis/en)abled.+	The Boolean argument controls the new SelectState. +		If the Boolean argument is False, then SelectState is the new SelectState of the indicated controls.+		If the Boolean argument is True,  then SelectState is the new SelectState of the indicated controls +										  and  all other controls. +-}+disablecontrols :: [Id] -> Bool -> OSWindowMetrics -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle  ls ps)+disablecontrols ids overrule wMetrics wPtr wH@(WindowHandle {whItems=itemHs,whShow=whShow,whSelect=whSelect,whSize=whSize,whDefaultId=whDefaultId}) = do+	(itemHs,_) <- setAllWElements (disableWItemHandle wMetrics wPtr whDefaultId overrule whSelect whShow clipRect) itemHs ids+	return wH{whItems=itemHs}+	where+		clipRect			= getContentRect wMetrics (whWindowInfo wH) whSize+		+		disableWItemHandle :: OSWindowMetrics -> OSWindowPtr -> Maybe Id -> Bool -> Bool -> Bool -> Rect -> WElementHandle ls ps -> [Id] -> IO (WElementHandle ls ps,[Id])+		disableWItemHandle wMetrics wPtr defId overrule contextSelect contextShow clipRect itemH@(WItemHandle {wItemKind=wItemKind}) ids+			| Just systemOSAction <- mb_action =+				let (found,ids1) = maybeRemoveCheck (wItemId itemH) ids+				in if found then do+					systemOSAction False+					return (itemH{wItemSelect=False},ids1)+				   else if overrule+					then do+						systemOSAction (contextSelect && itemSelect)+						return (itemH,ids)+					else return (itemH,ids)+			where+				itemPtr		= wItemPtr itemH+				itemSelect	= wItemSelect itemH+				mb_action	= case wItemKind of+					IsRadioControl	-> Just (\able->mapM_ (\itemH->osSetRadioControlSelect wPtr (radioItemPtr itemH) clipRect able) (radioItems (getWItemRadioInfo (wItemInfo itemH))))+					IsCheckControl	-> Just (\able->mapM_ (\itemH->osSetCheckControlSelect wPtr (checkItemPtr itemH) clipRect able) (checkItems (getWItemCheckInfo (wItemInfo itemH))))+					IsPopUpControl	-> Just (osSetPopUpControlSelect   wPtr itemPtr clipRect)+					IsListBoxControl-> Just (osSetListBoxControlSelect wPtr itemPtr clipRect)+					IsSliderControl	-> Just (osSetSliderControlSelect  wPtr itemPtr clipRect)+					IsTextControl	-> Just (osSetTextControlSelect    wPtr itemPtr clipRect)+					IsEditControl	-> Just (osSetEditControlSelect    wPtr itemPtr clipRect)+					IsButtonControl	-> Just (osSetButtonControlSelect  wPtr itemPtr clipRect)+					_		-> Nothing+		+		disableWItemHandle wMetrics wPtr defId overrule contextSelect contextShow clipRect itemH@(WItemHandle {wItemKind=wItemKind}) ids+			| customControl =+				let (found,ids1) = maybeRemoveCheck (wItemId itemH) ids+				in if found then do+					customOSAction False+					itemH <- customDraw False wPtr clipRect (itemH{wItemSelect=False})+					return (itemH,ids1)+				   else if overrule+					then do				+						let select = contextSelect && itemSelect+						itemH <- customDraw select wPtr clipRect itemH+						customOSAction select+						return (itemH,ids)+					else return (itemH,ids)+			where+				itemPtr				= wItemPtr itemH+				itemSelect			= wItemSelect itemH+				(customControl,customDraw,customOSAction)+									= case wItemKind of+										IsCustomButtonControl	-> (True,drawCustomButtonLook,osSetCustomButtonControlSelect wPtr itemPtr clipRect)+										IsCustomControl		-> (True,drawCustomLook,      osSetCustomControlSelect       wPtr itemPtr clipRect)+										_			-> (False,undefined,undefined)+		+		disableWItemHandle wMetrics wPtr defId overrule contextSelect contextShow clipRect itemH@(WItemHandle {wItemKind=wItemKind}) ids+			| wItemKind == IsCompoundControl =+				let (found,ids1) = maybeRemoveCheck (wItemId itemH) ids+				in if found then do+					itemH <- validateCompoundClipState wMetrics False wPtr defId contextShow (itemH{wItemSelect=False})+					itemH <- drawCompoundLook wMetrics False wPtr clipRect1 itemH+					(itemHs,ids) <- setAllWElements (disableWItemHandle wMetrics wPtr defId True False contextShow1 clipRect1) (wItems itemH) ids+					osSetCompoundSelect wPtr itemPtr clipRect scrollInfo False+					return (itemH{wItems=itemHs}, ids1)+				   else if overrule+					then do+						itemH <- validateCompoundClipState wMetrics False wPtr defId contextShow itemH+						itemH <- drawCompoundLook wMetrics contextSelect1 wPtr clipRect1 itemH+						(itemHs,ids) <- setAllWElements (disableWItemHandle wMetrics wPtr defId overrule contextSelect1 contextShow1 clipRect1) (wItems itemH) ids+						osSetCompoundSelect wPtr itemPtr clipRect scrollInfo contextSelect1+						return (itemH{wItems=itemHs}, ids)+					else do+						(itemHs,ids) <- setAllWElements (disableWItemHandle wMetrics wPtr defId overrule contextSelect1 contextShow1 clipRect1) (wItems itemH) ids+						return (itemH{wItems=itemHs},ids)+			where+				itemPtr					= wItemPtr itemH+				itemSelect				= wItemSelect itemH+				itemSize				= wItemSize itemH+				contextSelect1			= contextSelect && itemSelect+				contextShow1			= contextShow && wItemShow itemH+				info					= getWItemCompoundInfo (wItemInfo itemH)+				scrollInfo				= (isJust (compoundHScroll info),isJust (compoundVScroll info))+				clipRect1				= intersectRectContent wMetrics clipRect info (wItemPos itemH) itemSize+		+		disableWItemHandle wMetrics wPtr defId overrule contextSelect contextShow clipRect itemH@(WItemHandle {wItemKind=wItemKind}) ids+			| wItemKind == IsLayoutControl =+				let (found,ids1) = maybeRemoveCheck (wItemId itemH) ids+				in do+					let contextSelect1 = (not found) && (contextSelect && itemSelect)+					(itemHs,ids) <- setAllWElements (disableWItemHandle wMetrics wPtr defId (found || overrule) contextSelect1 contextShow1 clipRect1) (wItems itemH) ids1+					return (itemH{wItemSelect=not found && itemSelect,wItems=itemHs}, ids)+			where+				itemSelect				= wItemSelect itemH+				contextShow1			= contextShow && (wItemShow itemH)+				clipRect1				= intersectRects clipRect (posSizeToRect (wItemPos itemH) (wItemSize itemH))+		+		disableWItemHandle _ _ _ _ _ _ _ itemH@(WItemHandle {wItemKind=wItemKind}) ids+			| wItemKind == IsReceiverControl =+				let (found,ids1) = maybeRemoveCheck (wItemId itemH) ids+				in if found	then return (itemH{wItemSelect=False},ids1)+				   else return (itemH,ids)+++--	Set the show state of the controls and provide proper feedback.++setcontrolsshowstate :: [Id] -> Bool -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> IO (WindowHandle ls ps)+setcontrolsshowstate ids itemsShow wMetrics wids wH@(WindowHandle {whItems=itemHs,whSelect=whSelect,whSize=whSize,whWindowInfo=whWindowInfo}) = do+	(itemHs,_)	<- setArgWElements (setWItemShowStates wMetrics (wPtr wids) overrule itemsShow contextShow contextSelect clipRect) itemHs ids+	return (wH{whItems=itemHs})+	where+		clipRect		= getContentRect wMetrics whWindowInfo whSize+		overrule		= False+		contextShow		= True+		contextSelect		= if whSelect then Able else Unable+		+		setWItemShowStates :: OSWindowMetrics -> OSWindowPtr -> Bool -> Bool -> Bool -> SelectState -> Rect -> WElementHandle ls ps -> [Id] -> IO (WElementHandle ls ps,[Id])+		+		setWItemShowStates wMetrics wPtr overrule itemsShow contextShow contextSelect clipRect itemH@(WItemHandle  {wItemKind=IsRadioControl}) ids =+			let (found,ids1) = maybeRemoveCheck (wItemId itemH) ids+			in if not found && not overrule+			   then return (itemH,ids)+			   else let +						osShow	= (not overrule || contextShow) && itemsShow+						info	= getWItemRadioInfo (wItemInfo itemH)+					in do+						mapM_ (setradio osShow clipRect) (radioItems info)+						return (if found then itemH{wItemShow=itemsShow} else itemH,ids1)+			where+				setradio :: Bool -> Rect -> RadioItemInfo ls ps -> IO ()+				setradio osShow clipRect (RadioItemInfo {radioItemPtr=itemPtr}) =+					osSetRadioControlShow wPtr itemPtr clipRect osShow+		+		setWItemShowStates wMetrics wPtr overrule itemsShow contextShow contextSelect clipRect itemH@(WItemHandle {wItemKind=IsCheckControl}) ids =+			let (found,ids1) = maybeRemoveCheck (wItemId itemH) ids+			in if not found && not overrule+			   then return (itemH,ids)+			   else let+						osShow = (not overrule || contextShow) && itemsShow			  +						info   = getWItemCheckInfo (wItemInfo itemH)+					in do+						mapM_ (setcheck osShow clipRect) (checkItems info)+						return (if found then itemH{wItemShow=itemsShow} else itemH,ids1)+			where+				setcheck :: Bool -> Rect -> CheckItemInfo ls ps -> IO ()+				setcheck osShow clipRect (CheckItemInfo {checkItemPtr=itemPtr}) =+					osSetRadioControlShow wPtr itemPtr clipRect osShow+		+		setWItemShowStates wMetrics wPtr overrule itemsShow contextShow contextSelect clipRect itemH@(WItemHandle {wItemKind=wItemKind}) ids+			| Just osAction <- mb_action =+				let (found,ids1) = maybeRemoveCheck (wItemId itemH) ids+				in if not found && not overrule+				   then return (itemH,ids)+				   else let+							osShow = (not overrule || contextShow) && itemsShow+						in do+							osAction wPtr (wItemPtr itemH) clipRect osShow+							return (if found then itemH{wItemShow=itemsShow} else itemH,ids1)+			where+				mb_action = case wItemKind of+					IsPopUpControl		-> Just osSetPopUpControlShow+					IsListBoxControl	-> Just osSetListBoxControlShow+					IsSliderControl		-> Just osSetSliderControlShow+					IsTextControl		-> Just osSetTextControlShow+					IsEditControl		-> Just osSetEditControlShow+					IsButtonControl		-> Just osSetButtonControlShow+					_			-> Nothing+		+		setWItemShowStates wMetrics wPtr overrule itemsShow contextShow contextSelect clipRect itemH@(WItemHandle {wItemKind=wItemKind}) ids+			| isCustom =+				let (found,ids1) = maybeRemoveCheck (wItemId itemH) ids+				in if not found && not overrule+				   then return (itemH,ids)+				   else let			+							osShow = (not overrule || contextShow) && itemsShow+						in do+							osAction wPtr (wItemPtr itemH) clipRect osShow+							itemH <- (if osShow then customDraw (wItemSelect itemH) wPtr clipRect itemH else return itemH)+							return (if found then itemH{wItemShow=itemsShow} else itemH,ids1)+			where+				(isCustom,customDraw,osAction) = case wItemKind of+					IsCustomButtonControl	-> (True,drawCustomButtonLook,osSetCustomButtonControlShow)+					IsCustomControl			-> (True,drawCustomLook,      osSetCustomControlShow)+					_						-> (False,undefined,undefined)+		+		setWItemShowStates wMetrics wPtr overrule itemsShow contextShow contextSelect clipRect itemH@(WItemHandle {wItemKind=IsCompoundControl}) ids =+			let+				(found,ids1) = maybeRemoveCheck (wItemId itemH) ids+				contextShow1 = contextShow && (if found then itemsShow else wItemShow itemH)+				overrule1	 = overrule || found && (wItemShow itemH /= itemsShow)+			in do+				(itemHs,ids) <- setAllWElements (setWItemShowStates wMetrics wPtr overrule1 itemsShow contextShow1 contextSelect1 clipRect1) (wItems itemH) ids1+				(if not found && not overrule+				 then return (itemH{wItems=itemHs},ids)+				 else do+					osSetCompoundShow wPtr (wItemPtr itemH) clipRect itemsShow+					let itemH1 = (if found then itemH{wItems=itemHs, wItemShow=itemsShow} else itemH{wItems=itemHs})+					let itemH2 = invalidateCompoundClipState itemH1+					return (itemH2,ids))+			where+				contextSelect1	= if enabled contextSelect then (if wItemSelect itemH then Able else Unable) else contextSelect+				info			= getWItemCompoundInfo (wItemInfo itemH)+				itemSize		= wItemSize itemH+				clipRect1		= intersectRectContent wMetrics clipRect info (wItemPos itemH) itemSize+		+		setWItemShowStates wMetrics wPtr overrule itemsShow contextShow contextSelect clipRect itemH@(WItemHandle {wItemKind=IsLayoutControl}) ids =+			let+				(found,ids1) = maybeRemoveCheck (wItemId itemH) ids+				contextShow1 = contextShow && (if found then itemsShow else itemShow)+				overrule1	 = overrule || found && (itemShow /= itemsShow)+			in do+				(itemHs,ids) <- setAllWElements (setWItemShowStates wMetrics wPtr overrule1 itemsShow contextShow1 contextSelect1 clipRect) (wItems itemH) ids1+				return (itemH{wItemShow=if found then itemsShow else itemShow,wItems=itemHs},ids)+			where+				itemShow		= wItemShow itemH+				contextSelect1	= if enabled contextSelect then (if wItemSelect itemH then Able else Unable) else contextSelect+		+		setWItemShowStates _ _ _ _ _ _ _ itemH@(WItemHandle {wItemKind=IsReceiverControl}) ids =+			let +				(_,ids1) = maybeRemoveCheck (wItemId itemH) ids+			in+				return (itemH,ids1)+++--	Set the MarkState of the controls and provide proper feedback.++setcontrolsmarkstate :: Id -> MarkState -> [Index] -> OSWindowMetrics -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+setcontrolsmarkstate id mark indices wMetrics wPtr wH@(WindowHandle {whItems=itemHs,whSize=whSize,whWindowInfo=whWindowInfo}) = do+	(_,itemHs,_) <- setWElement (setWItemMarks wMetrics wPtr mark indices) id itemHs ()+	return (wH{whItems=itemHs})+	where+		setWItemMarks :: OSWindowMetrics -> OSWindowPtr -> MarkState -> [Index] -> Id -> WElementHandle ls ps -> s -> IO (Bool,WElementHandle ls ps,s)+		setWItemMarks wMetrics wPtr mark indices id itemH@(WItemHandle {wItemKind=IsCheckControl}) s+			| identifyMaybeId id (wItemId itemH) =+				let+					info = getWItemCheckInfo (wItemInfo itemH)+					items = checkItems info+					nrCheckItems = length items+					indices1 = filter (\index->isBetween index 1 nrCheckItems) indices+				in+					if null indices1 then return (True,itemH,s)+					else do+						items <- foldrM (setCheckMark wPtr mark) items indices1+						return (True,itemH{wItemInfo=WCheckInfo info{checkItems=items}},s)+			| otherwise =+				return (False,itemH,s)+			where+				setCheckMark :: OSWindowPtr -> MarkState -> Index -> [CheckItemInfo ls ps] -> IO [CheckItemInfo ls ps]+				setCheckMark wPtr mark index checkItems =+					let+						(before,(item:after)) 	= split (index-1) checkItems+						(title,width,_,f)	= checkItem item+						checkItems1		= before++(item{checkItem=(title,width,mark,f)}:after)+					in do+						osCheckCheckControl wPtr (checkItemPtr item) (marked mark)+						return checkItems1+						+		setWItemMarks wMetrics wPtr mark indices id itemH@(WItemHandle {wItemKind=IsListBoxControl}) s+			| identifyMaybeId id (wItemId itemH) =+				let+					info    = getWItemListBoxInfo (wItemInfo itemH)+					items   = listBoxInfoItems info+					nrItems = length items+					indices1= filter (\index->isBetween index 1 nrItems) indices+				in+					if null indices1 then return (True,itemH,s)+					else do+						items <- foldrM (setItemMark wPtr mark) items indices1+						return (True,itemH{wItemInfo=WListBoxInfo info{listBoxInfoItems=items}},s)+			| otherwise =+				return (False,itemH,s)+			where+				setItemMark :: OSWindowPtr -> MarkState -> Index -> [ListBoxControlItem ls ps] -> IO [ListBoxControlItem ls ps]+				setItemMark wPtr mark index items =+					let+						(before,((title,_,f):after)) = split (index-1) items+						items1	= before++(title,mark,f):after+					in do+						osMarkListBoxControlItem wPtr (wItemPtr itemH) index (marked mark)+						return items1+		+		setWItemMarks wMetrics wPtr mark indices id itemH@(WItemHandle {wItemKind=wItemKind}) s+			| wItemKind == IsCompoundControl = do+				(found,itemHs,s) <- setWElement (setWItemMarks wMetrics wPtr mark indices) id (wItems itemH) s+				return (found,itemH{wItems=itemHs},s)+				+			| wItemKind == IsLayoutControl = do+				(found,itemHs,s) <- setWElement (setWItemMarks wMetrics wPtr mark indices) id (wItems itemH) s+				return (found,itemH{wItems=itemHs},s)++			| otherwise =+				return (False,itemH,s)++--	Set the text of the controls and provide proper feedback.++setcontroltexts :: [(Id,String)] -> OSWindowMetrics -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+setcontroltexts id_texts wMetrics wPtr wH+	= do {+		(itemHs,_) <- setArgWElements (setControlText wMetrics wPtr True clipRect) (whItems wH) id_texts;+		return wH{whItems=itemHs}+	  }+	where+		clipRect = getContentRect wMetrics (whWindowInfo wH) (whSize wH)+		+		setControlText :: OSWindowMetrics -> OSWindowPtr -> Bool -> Rect -> WElementHandle ls ps -> [(Id,String)] -> IO (WElementHandle ls ps,[(Id,String)])+		+		setControlText wMetrics wPtr shownContext clipRect itemH@(WItemHandle {wItemKind=IsEditControl}) id_texts+			| not found+				= return (itemH,id_texts1)+			| otherwise+				= osSetEditControlText wPtr (wItemPtr itemH1) clipRect itemRect shownContext1 text >> return (itemH1,id_texts1)+			where+				(found,id_text,id_texts1) = removeOnIdOfPair (wItemId itemH) id_texts+				shownContext1             = shownContext && wItemShow itemH+				(_,text)                  = id_text+				editInfo                  = getWItemEditInfo (wItemInfo itemH)+				itemH1                    = itemH {wItemInfo=WEditInfo editInfo {editInfoText=text}}+				itemRect                  = posSizeToRect (wItemPos itemH) (wItemSize itemH)+		+		setControlText wMetrics wPtr shownContext clipRect itemH@(WItemHandle {wItemKind=IsTextControl}) id_texts+			| not found+				= return (itemH,id_texts1)+			| otherwise+				= osSetTextControlText wPtr (wItemPtr itemH) clipRect itemRect shownContext1 text >> return (itemH1,id_texts1)+			where+				(found,id_text,id_texts1) = removeOnIdOfPair (wItemId itemH) id_texts+				(_,text)                  = id_text+				shownContext1             = shownContext && wItemShow itemH+				textInfo                  = getWItemTextInfo (wItemInfo itemH)+				itemH1                    = itemH {wItemInfo=WTextInfo textInfo {textInfoText=text}}+				itemRect                  = posSizeToRect (wItemPos itemH) (wItemSize itemH)+		+		setControlText wMetrics wPtr _ clipRect itemH@(WItemHandle {wItemKind=IsButtonControl}) id_texts+			| not found+				= return (itemH,id_texts1)+			| otherwise+				= osSetButtonControlText wPtr (wItemPtr itemH) clipRect (validateControlTitle text) >> return (itemH1,id_texts1)+			where+				(found,id_text,id_texts1) = removeOnIdOfPair (wItemId itemH) id_texts+				(_,text)                  = id_text+				buttonInfo                = getWItemButtonInfo (wItemInfo itemH)+				itemH1                    = itemH {wItemInfo=WButtonInfo buttonInfo {buttonInfoText=text}}+		+		setControlText wMetrics wPtr shownContext clipRect itemH@(WItemHandle {wItemKind=IsCompoundControl}) id_texts+			= do {+				(itemHs,id_texts1) <- setArgWElements (setControlText wMetrics wPtr shownContext1 clipRect1) (wItems itemH) id_texts;+				return (itemH {wItems=itemHs},id_texts1)+			  }+			where+				info                      = getWItemCompoundInfo (wItemInfo itemH)+				clipRect1                 = intersectRectContent wMetrics clipRect info (wItemPos itemH) (wItemSize itemH)+				shownContext1             = shownContext && wItemShow itemH++		setControlText wMetrics wPtr shownContext clipRect itemH@(WItemHandle {wItemKind=IsLayoutControl}) id_texts+			= do {+				(itemHs,id_texts1) <- setArgWElements (setControlText wMetrics wPtr shownContext1 clipRect1) (wItems itemH) id_texts;+				return (itemH{wItems=itemHs},id_texts1)+			  }+			where+				clipRect1                 = intersectRects clipRect (posSizeToRect (wItemPos itemH) (wItemSize itemH))+				shownContext1             = shownContext && wItemShow itemH+	+		setControlText _ _ _ _ itemH id_texts+			= return (itemH,id_texts)+++--	Set the cursor position of an EditControl, and handle proper feedback.++seteditcontrolcursor :: Id -> Int -> OSWindowMetrics -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+seteditcontrolcursor id pos wMetrics wPtr wH@(WindowHandle {whItems=itemHs,whSize=whSize,whWindowInfo=whWindowInfo}) = do+	(_,itemHs,_) <- setWElement (setEditCursor wMetrics wPtr True clipRect pos) id itemHs ()+	return (wH{whItems=itemHs})+	where+		clipRect = getContentRect wMetrics whWindowInfo whSize+		+		setEditCursor :: OSWindowMetrics -> OSWindowPtr -> Bool -> Rect -> Int -> Id -> WElementHandle ls ps -> s -> IO (Bool,WElementHandle ls ps,s)+		setEditCursor wMetrics wPtr shownContext clipRect pos id itemH@(WItemHandle {wItemKind=IsEditControl}) s+			| not (identifyMaybeId id (wItemId itemH)) =+				return (False,itemH,s)+			| otherwise =+				let +					itemRect = posSizeToRect (wItemPos itemH) (wItemSize itemH)+				in do+					osSetEditControlCursor wPtr (wItemPtr itemH) clipRect itemRect pos+					return (True,itemH,s)+		+		setEditCursor wMetrics wPtr shownContext clipRect pos id itemH@(WItemHandle {wItems=itemHs, wItemKind=IsCompoundControl}) s = do+			(found,itemHs,s) <- setWElement (setEditCursor wMetrics wPtr shownContext1 clipRect1 pos) id itemHs s+			return (found,itemH{wItems=itemHs},s)+			where+				info			= getWItemCompoundInfo (wItemInfo itemH)+				clipRect1		= intersectRectContent wMetrics clipRect info (wItemPos itemH) (wItemSize itemH)+				shownContext1	= shownContext && (wItemShow itemH)+		+		setEditCursor wMetrics wPtr shownContext clipRect pos id itemH@(WItemHandle {wItems=itemHs, wItemKind=IsLayoutControl}) s = do+			(found,itemHs,s) <- setWElement (setEditCursor wMetrics wPtr shownContext1 clipRect1 pos) id itemHs s+			return (found,itemH{wItems=itemHs},s)+			where+				clipRect1			= intersectRects clipRect (posSizeToRect (wItemPos itemH) (wItemSize itemH))+				shownContext1		= shownContext && wItemShow itemH+		+		setEditCursor _ _ _ _ _ _ itemH s = do+			return (False,itemH,s)+++--	Set the look of a control, and handle proper feedback.++setcontrolslook :: [(Id,Bool,(Bool,Look))] -> OSWindowMetrics -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+setcontrolslook looks wMetrics wPtr wH@(WindowHandle {whItems=itemHs,whSelect=whSelect,whDefaultId=whDefaultId,whSize=whSize,whWindowInfo=whWindowInfo}) = do+	(itemHs, _) <- setAllWElements (setWItemLook wMetrics wPtr whSelect True resizeable whDefaultId clipRect) itemHs looks+	return (wH{whItems=itemHs})+	where+		clipRect	= getContentRect wMetrics whWindowInfo whSize+		resizeable	= True+		+		setWItemLook :: OSWindowMetrics -> OSWindowPtr -> Bool -> Bool -> Bool -> Maybe Id -> Rect -> WElementHandle ls ps -> [(Id,Bool,(Bool,Look))] -> IO (WElementHandle ls ps,[(Id,Bool,(Bool,Look))])+		setWItemLook wMetrics wPtr ableContext shownContext resizeable defId clipRect itemH@(WItemHandle {wItemId=wItemId,wItemKind=IsCompoundControl,wItemSize=wItemSize}) looks =+			let+				(found,look,looks1)	= removeOnIdOfTriple wItemId looks+				(_,redraw,(sysLook,cLook)) = look+			in do+				(itemHs,looks) <- setAllWElements (setWItemLook wMetrics wPtr ableContext1 shownContext1 resizeable defId clipRect1) (wItems itemH) looks1+				(if not found then return (itemH{wItems=itemHs},looks)+				 else+					let +						info1  = info{compoundLookInfo=lookInfo{compoundLook = LookInfo+											{ lookFun		= cLook+		  									, lookPen		= pen+		  									, lookSysUpdate	= sysLook+		  									}}}+						itemH1 = itemH{wItems=itemHs, wItemInfo=WCompoundInfo info1}+					in +						if not redraw || not shownContext1+						then return (itemH1,looks)+						else do						+							itemH <- validateCompoundClipState wMetrics False wPtr defId shownContext itemH1+							itemH <- drawCompoundLook wMetrics ableContext1 wPtr clipRect1 itemH+							return (itemH,looks))+			where+				info				= getWItemCompoundInfo (wItemInfo itemH)+				hasScrolls			= (isJust (compoundHScroll info),isJust (compoundVScroll info))+				lookInfo			= compoundLookInfo info+				pen					= lookPen (compoundLook lookInfo)+				visScrolls			= osScrollbarsAreVisible wMetrics (compoundDomain info) (toTuple wItemSize) hasScrolls+				itemRect			= posSizeToRect (wItemPos itemH) wItemSize+				contentRect			= getCompoundContentRect wMetrics visScrolls itemRect+				clipRect1			= intersectRects clipRect contentRect+				ableContext1		= ableContext  && wItemSelect itemH+				shownContext1		= shownContext && wItemShow itemH++		setWItemLook wMetrics wPtr ableContext shownContext resizeable defId clipRect itemH@(WItemHandle {wItemId=wItemId,wItemKind=IsCustomButtonControl}) looks =+			let+				(found,look,looks1)			= removeOnIdOfTriple wItemId looks+				(_,redraw,(sysLook,cLook))	= look+			in +				if not found+				then return (itemH,looks1)+				else +					let+						info1  = info{cButtonInfoLook=itemLook{lookFun=cLook,lookSysUpdate=sysLook}}+						itemH1 = itemH{wItemInfo=WCustomButtonInfo info1}+					in+						if not redraw || not shownContext1 then return (itemH1,looks1)+						else do+							itemH2 <- drawCustomButtonLook ableContext1 wPtr clipRect itemH1+							return (itemH2,looks1)+			where+				info			= getWItemCustomButtonInfo (wItemInfo itemH)+				itemLook		= cButtonInfoLook info+				ableContext1	= ableContext  && wItemSelect itemH+				shownContext1	= shownContext && wItemShow   itemH+		+		setWItemLook wMetrics wPtr ableContext shownContext resizeable defId clipRect itemH@(WItemHandle {wItemId=wItemId,wItemKind=IsCustomControl}) looks =+			let+				(found,look,looks1)	= removeOnIdOfTriple wItemId looks+				(_,redraw,(sysLook,cLook)) = look+			in+				if not found+				then return (itemH,looks1)+				else+					let+						info1  = info{customInfoLook=itemLook{lookFun=cLook,lookSysUpdate=sysLook}}+						itemH1 = itemH{wItemInfo=WCustomInfo info1}+					in+						if not redraw || not shownContext1 then return (itemH1,looks1)+						else do+							itemH2 <- drawCustomLook ableContext1 wPtr clipRect itemH1+							return (itemH2,looks1)+			where+				info			= getWItemCustomInfo (wItemInfo itemH)+				itemLook		= customInfoLook info+				ableContext1	= ableContext  && wItemSelect itemH+				shownContext1	= shownContext && wItemShow   itemH+		+		setWItemLook wMetrics wPtr ableContext shownContext resizeable defId clipRect itemH@(WItemHandle {wItemId=wItemId,wItems=itemHs,wItemKind=IsLayoutControl}) looks =+			let+				(_,_,looks1) = removeOnIdOfTriple wItemId looks+			in do+				(itemHs,looks) <- setAllWElements (setWItemLook wMetrics wPtr ableContext1 shownContext1 resizeable defId clipRect1) itemHs looks1+				return (itemH{wItems=itemHs},looks1)+			where+				clipRect1		= intersectRects clipRect (posSizeToRect (wItemPos itemH) (wItemSize itemH))+				ableContext1	= ableContext  && wItemSelect itemH+				shownContext1	= shownContext && wItemShow   itemH+		+		setWItemLook _ _ _ _ _ _ _ itemH@(WItemHandle {wItemId=wItemId}) looks =+			let+				(_,_,looks1)	= removeOnIdOfTriple wItemId looks+			in+				return (itemH,looks)+++--	Draw in a customised control.++drawincontrol :: Id -> Draw x -> OSWindowMetrics -> OSWindowPtr -> WindowHandle ls ps -> IO (Maybe x,WindowHandle ls ps)+drawincontrol controlId drawfun wMetrics wPtr wH@(WindowHandle {whItems=itemHs,whDefaultId=whDefaultId,whShow=whShow,whSize=whSize,whWindowInfo=whWindowInfo}) = do+	(_,itemHs,mb_x) <- setWElement (drawInWItem wMetrics wPtr resizeable whDefaultId whShow clipRect drawfun) controlId itemHs Nothing+	return (mb_x,wH{whItems=itemHs})+	where+		clipRect	= getContentRect wMetrics whWindowInfo whSize+		resizeable	= True++		drawInWItem :: OSWindowMetrics -> OSWindowPtr -> Bool -> Maybe Id -> Bool -> Rect -> Draw x -> Id -> WElementHandle ls ps -> Maybe x -> IO (Bool,WElementHandle ls ps,Maybe x)+		drawInWItem wMetrics wPtr resizeable defId contextShow clipRect drawfun id itemH@(WItemHandle {wItemId=itemId,wItemPtr=itemPtr,wItems=itemHs, wItemKind=IsCompoundControl}) mb_x+			| not (identifyMaybeId id itemId) = do+				(found,itemHs,mb_x) <- setWElement (drawInWItem wMetrics wPtr resizeable defId itemShow clipRect1 drawfun) id itemHs mb_x+				return (found,itemH{wItems=itemHs},mb_x)+			| otherwise = do				+				itemH <- validateCompoundClipState wMetrics False wPtr defId contextShow itemH+				(x,itemH) <- drawInCompound wPtr drawfun clipRect1 itemH+				return (True,itemH,Just x)+			where+				itemShow	= contextShow && wItemShow itemH+				info		= getWItemCompoundInfo (wItemInfo itemH)+				domainRect	= compoundDomain info+				hasScrolls	= (isJust (compoundHScroll info),isJust (compoundVScroll info))+				itemPos		= wItemPos itemH+				itemSize	= wItemSize itemH+				itemRect	= posSizeToRect itemPos itemSize+				visScrolls	= osScrollbarsAreVisible wMetrics domainRect (toTuple itemSize) hasScrolls+				contentRect	= getCompoundContentRect wMetrics visScrolls itemRect+				clipRect1	= intersectRects clipRect contentRect++		drawInWItem _ wPtr _ _ _ clipRect drawfun id itemH@(WItemHandle {wItemId=itemId,wItemKind=IsCustomButtonControl}) mb_x+			| not (identifyMaybeId id itemId) =+				return (False,itemH,mb_x)+			| otherwise = do+				(x,itemH) <- drawInCustomButton wPtr drawfun clipRect itemH+				return (True,itemH,Just x)++		drawInWItem _ wPtr _ _ _ clipRect drawfun id itemH@(WItemHandle {wItemId=itemId,wItemKind=IsCustomControl}) mb_x+			| not (identifyMaybeId id itemId) =+				return (False,itemH,mb_x)+			| otherwise = do+				(x,itemH) <- drawInCustom wPtr drawfun clipRect itemH+				return (True,itemH,Just x)++		drawInWItem wMetrics wPtr resizeable defId contextShow clipRect drawfun id itemH@(WItemHandle {wItemId=itemId,wItems=itemHs,wItemKind=IsLayoutControl}) mb_x+			| identifyMaybeId id itemId =+				return (True,itemH,mb_x)+			| otherwise = do+				(found,itemHs,mb_x) <- setWElement (drawInWItem wMetrics wPtr resizeable defId itemShow clipRect1 drawfun) id itemHs mb_x+				return (found,itemH{wItems=itemHs},mb_x)+			where+				itemShow	= contextShow && wItemShow itemH+				clipRect1	= intersectRects clipRect (posSizeToRect (wItemPos itemH) (wItemSize itemH))++		drawInWItem _ _ _ _ _ _ _ id itemH@(WItemHandle {wItemId=itemId}) mb_x =+			return (identifyMaybeId id itemId,itemH,mb_x)++--	Change the state of the slider and handle proper feedback.++setsliderstates :: [(Id,IdFun SliderState)] -> OSWindowMetrics -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+setsliderstates id_fs wMetrics wPtr wH@(WindowHandle {whItems=itemHs,whSize=whSize,whWindowInfo=whWindowInfo}) = do+	(itemHs,_) <- setAllWElements (setSliderState wMetrics wPtr clipRect) itemHs id_fs+	return (wH{whItems=itemHs})+	where+		clipRect	= getContentRect wMetrics whWindowInfo whSize+		+		setSliderState :: OSWindowMetrics -> OSWindowPtr -> Rect -> WElementHandle ls ps -> [(Id,IdFun SliderState)] -> IO (WElementHandle ls ps, [(Id,IdFun SliderState)])+		setSliderState wMetrics wPtr clipRect itemH@(WItemHandle {wItemId=itemId,wItemKind=IsSliderControl,wItemPtr=itemPtr}) id_fs =+			let+				(found,id_f,id_fs1) = removeOnIdOfPair itemId id_fs+				(_,f) = id_f+			in+				if not found then return (itemH,id_fs1)+				else+					let+						info = getWItemSliderInfo (wItemInfo itemH)+						oldState	= sliderInfoState info+						newState	= validateSliderState (f oldState)+						itemH1		= itemH{wItemInfo=WSliderInfo info{sliderInfoState=newState}}+						(tbMin,tbThumb,tbMax,_) = toOSscrollbarRange (sliderMin newState,sliderThumb newState,sliderMax newState) 0+					in do+						osSetSliderThumb wPtr itemPtr clipRect (not (isEmptyRect clipRect)) (tbMin,tbThumb,tbMax)+						return (itemH1,id_fs1)+		+		setSliderState wMetrics wPtr clipRect itemH@(WItemHandle {wItemKind=IsCompoundControl,wItems=itemHs}) id_fs =+			let+				(_,_,id_fs1) = removeOnIdOfPair (wItemId itemH) id_fs+			in do+				(itemHs,id_fs2) <- setAllWElements (setSliderState wMetrics wPtr clipRect1) itemHs id_fs1+				return (itemH{wItems=itemHs},id_fs2)+			where+				info		= getWItemCompoundInfo (wItemInfo itemH)+				clipRect1	= intersectRectContent wMetrics clipRect info (wItemPos itemH) (wItemSize itemH)+		+		setSliderState wMetrics wPtr clipRect itemH@(WItemHandle {wItemKind=IsLayoutControl,wItems=itemHs}) id_fs =+			let+				(_,_,id_fs1) = removeOnIdOfPair (wItemId itemH) id_fs+			in do+				(itemHs,id_fs2)	<- setAllWElements (setSliderState wMetrics wPtr clipRect1) itemHs id_fs1+				return (itemH{wItems=itemHs},id_fs2)+			where+				clipRect1 = intersectRects clipRect (posSizeToRect (wItemPos itemH) (wItemSize itemH))+		+		setSliderState _ _ _ itemH id_fs =+			let+				(_,_,id_fs1) = removeOnIdOfPair (wItemId itemH) id_fs+			in+				return (itemH,id_fs1)+++--	Select a PopUpControl item.+	+selectcontrolitem :: Id -> Index -> OSWindowMetrics -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+selectcontrolitem id index wMetrics wPtr wH@(WindowHandle {whItems=itemHs,whSize=whSize,whWindowInfo=whWindowInfo}) = do+	(_,itemHs,_) <- setWElement (selectWItem wMetrics wPtr index) id itemHs ()+	return (wH{whItems=itemHs})+	where+		selectWItem :: OSWindowMetrics -> OSWindowPtr -> Index -> Id -> WElementHandle ls ps -> s -> IO (Bool,WElementHandle ls ps,s)+		selectWItem wMetrics wPtr index id itemH@(WItemHandle {wItemKind=IsPopUpControl}) s+			| not (identifyMaybeId id (wItemId itemH)) =+				return (False,itemH,s)+			| otherwise =+				let+					info	 	= getWItemPopUpInfo (wItemInfo itemH)+			  		curindex 	= popUpInfoIndex info+			  		nrPopUps 	= length (popUpInfoItems info)+			  		newindex	= setBetween index 1 nrPopUps+					itemH1	 	= itemH{wItemInfo=WPopUpInfo info{popUpInfoIndex=index}}+			  	in+			  		if curindex==newindex then return (True,itemH1,s)+					else do+						osSelectPopUpControlItem wPtr (wItemPtr itemH) newindex+						return (True,itemH1,s)+						+		selectWItem wMetrics wPtr index id itemH@(WItemHandle {wItemKind=IsListBoxControl}) s+			| not (identifyMaybeId id (wItemId itemH)) =+				return (False,itemH,s)+			| otherwise =+				let+					info	 	= getWItemListBoxInfo (wItemInfo itemH)+					items		= listBoxInfoItems info+					nrItems 	= length items+					newindex	= setBetween index 1 nrItems+					items' 		= updateItems items newindex+					itemH1	 	= itemH{wItemInfo=WListBoxInfo info{listBoxInfoItems=items'}}+					+					updateItems [] n = []+					updateItems ((title,mark,f):items) n+						| n==1      = (title,Mark  ,f):items'+						| otherwise = (title,NoMark,f):items'+						where+							items' = updateItems items (n-1)+				in do+					osSelectListBoxControlItem wPtr (wItemPtr itemH) newindex+					return (True,itemH1,s)++		selectWItem wMetrics wPtr index id itemH@(WItemHandle {wItemId=itemId,wItemKind=IsRadioControl}) s+			| not (identifyMaybeId id itemId) =+				return (False,itemH,s)+			| otherwise =+				let+					info		= getWItemRadioInfo (wItemInfo itemH)+					curindex	= radioIndex info+					items		= radioItems info+					nrItems		= length items+					newindex	= setBetween index 1 nrItems					+					itemH1		= itemH{wItemInfo=WRadioInfo info{radioIndex=index}}+				in+					if newindex==curindex then return (True,itemH1,s)+					else do+						osCheckRadioControl wPtr (radioItemPtr (items!!(curindex-1))) False+						osCheckRadioControl wPtr (radioItemPtr (items!!(newindex-1))) True+						return (True,itemH1,s)++		selectWItem wMetrics wPtr index id itemH@(WItemHandle {wItemKind=IsCompoundControl, wItems=itemHs}) s+			| identifyMaybeId id (wItemId itemH) =+				return (True,itemH,s)+			| otherwise = do+				(found,itemHs,s) <- setWElement (selectWItem wMetrics wPtr index) id itemHs s+				return (found,itemH{wItems=itemHs},s)++		selectWItem wMetrics wPtr index id itemH@(WItemHandle {wItemKind=IsLayoutControl, wItems=itemHs}) s+			| identifyMaybeId id (wItemId itemH) =+				return (True,itemH,s)+			| otherwise = do+				(found,itemHs,s) <- setWElement (selectWItem wMetrics wPtr index) id itemHs s+				return (found,itemH{wItems=itemHs},s)++		selectWItem _ _ _ id itemH s =+			return (identifyMaybeId id (wItemId itemH),itemH,s)++--	Add new items to a PopUpControl. ++openpopupitems :: Id -> Index -> [PopUpControlItem ps ps] -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+openpopupitems id index newItems wPtr wH@(WindowHandle {whItems=itemHs}) = do+	(_,itemHs) <- openWElementsPopUpItems wPtr index newItems id itemHs+	return (wH{whItems=itemHs})+	where+		openWElementsPopUpItems :: OSWindowPtr -> Index -> [PopUpControlItem ps ps] -> Id -> [WElementHandle ls ps] -> IO (Bool,[WElementHandle ls ps])+		openWElementsPopUpItems wPtr index newItems id [] = return (False,[])+		openWElementsPopUpItems wPtr index newItems id (itemH:itemHs) = do+			(done,itemH) <- openWElementPopUpItems wPtr index newItems id itemH+			(if done then return (done,itemH:itemHs)+			 else do+				(done,itemHs) <- openWElementsPopUpItems wPtr index newItems id itemHs+				return (done,itemH:itemHs))+			where+				openWElementPopUpItems :: OSWindowPtr -> Index -> [PopUpControlItem ps ps] -> Id -> WElementHandle ls ps -> IO (Bool,WElementHandle ls ps)+				openWElementPopUpItems wPtr id index newItems itemH@(WItemHandle {}) = do+					openWItemPopUpItems wPtr id index newItems itemH+					where+						openWItemPopUpItems :: OSWindowPtr -> Index -> [PopUpControlItem ps ps] -> Id -> WElementHandle ls ps -> IO (Bool,WElementHandle ls ps)+						openWItemPopUpItems wPtr index items id itemH@(WItemHandle {wItemKind=IsPopUpControl})+							| not (identifyMaybeId id (wItemId itemH)) =+								return (False,itemH)+							| otherwise = do+								(newPopUpPtr,editPtr) <- osCreateEmptyPopUpControl wPtr (0,0) (wItemShow itemH) ableContext (toTuple popUpPos) (toTuple popUpSize) (length newItems) isEditable+								foldrM (appendPopUp newPopUpPtr newIndex) 1 newItems+								osStackWindow newPopUpPtr popUpPtr (\x -> return ())+								osDestroyPopUpControl popUpPtr+							  	let newPopUpInfo = PopUpInfo+							  		{ popUpInfoItems = newItems+									, popUpInfoIndex = newIndex+									, popUpInfoEdit  = if isEditable then Just curEditInfo{popUpEditPtr=editPtr} else Nothing+									}+							  	let itemH1 = itemH{wItemInfo=WPopUpInfo newPopUpInfo,wItemPtr=newPopUpPtr}+								(if not hasTip then return (True,itemH1)+								 else do							+									osAddControlToolTip wPtr newPopUpPtr (getControlTipAtt tipAtt)+									return (True,itemH1))+							where+								(hasTip,tipAtt)	= cselect isControlTip undefined (wItemAtts itemH)+								isEditable	= any isControlKeyboard (wItemAtts itemH)+								ableContext	= wItemSelect itemH+								popUpPtr	= wItemPtr itemH+								popUpSize	= wItemSize itemH+								popUpPos	= wItemPos itemH+								popUpInfo	= getWItemPopUpInfo (wItemInfo itemH)+								curEditInfo	= fromJust (popUpInfoEdit popUpInfo)+								curIndex	= popUpInfoIndex popUpInfo+								curItems	= popUpInfoItems popUpInfo+								newItems	= before++[(title,noLS f) | (title,f)<-items]++after+								newIndex	= if curIndex<=index then curIndex else curIndex+index+								(before,after)	= split index curItems++								appendPopUp :: OSWindowPtr -> Index -> PopUpControlItem ps st -> Int -> IO Int+								appendPopUp popUpPtr index (title,_) itemNr = do+									osAddPopUpControlItem popUpPtr title (index==itemNr)+									return (itemNr+1)++						openWItemPopUpItems wPtr index newItems id itemH@(WItemHandle {wItemId=itemId,wItems=itemHs})+							| identifyMaybeId id itemId =+								return (True,itemH)+							| otherwise = do+								(done,itemHs) <- openWElementsPopUpItems wPtr index newItems id itemHs+								return (done,itemH{wItems=itemHs})++				openWElementPopUpItems wPtr index newItems id (WListLSHandle itemHs) = do+					(done,itemHs) <- openWElementsPopUpItems wPtr index newItems id itemHs+					return (done,WListLSHandle itemHs)++				openWElementPopUpItems wPtr index newItems id (WExtendLSHandle exLS itemHs) = do+					(done,itemHs) <- openWElementsPopUpItems wPtr index newItems id itemHs+					return (done,WExtendLSHandle exLS itemHs)++				openWElementPopUpItems wPtr index newItems id (WChangeLSHandle chLS itemHs) = do+					(done,itemHs) <- openWElementsPopUpItems wPtr index newItems id itemHs+					return (done,WChangeLSHandle chLS itemHs)+++--	Remove items from a PopUpControl. ++closepopupitems :: Id -> [Index] -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+closepopupitems id indices wPtr wH@(WindowHandle {whItems=itemHs}) = do+	(_,itemHs) <- closeWElementsPopUpItems wPtr indices id itemHs+	return (wH{whItems=itemHs})+	where+		closeWElementsPopUpItems :: OSWindowPtr -> [Index] -> Id -> [WElementHandle ls ps] -> IO (Bool,[WElementHandle ls ps])+		closeWElementsPopUpItems wPtr indices id [] 		= return (False,[])+		closeWElementsPopUpItems wPtr indices id (itemH:itemHs)  = do+			(done,itemH) <- closeWElementPopUpItems wPtr indices id itemH+			(if done then return (done,itemH:itemHs)+			 else do+				(done,itemHs) <- closeWElementsPopUpItems wPtr indices id itemHs+				return (done,itemH:itemHs))+			where+				closeWElementPopUpItems :: OSWindowPtr -> [Index] -> Id -> WElementHandle ls ps -> IO (Bool,WElementHandle ls ps)+				closeWElementPopUpItems wPtr indices id itemH@(WItemHandle {wItemKind=itemKind,wItems=itemHs})+					| itemKind == IsPopUpControl =+						if not (identifyMaybeId id (wItemId itemH)) then return (False,itemH)+						else do+							(newPopUpPtr,editPtr) <- osCreateEmptyPopUpControl wPtr (0,0) (wItemShow itemH) ableContext (toTuple popUpPos) (toTuple popUpSize) (length newItems) isEditable+							foldrM (appendPopUp newPopUpPtr newIndex) 1 newItems+							osStackWindow newPopUpPtr popUpPtr (\x -> return ())+							osDestroyPopUpControl popUpPtr+							let newPopUpInfo = PopUpInfo+								{ popUpInfoItems = newItems+								, popUpInfoIndex = newIndex+								, popUpInfoEdit  = if isEditable then Just curEditInfo{popUpEditPtr=editPtr} else Nothing+								}+							let itemH1 = itemH{wItemInfo=WPopUpInfo newPopUpInfo,wItemPtr=newPopUpPtr}+							(if not hasTip then return (True,itemH1)+							 else do+								osAddControlToolTip wPtr newPopUpPtr (getControlTipAtt tipAtt)+								return (True,itemH1))+					| otherwise = +						if identifyMaybeId id (wItemId itemH) then return (True,itemH)+						else do+						  	(done,itemHs) <- closeWElementsPopUpItems wPtr indices id itemHs+							return (done,itemH{wItems=itemHs})+					where+						(hasTip,tipAtt)	= cselect isControlTip undefined (wItemAtts itemH)+						isEditable	= any isControlKeyboard (wItemAtts itemH)+						ableContext	= wItemSelect itemH+						popUpPtr	= wItemPtr itemH+						popUpSize	= wItemSize itemH+						popUpPos	= wItemPos itemH+						popUpInfo	= getWItemPopUpInfo (wItemInfo itemH)+						curEditInfo	= fromJust (popUpInfoEdit popUpInfo)+						curIndex	= popUpInfoIndex popUpInfo+						curItems	= popUpInfoItems popUpInfo+						newItems	= map snd (filter (\(i,_)->not (i `elem` indices)) (zip [1..] curItems))+						nrNewItems	= length newItems+						newIndex	= if curIndex `elem` indices then 1 else min nrNewItems curIndex++						appendPopUp :: OSWindowPtr -> Index -> PopUpControlItem ps st -> Int -> IO Int+						appendPopUp popUpPtr index (title,_) itemNr = do+							osAddPopUpControlItem popUpPtr title (index==itemNr)+							return (itemNr+1)					++				closeWElementPopUpItems wPtr indices id (WListLSHandle itemHs) = do+					(done,itemHs) <- closeWElementsPopUpItems wPtr indices id itemHs+					return (done,WListLSHandle itemHs)++				closeWElementPopUpItems wPtr indices id (WExtendLSHandle exLS itemHs) = do+					(done,itemHs) <- closeWElementsPopUpItems wPtr indices id itemHs+					return (done,WExtendLSHandle exLS itemHs)++				closeWElementPopUpItems wPtr indices id (WChangeLSHandle chLS itemHs) = do+					(done,itemHs) <- closeWElementsPopUpItems wPtr indices id itemHs+					return (done,WChangeLSHandle chLS itemHs)+++--	Add new items to a ListBoxControl. ++openlistboxitems :: Id -> Index -> [ListBoxControlItem ps ps] -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+openlistboxitems id index newItems wPtr wH@(WindowHandle {whItems=itemHs}) = do+	(_,itemHs) <- openWElementsListBoxItems wPtr index newItems id itemHs+	return (wH{whItems=itemHs})+	where+		openWElementsListBoxItems :: OSWindowPtr -> Index -> [ListBoxControlItem ps ps] -> Id -> [WElementHandle ls ps] -> IO (Bool,[WElementHandle ls ps])+		openWElementsListBoxItems wPtr index newItems id [] = return (False,[])+		openWElementsListBoxItems wPtr index newItems id (itemH:itemHs) = do+			(done,itemH) <- openWElementListBoxItems wPtr index newItems id itemH+			(if done then return (done,itemH:itemHs)+			 else do+				(done,itemHs) <- openWElementsListBoxItems wPtr index newItems id itemHs+				return (done,itemH:itemHs))+			where+				openWElementListBoxItems :: OSWindowPtr -> Index -> [ListBoxControlItem ps ps] -> Id -> WElementHandle ls ps -> IO (Bool,WElementHandle ls ps)+				openWElementListBoxItems wPtr id index newItems itemH@(WItemHandle {}) = do+					openWItemListBoxItems wPtr id index newItems itemH+					where+						openWItemListBoxItems :: OSWindowPtr -> Index -> [ListBoxControlItem ps ps] -> Id -> WElementHandle ls ps -> IO (Bool,WElementHandle ls ps)+						openWItemListBoxItems wPtr index items id itemH@(WItemHandle {wItemKind=IsListBoxControl})+							| not (identifyMaybeId id (wItemId itemH)) =+								return (False,itemH)+							| otherwise = do+								newLBoxPtr <- osCreateEmptyListBoxControl wPtr (0,0) (wItemShow itemH) ableContext (toTuple lboxPos) (toTuple lboxSize) (listBoxInfoMultiSel info)+								mapM_ (appendListBox newLBoxPtr) newItems+								osStackWindow newLBoxPtr lboxPtr (\x -> return ())+								osDestroyListBoxControl lboxPtr+							  	let newListBoxInfo = info{listBoxInfoItems = newItems}+							  	let itemH1 = itemH{wItemInfo=WListBoxInfo newListBoxInfo,wItemPtr=newLBoxPtr}+								(if not hasTip then return (True,itemH1)+								 else do							+									osAddControlToolTip wPtr newLBoxPtr (getControlTipAtt tipAtt)+									return (True,itemH1))+							where+								(hasTip,tipAtt)	= cselect isControlTip undefined (wItemAtts itemH)+								ableContext	= wItemSelect itemH+								lboxPtr		= wItemPtr itemH+								lboxSize	= wItemSize itemH+								lboxPos		= wItemPos itemH+								info		= getWItemListBoxInfo (wItemInfo itemH)+								curItems	= listBoxInfoItems info+								newItems	= before++[(title,mark,noLS f) | (title,mark,f)<-items]++after+								(before,after)	= split index curItems++								appendListBox :: OSWindowPtr -> ListBoxControlItem ps st -> IO ()+								appendListBox lboxPtr (title,mark,_) = do+									osAddListBoxControlItem lboxPtr title (marked mark)+									return ()++						openWItemListBoxItems wPtr index newItems id itemH@(WItemHandle {wItemId=itemId,wItems=itemHs})+							| identifyMaybeId id itemId =+								return (True,itemH)+							| otherwise = do+								(done,itemHs) <- openWElementsListBoxItems wPtr index newItems id itemHs+								return (done,itemH{wItems=itemHs})++				openWElementListBoxItems wPtr index newItems id (WListLSHandle itemHs) = do+					(done,itemHs) <- openWElementsListBoxItems wPtr index newItems id itemHs+					return (done,WListLSHandle itemHs)++				openWElementListBoxItems wPtr index newItems id (WExtendLSHandle exLS itemHs) = do+					(done,itemHs) <- openWElementsListBoxItems wPtr index newItems id itemHs+					return (done,WExtendLSHandle exLS itemHs)++				openWElementListBoxItems wPtr index newItems id (WChangeLSHandle chLS itemHs) = do+					(done,itemHs) <- openWElementsListBoxItems wPtr index newItems id itemHs+					return (done,WChangeLSHandle chLS itemHs)+++--	Remove items from a PopUpControl. ++closelistboxitems :: Id -> [Index] -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+closelistboxitems id indices wPtr wH@(WindowHandle {whItems=itemHs}) = do+	(_,itemHs) <- closeWElementsListBoxItems wPtr indices id itemHs+	return (wH{whItems=itemHs})+	where+		closeWElementsListBoxItems :: OSWindowPtr -> [Index] -> Id -> [WElementHandle ls ps] -> IO (Bool,[WElementHandle ls ps])+		closeWElementsListBoxItems wPtr indices id [] 		= return (False,[])+		closeWElementsListBoxItems wPtr indices id (itemH:itemHs)  = do+			(done,itemH) <- closeWElementListBoxItems wPtr indices id itemH+			(if done then return (done,itemH:itemHs)+			 else do+				(done,itemHs) <- closeWElementsListBoxItems wPtr indices id itemHs+				return (done,itemH:itemHs))+			where+				closeWElementListBoxItems :: OSWindowPtr -> [Index] -> Id -> WElementHandle ls ps -> IO (Bool,WElementHandle ls ps)+				closeWElementListBoxItems wPtr indices id itemH@(WItemHandle {wItemKind=itemKind,wItems=itemHs})+					| itemKind == IsListBoxControl =+						if not (identifyMaybeId id (wItemId itemH)) then return (False,itemH)+						else do+							newLBoxPtr <- osCreateEmptyListBoxControl wPtr (0,0) (wItemShow itemH) ableContext (toTuple lboxPos) (toTuple lboxSize) (listBoxInfoMultiSel info)+							mapM_ (appendPopUp newLBoxPtr) newItems+							osStackWindow newLBoxPtr lboxPtr (\x -> return ())+							osDestroyListBoxControl lboxPtr+							let newListBoxInfo = info{listBoxInfoItems = newItems}+							let itemH1 = itemH{wItemInfo=WListBoxInfo newListBoxInfo,wItemPtr=newLBoxPtr}+							(if not hasTip then return (True,itemH1)+							 else do+								osAddControlToolTip wPtr newLBoxPtr (getControlTipAtt tipAtt)+								return (True,itemH1))+					| otherwise = +						if identifyMaybeId id (wItemId itemH) then return (True,itemH)+						else do+						  	(done,itemHs) <- closeWElementsListBoxItems wPtr indices id itemHs+							return (done,itemH{wItems=itemHs})+					where+						(hasTip,tipAtt)	= cselect isControlTip undefined (wItemAtts itemH)						+						ableContext	= wItemSelect itemH+						lboxPtr		= wItemPtr itemH+						lboxSize	= wItemSize itemH+						lboxPos		= wItemPos itemH+						info		= getWItemListBoxInfo (wItemInfo itemH)+						curItems	= listBoxInfoItems info+						newItems	= map snd (filter (\(i,_)->not (i `elem` indices)) (zip [1..] curItems))+						nrNewItems	= length newItems++						appendPopUp :: OSWindowPtr -> ListBoxControlItem ps st -> IO ()+						appendPopUp lboxPtr (title,mark,_) = do+							osAddListBoxControlItem lboxPtr title (marked mark)+							return ()++				closeWElementListBoxItems wPtr indices id (WListLSHandle itemHs) = do+					(done,itemHs) <- closeWElementsListBoxItems wPtr indices id itemHs+					return (done,WListLSHandle itemHs)++				closeWElementListBoxItems wPtr indices id (WExtendLSHandle exLS itemHs) = do+					(done,itemHs) <- closeWElementsListBoxItems wPtr indices id itemHs+					return (done,WExtendLSHandle exLS itemHs)++				closeWElementListBoxItems wPtr indices id (WChangeLSHandle chLS itemHs) = do+					(done,itemHs) <- closeWElementsListBoxItems wPtr indices id itemHs+					return (done,WChangeLSHandle chLS itemHs)+++{-	The record MetricsInfo and the functions shiftControls` and setsliderthumb are used by+	movecontrolviewframe and setcontrolviewdomain.+-}++data MetricsInfo+   = MetricsInfo+	{ miOSMetrics	:: !OSWindowMetrics+	, miHMargins	:: !(Int,Int)+	, miVMargins	:: !(Int,Int)+	, miItemSpaces	:: !(Int,Int)+	, miOrientation	:: ![(ViewDomain,Origin)]+	}++shiftControls :: Vector2 -> [WElementHandle ls ps] -> [WElementHandle ls ps]+shiftControls v [] = []+shiftControls v (itemH:itemHs) = shiftControl v itemH : shiftControls v itemHs+	where+		shiftControl :: Vector2 -> WElementHandle ls ps -> WElementHandle ls ps+		shiftControl v itemH@(WItemHandle {wItemPos=itemPos,wItems=itemHs}) =+			itemH{wItemPos=movePoint v itemPos, wItems=shiftControls v itemHs}+		shiftControl v (WListLSHandle itemHs) =+			WListLSHandle (shiftControls v itemHs)+		shiftControl v (WExtendLSHandle exLS itemHs) =+			WExtendLSHandle exLS (shiftControls v itemHs)+		shiftControl v (WChangeLSHandle chLS itemHs) =+			WChangeLSHandle chLS (shiftControls v itemHs)++setsliderthumb :: Bool -> OSWindowMetrics -> OSWindowPtr -> Bool -> (Int,Int,Int) -> Int -> Size -> IO ()+setsliderthumb hasScroll wMetrics itemPtr isHScroll scrollValues viewSize maxcoords+	| not hasScroll	= return ()+	| otherwise	= osSetCompoundSlider wMetrics itemPtr isHScroll (toOSscrollbarRange scrollValues viewSize) (toTuple maxcoords)+++{-	Move the ViewFrame of a CompoundControl. (In future version also customised controls.)+-}+movecontrolviewframe :: Id -> Vector2 -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> IO (WindowHandle ls ps)+movecontrolviewframe id v wMetrics wids wH@(WindowHandle {whKind=whKind,whItems=itemHs,whSize=whSize,whAtts=whAtts,whSelect=whSelect,whDefaultId=whDefaultId,whWindowInfo=windowInfo}) = do+	let metricsInfo	= MetricsInfo {miOSMetrics=wMetrics,miHMargins=hMargins,miVMargins=vMargins,miItemSpaces=spaces,miOrientation=orientation}+	(_,itemHs,mb_updRgn) <- setWElement (moveWItemFrame metricsInfo (wPtr wids) whDefaultId True whSelect clipRect v) id itemHs Nothing+	let wH1 = wH{whItems=itemHs}+	(if isNothing mb_updRgn then return wH1+	 else do+		let updRgn = fromJust mb_updRgn+		empty <- osIsEmptyRgn updRgn+		(if empty+		 then do+			osDisposeRgn updRgn+			return wH1+		 else updateWindowBackgrounds wMetrics updRgn wids wH1))+	where+		(domainRect,origin,defHMargin,defVMargin) = +			if whKind==IsDialog+			then (sizeToRect whSize,zero,osmHorMargin wMetrics,osmVerMargin wMetrics)+			else (windowDomain windowInfo,windowOrigin windowInfo,0,0)+		(defHSpace, defVSpace)	= (osmHorItemSpace wMetrics,osmVerItemSpace wMetrics)+		hMargins		= getWindowHMarginAtt   (snd (cselect isWindowHMargin   (WindowHMargin defHMargin defHMargin) whAtts))+		vMargins		= getWindowVMarginAtt   (snd (cselect isWindowVMargin   (WindowVMargin defVMargin defVMargin) whAtts))+		spaces			= getWindowItemSpaceAtt (snd (cselect isWindowItemSpace (WindowItemSpace defHSpace defVSpace) whAtts))+		clipRect		= getContentRect wMetrics windowInfo whSize+		orientation		= [(rectToRectangle domainRect,origin)]++		moveWItemFrame :: MetricsInfo -> OSWindowPtr -> Maybe Id -> Bool -> Bool -> Rect -> Vector2 -> Id -> WElementHandle ls ps -> Maybe OSRgnHandle -> IO (Bool,WElementHandle ls ps,Maybe OSRgnHandle)+		moveWItemFrame metricsInfo@(MetricsInfo {miOSMetrics=miOSMetrics,miHMargins=miHMargins,miVMargins=miVMargins,miItemSpaces=miItemSpaces,miOrientation=miOrientation}) wPtr defaultId shownContext ableContext clipRect v id itemH@(WItemHandle {wItemId=itemId,wItemKind=itemKind}) updRgn+			| not (isRecursiveControl itemKind) =+				return (identifyMaybeId id itemId,itemH,updRgn)+			| itemKind==IsLayoutControl =+				if identifyMaybeId id itemId+				then return (True,itemH,updRgn)+				else do+					let metricsInfo1 = metricsInfo{miHMargins=hMargins,miVMargins=vMargins,miItemSpaces=spaces}+					let clipRect1	 = intersectRects clipRect (posSizeToRect itemPos itemSize)+					(done,itemHs,updRgn) <- setWElement (moveWItemFrame metricsInfo1 wPtr defaultId shownContext1 ableContext1 clipRect1 v) id (wItems itemH) updRgn+					return (done,itemH{wItems=itemHs},updRgn)+			| not (identifyMaybeId id itemId) = do+				let orientation1 = (domain,oldOrigin):miOrientation+				let clipRect1	 = intersectRects contentRect clipRect+				let metricsInfo1 = metricsInfo{miHMargins=hMargins,miVMargins=vMargins,miItemSpaces=spaces,miOrientation=orientation}+				(done,itemHs,updRgn) <- setWElement (moveWItemFrame metricsInfo1 wPtr defaultId shownContext1 ableContext1 clipRect1 v) id (wItems itemH) updRgn+				return (done,itemH{wItems=itemHs},updRgn)+			| newOrigin==oldOrigin =+				return (True,itemH,updRgn)+			| otherwise = do+				setsliderthumb (hasHScroll && x newOrigin /= x oldOrigin) miOSMetrics itemPtr True  (minx,x newOrigin,maxx) viewx itemSize+				setsliderthumb (hasVScroll && y newOrigin /= y oldOrigin) miOSMetrics itemPtr False (miny,y newOrigin,maxy) viewy itemSize+			  	let info1 = info{compoundOrigin=newOrigin}+			  	let clipRect1 = intersectRects contentRect clipRect+				(if null (wItems itemH)+				 then do+					let itemH1 = itemH{wItemInfo=WCompoundInfo info1}+					itemH2 <- drawCompoundLook miOSMetrics ableContext1 wPtr clipRect1 itemH1+					return (True,itemH2,updRgn)+				 else do+					let oldItems	= wItems itemH+				  	let orientation	= (domain,newOrigin):miOrientation+					(_,newItems) <- layoutControls miOSMetrics hMargins vMargins spaces itemSize itemSize orientation oldItems+				  	let newItems = shiftControls (toVector itemPos) newItems+				  	let itemH1 = itemH{wItems=newItems,wItemInfo=WCompoundInfo info}+				  	maybe (return ()) osDisposeRgn updRgn+					itemH2 <- forceValidCompoundClipState miOSMetrics True wPtr defaultId shownContext itemH1+					updRgn <- relayoutControls miOSMetrics ableContext1 shownContext1 contentRect contentRect itemPos itemPos itemPtr defaultId oldItems (wItems itemH)+					itemH3 <- drawCompoundLook miOSMetrics ableContext1 wPtr clipRect1 itemH2+					return (True,itemH3,Just updRgn))+			where+				info			= getWItemCompoundInfo (wItemInfo itemH)+				oldOrigin		= compoundOrigin info+				domainRect		= compoundDomain info+				domain			= rectToRectangle domainRect+				itemPtr			= wItemPtr itemH+				itemPos			= wItemPos itemH+				itemSize		= wItemSize itemH+				itemAtts		= wItemAtts itemH+				(hasHScroll,hasVScroll)	= (isJust (compoundHScroll info),isJust (compoundVScroll info))+				visScrolls		= osScrollbarsAreVisible miOSMetrics domainRect (toTuple itemSize) (hasHScroll,hasVScroll)+				contentRect		= getCompoundContentRect miOSMetrics visScrolls (posSizeToRect itemPos itemSize)+				contentSize		= rectSize contentRect+				shownContext1		= if shownContext then wItemShow itemH else shownContext+				ableContext1		= ableContext && wItemSelect itemH+				hMargins		= getControlHMarginAtt (snd (cselect isControlHMargin (ControlHMargin (fst miHMargins) (snd miHMargins)) itemAtts))+				vMargins		= getControlVMarginAtt (snd (cselect isControlVMargin (ControlVMargin (fst miVMargins) (snd miVMargins)) itemAtts))+				spaces			= getControlItemSpaceAtt (snd (cselect isControlItemSpace (ControlItemSpace (fst miItemSpaces) (snd miItemSpaces)) itemAtts))+				(minx,maxx,viewx)	= (rleft domainRect,rright  domainRect, w contentSize)+				(miny,maxy,viewy)	= (rtop  domainRect,rbottom domainRect, h contentSize)+				newOrigin		= Point2{x=setBetween (x oldOrigin+vx v) minx (maxx-viewx),y=setBetween (y oldOrigin+vy v) miny (maxy-viewy)}+++--	Set the ViewDomain of a CompoundControl. (In future versions also customised controls.)++setcontrolviewdomain :: Id -> ViewDomain -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> IO (WindowHandle ls ps)+setcontrolviewdomain id newDomain wMetrics wids wH@(WindowHandle {whKind=whKind,whItems=itemHs,whSize=whSize,whAtts=whAtts,whSelect=whSelect,whDefaultId=whDefaultId,whWindowInfo=windowInfo}) = do+	let metricsInfo	= MetricsInfo {miOSMetrics=wMetrics,miHMargins=hMargins,miVMargins=vMargins,miItemSpaces=spaces,miOrientation=orientation}+	(_,itemHs,mb_updRgn) <- setWElement (setWItemDomain metricsInfo (wPtr wids) whDefaultId True whSelect clipRect (validateViewDomain newDomain)) id itemHs Nothing+	let wH1 = wH{whItems=itemHs}+	(case mb_updRgn of+		Nothing -> return wH+		Just updRgn -> do+			empty <- osIsEmptyRgn updRgn+			(if empty then do+				osDisposeRgn updRgn+				return wH1+			 else updateWindowBackgrounds wMetrics updRgn wids wH1))+	where+		(domainRect,origin,defHMargin,defVMargin)+				= if whKind==IsDialog+				  then (sizeToRect whSize,zero,osmHorMargin wMetrics,osmVerMargin wMetrics)+				  else (windowDomain windowInfo,windowOrigin windowInfo,0,0)+		(defHSpace, defVSpace)	= (osmHorItemSpace wMetrics,osmVerItemSpace wMetrics)+		hMargins	= getWindowHMarginAtt (snd (cselect isWindowHMargin (WindowHMargin defHMargin defHMargin) whAtts))+		vMargins	= getWindowVMarginAtt (snd (cselect isWindowVMargin (WindowVMargin defVMargin defVMargin) whAtts))+		spaces		= getWindowItemSpaceAtt (snd (cselect isWindowItemSpace (WindowItemSpace defHSpace defVSpace) whAtts))+		clipRect	= getContentRect wMetrics windowInfo whSize+		orientation	= [(rectToRectangle domainRect,origin)]++		setWItemDomain :: MetricsInfo -> OSWindowPtr -> Maybe Id -> Bool -> Bool -> Rect -> ViewDomain -> Id -> WElementHandle ls ps -> Maybe OSRgnHandle -> IO (Bool,WElementHandle ls ps ,Maybe OSRgnHandle)+		setWItemDomain metricsInfo@(MetricsInfo {miOSMetrics=miOSMetrics,miHMargins=miHMargins,miVMargins=miVMargins,miItemSpaces=miItemSpaces,miOrientation=miOrientation}) wPtr defaultId shownContext ableContext clipRect newDomain id itemH@(WItemHandle {wItemId=itemId,wItemKind=wItemKind}) mb_updRgn+			| not (isRecursiveControl wItemKind) =+				return (identifyMaybeId id itemId,itemH,mb_updRgn)+			| wItemKind == IsLayoutControl =+				if identifyMaybeId id itemId +				then return (True,itemH,mb_updRgn)+				else do+					let metricsInfo1 = metricsInfo{miHMargins=hMargins,miVMargins=vMargins,miItemSpaces=spaces}+					let clipRect1 = intersectRects clipRect (posSizeToRect itemPos itemSize)+					(done,itemHs,mb_updRgn) <- setWElement (setWItemDomain metricsInfo1 wPtr defaultId shownContext1 ableContext1 clipRect1 newDomain) id (wItems itemH) mb_updRgn+					return (done,itemH{wItems=itemHs},mb_updRgn)+			| not (identifyMaybeId id (wItemId itemH)) =+				let+					orientation  = (oldDomain,oldOrigin):miOrientation+					clipRect1    = intersectRects oldContentRect clipRect+					metricsInfo1 = metricsInfo{miHMargins=hMargins,miVMargins=vMargins,miItemSpaces=spaces,miOrientation=orientation}+				in do+					(done,itemHs,mb_updRgn) <- setWElement (setWItemDomain metricsInfo1 wPtr defaultId shownContext1 ableContext1 clipRect1 newDomain) id (wItems itemH) mb_updRgn+					return (done,itemH{wItems=itemHs},mb_updRgn)+			| newDomain == oldDomain =+				return (True,itemH,mb_updRgn)+			| otherwise = do+				let (minx,maxx,viewx) = (rleft newDomainRect,rright newDomainRect, w newContentSize)+			  	let (miny,maxy,viewy) = (rtop newDomainRect, rbottom newDomainRect,h newContentSize)+			  	let newOrigin	      = Point2 {x=setBetween (x oldOrigin) minx (max minx (maxx-viewx)),y=setBetween (y oldOrigin) miny (max miny (maxy-viewy))}+			  	let info1 = info{compoundOrigin=newOrigin,compoundDomain=newDomainRect}+				setsliderthumb hasHScroll miOSMetrics itemPtr True  (minx,x newOrigin,maxx) viewx itemSize+				setsliderthumb hasVScroll miOSMetrics itemPtr False (miny,y newOrigin,maxy) viewy itemSize+			  	let oldItems = wItems itemH+				(if null oldItems		-- CompoundControl has no controls+				 then let itemH1 = itemH{wItemInfo=WCompoundInfo info1}+				      in if shownContext1+					 then do+						itemH2 <- drawCompoundLook miOSMetrics ableContext1 wPtr (intersectRects newContentRect clipRect) itemH+						return (True,itemH2,mb_updRgn)+					 else return (True,itemH1,mb_updRgn)+				 else do				-- CompoundControl has controls+					let orientation = (newDomain,newOrigin):miOrientation+					(_,newItems) <- layoutControls miOSMetrics hMargins vMargins spaces itemSize itemSize orientation oldItems+			  		let newItems1 = shiftControls (toVector itemPos) newItems+			  		let itemH1 = itemH{wItems=newItems1,wItemInfo=WCompoundInfo info1}+					maybe (return ()) osDisposeRgn mb_updRgn+					itemH2 <- forceValidCompoundClipState miOSMetrics True wPtr defaultId shownContext itemH1+					updRgn <- relayoutControls miOSMetrics ableContext1 shownContext1 newContentRect newContentRect itemPos itemPos itemPtr defaultId oldItems (wItems itemH)+					(if shownContext1+					 then do+						itemH <- drawCompoundLook miOSMetrics ableContext1 wPtr (intersectRects newContentRect clipRect) itemH+						return (True,itemH,Just updRgn)+					 else+						return (True,itemH,Just updRgn)))+			where+				info			= getWItemCompoundInfo (wItemInfo itemH)+				oldOrigin		= compoundOrigin info+				oldDomainRect		= compoundDomain info+				oldDomain		= rectToRectangle oldDomainRect+				newDomainRect		= rectangleToRect newDomain+				itemPtr			= wItemPtr itemH+				itemPos			= wItemPos itemH+				itemSize		= wItemSize itemH				+				itemAtts		= wItemAtts itemH+				itemRect		= posSizeToRect itemPos itemSize+				(hasHScroll,hasVScroll)	= (isJust (compoundHScroll info),isJust (compoundVScroll info))+				oldVisScrolls		= osScrollbarsAreVisible miOSMetrics oldDomainRect (toTuple itemSize) (hasHScroll,hasVScroll)+				newVisScrolls		= osScrollbarsAreVisible miOSMetrics newDomainRect (toTuple itemSize) (hasHScroll,hasVScroll)+				oldContentRect		= getCompoundContentRect miOSMetrics oldVisScrolls itemRect+				newContentRect		= getCompoundContentRect miOSMetrics newVisScrolls itemRect+				newContentSize		= rectSize newContentRect+				shownContext1		= if shownContext then wItemShow itemH else shownContext+				ableContext1		= ableContext && wItemSelect itemH+				hMargins		= getControlHMarginAtt (snd (cselect isControlHMargin   (ControlHMargin   (fst miHMargins)   (snd miHMargins))   itemAtts))+				vMargins		= getControlVMarginAtt (snd (cselect isControlVMargin   (ControlVMargin   (fst miVMargins)   (snd miVMargins))   itemAtts))+				spaces			= getControlItemSpaceAtt (snd (cselect isControlItemSpace (ControlItemSpace (fst miItemSpaces) (snd miItemSpaces)) itemAtts))++setcontrolscrollfun	:: Id -> Direction -> ScrollFunction -> WindowHandle ls ps -> IO (WindowHandle ls ps)+setcontrolscrollfun id direction scrollFun wH@(WindowHandle {whItems=itemHs}) = do+	(_,itemHs,_) <- setWElement (setCompoundScrollFun direction scrollFun) id itemHs 0+	return wH{whItems=itemHs}+	where+		setCompoundScrollFun :: Direction -> ScrollFunction -> Id -> WElementHandle ls ps -> s -> IO (Bool,WElementHandle ls ps,s)+		setCompoundScrollFun direction scrollFun id itemH@(WItemHandle {wItemId=itemId,wItemKind=IsCompoundControl}) s+			| not (identifyMaybeId id itemId) = do+				(found,itemHs,s) <- setWElement (setCompoundScrollFun direction scrollFun) id (wItems itemH) s+				return (found,itemH{wItems=itemHs},s)+			| direction==Horizontal && isJust hScroll = do+				let info1 = info{compoundHScroll=fmap (setScrollFun scrollFun) hScroll}+				return (True,itemH{wItemInfo=WCompoundInfo info1},s)+			| direction==Vertical && isJust vScroll = do+				let info1 = info{compoundVScroll=fmap (setScrollFun scrollFun) vScroll}+				return (True,itemH{wItemInfo=WCompoundInfo info1},s)+			| otherwise =+				return (True,itemH,s)+			where+				info	= getWItemCompoundInfo (wItemInfo itemH)+				hScroll	= compoundHScroll info+				vScroll	= compoundVScroll info++				setScrollFun :: ScrollFunction -> ScrollInfo -> ScrollInfo+				setScrollFun f scrollInfo = scrollInfo{scrollFunction=f}++		setCompoundScrollFun direction scrollFun id itemH@(WItemHandle {wItemId=itemId,wItems=itemHs}) s+			| identifyMaybeId id itemId =+				return (True,itemH,s)+			| otherwise = do+				(found,itemHs,s) <- setWElement (setCompoundScrollFun direction scrollFun) id itemHs s+				return (found,itemH{wItems=itemHs},s)++++--	Higher order monadic access functions on [WElementHandle ls ps]++type MapFunction  ps s = forall ls .       WElementHandle ls ps -> s -> IO (     WElementHandle ls ps,s)+type Map2Function ps s = forall ls . Id -> WElementHandle ls ps -> s -> IO (Bool,WElementHandle ls ps,s)++setAllWElements :: MapFunction ps s -> [WElementHandle ls ps] -> s -> IO ([WElementHandle ls ps],s)+setAllWElements f (itemH:itemHs) s = do+	(itemH, s) <- setWElement     f itemH  s+	(itemHs,s) <- setAllWElements f itemHs s+	return (itemH:itemHs,s)+	where+		setWElement :: MapFunction ps s -> WElementHandle ls ps -> s -> IO (WElementHandle ls ps, s)+		setWElement f itemH@(WItemHandle {}) s = f itemH s+		setWElement f (WListLSHandle itemHs) s = do+			(itemHs,s) <- setAllWElements f itemHs s+			return (WListLSHandle itemHs,s)+		setWElement f (WChangeLSHandle chLS itemHs) s = do+			(itemHs,s) <- setAllWElements f itemHs s+			return (WChangeLSHandle chLS itemHs,s)+		setWElement f (WExtendLSHandle exLS itemHs) s = do+			(itemHs,s) <- setAllWElements f itemHs s+			return (WExtendLSHandle exLS itemHs,s)+setAllWElements _ _ s = return ([],s)++setArgWElements :: MapFunction ps [arg] -> [WElementHandle ls ps] -> [arg] -> IO ([WElementHandle ls ps],[arg])+setArgWElements f itemHs args+	| null args || null itemHs+		= return (itemHs,args)+	| otherwise+		= do {+			(itemH1, args1) <- setArgWElements' f itemH   args;+			(itemHs2,args2) <- setArgWElements  f itemHs1 args1;+			return (itemH1 : itemHs2, args2)+		  }+	where+		(itemH:itemHs1)  = itemHs+		+		setArgWElements' :: MapFunction ps [arg] -> WElementHandle ls ps -> [arg] -> IO (WElementHandle ls ps, [arg])+		setArgWElements' f itemH@(WItemHandle {}) args = f itemH args+		setArgWElements' f (WListLSHandle itemHs) args = do+			(itemHs1,args1) <- setArgWElements f itemHs args+			return (WListLSHandle itemHs1,args1)+		setArgWElements' f (WChangeLSHandle chLS itemHs) args = do+			(itemHs1,args1) <- setArgWElements f itemHs args+			return (WChangeLSHandle chLS itemHs1,args1)+		setArgWElements' f (WExtendLSHandle exLS itemHs) args = do+			(itemHs1,args1) <- setArgWElements f itemHs args+			return (WExtendLSHandle exLS itemHs1,args1)+++setWElement :: Map2Function ps s -> Id -> [WElementHandle ls ps] -> s -> IO (Bool,[WElementHandle ls ps],s)+setWElement f id [] s = return (False,[],s)+setWElement f id (itemH:itemHs) s+		= do {+			(done1,itemH1,s) <- setWElement' f id itemH s;+			if   done1+			then return (done1,itemH1:itemHs,s)+			else do {+					(done2,itemHs2,s) <- setWElement f id itemHs s;+					return (done2,itemH1:itemHs2,s);+			     }+		  }+	where+		setWElement' :: Map2Function ps s -> Id -> WElementHandle ls ps -> s -> IO (Bool,WElementHandle ls ps,s)+		setWElement' f id itemH@(WItemHandle {}) s = f id itemH s+		setWElement' f id (WListLSHandle itemHs) s = do+			(done,itemHs1,s) <- setWElement f id itemHs s+			return (done,WListLSHandle itemHs1,s)+		setWElement' f id (WChangeLSHandle chLS itemHs) s = do+			(done,itemHs1,s) <- setWElement f id itemHs s+			return (done,WChangeLSHandle chLS itemHs1,s)+		setWElement' f id (WExtendLSHandle exLS itemHs) s = do+			(done,itemHs1,s) <- setWElement f id itemHs s+			return (done,WExtendLSHandle exLS itemHs1,s)
+ Graphics/UI/ObjectIO/Control/Layout.hs view
@@ -0,0 +1,674 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Layout+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Control.Layout contains the control layout calculation functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Control.Layout ( layoutControls, calcControlsSize ) where+++import Prelude hiding (Either(..))	-- Either = Left | Right must be hidden+import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.Layout+import Graphics.UI.ObjectIO.StdControlAttribute+import Graphics.UI.ObjectIO.Window.Access+import Graphics.UI.ObjectIO.OS.Window+import Data.Unique+++controlLayoutFatalError :: String -> String -> x+controlLayoutFatalError rule message+	= dumpFatalError rule "controlLayout" message+++--	Calculate the precise position (in pixels) of each Control.++layoutControls :: OSWindowMetrics -> (Int,Int) -> (Int,Int) -> (Int,Int) -> Size -> Size -> [(ViewDomain,Point2)] -> [WElementHandle ls ps]+                                                                                                        -> IO (Size, [WElementHandle ls ps])+layoutControls wMetrics hMargins vMargins spaces reqSize minSize orientations itemHs = do+	u <- newUnique+	(layouts,_,_,itemHs2) <- getLayoutItems wMetrics hMargins vMargins spaces orientations [] (toId u) itemHs1;+	let (size,roots)         = layoutItems hMargins vMargins spaces reqSize minSize orientations layouts+	let (_,itemHs3)          = setLayoutItems roots itemHs2+	return (size,itemHs3)+	where+		(_,_,itemHs1) = validateFirstWElementsPos False itemHs++calcControlsSize :: OSWindowMetrics -> (Int,Int) -> (Int,Int) -> (Int,Int) -> Size -> Size -> [(ViewDomain,Point2)] -> [WElementHandle ls ps]+                 -> IO Size+calcControlsSize wMetrics hMargins vMargins spaces reqSize minSize orientations itemHs = do+	u <- newUnique+	(layouts,_,_,_) <- getLayoutItems wMetrics hMargins vMargins spaces orientations [] (toId u) itemHs1;+	return (fst (layoutItems hMargins vMargins spaces reqSize minSize orientations layouts))+	where+		(_,_,itemHs1) = validateFirstWElementsPos False itemHs+++{-	validateFirstWElementsPos verifies that the first non line layout, not virtual, WElementHandle either:+	-	already has a layout attribute, or+	-	obtains the (Left,zero) layout attribute if not preceded by a fix or corner WItemHandle.+-}+validateFirstWElementsPos :: Bool -> [WElementHandle ls ps] -> (Bool,Bool,[WElementHandle ls ps])+validateFirstWElementsPos fix_corner_item_found []+	= (False,fix_corner_item_found,[])+validateFirstWElementsPos fix_corner_item_found (itemH:itemHs)+	= let (done,fix_corner_item_found1,itemH1) = validateFirstWElementPos fix_corner_item_found itemH+	  in+	  if   done+	  then (done,fix_corner_item_found1,itemH1:itemHs)+	  else let (done1,fix_corner_item_found2,itemHs1) = validateFirstWElementsPos fix_corner_item_found1 itemHs+	       in  (done1,fix_corner_item_found2,itemH1:itemHs1)+	where+		validateFirstWElementPos :: Bool -> WElementHandle ls ps -> (Bool,Bool,WElementHandle ls ps)+		validateFirstWElementPos fix_corner_item_found itemH@(WItemHandle {wItemVirtual=wItemVirtual,wItemAtts=wItemAtts})+			| wItemVirtual+				= (False,fix_corner_item_found,itemH)+			| not hasPos+				= if   fix_corner_item_found+				  then (True,fix_corner_item_found,itemH)+				  else (True,fix_corner_item_found,itemH {wItemAtts=posAtt:wItemAtts})+			| otherwise+				= let  fix_corner_item_found1 = case pos of+									Fix         -> True+									LeftTop     -> True+									RightTop    -> True+									LeftBottom  -> True+									RightBottom -> True+									_           -> fix_corner_item_found+				       is_line_item           = case pos of+									Left        -> True+									Right       -> True+									Center      -> True+									_           -> False+				  in  (is_line_item,fix_corner_item_found1,itemH)+			where+				(hasPos,posAtt) = cselect isControlPos (ControlPos (Left, {-NoOffset-}zero)) wItemAtts+				pos             = fst (getControlPosAtt posAtt)++		validateFirstWElementPos fix_corner_item_found (WListLSHandle itemHs)+			= let (done,fix_corner_item_found1,itemHs1) = validateFirstWElementsPos fix_corner_item_found itemHs+			  in  (done,fix_corner_item_found1,WListLSHandle itemHs1)++		validateFirstWElementPos fix_corner_item_found (WExtendLSHandle addLS itemHs)+			= let (done,fix_corner_item_found1,itemHs1) = validateFirstWElementsPos fix_corner_item_found itemHs+			  in  (done,fix_corner_item_found1,WExtendLSHandle  addLS itemHs1)++		validateFirstWElementPos fix_corner_item_found (WChangeLSHandle newLS itemHs)+			= let (done,fix_corner_item_found1,itemHs1) = validateFirstWElementsPos fix_corner_item_found itemHs+			  in  (done,fix_corner_item_found1,WChangeLSHandle newLS itemHs1)+++{-	Transform the list of WElementHandles to LayoutItem elements and add private information to+	the list of WElementHandles.+	Only the definition fields of the WElementHandle are inspected (except for the recursive+	WElementHandles (WList/WExtend/WChange(LSHandle), and IsCompoundControls)+	which also inspects the recursive elements).+	The recursive LayoutItems of WList/WExtend/WChange(LSHandle)s are flattened.+	In case a control has no Id or an invalid Id (the Id already occurs earlier), then the control+		is provided with a correct ControlId attribute in the attribute list.+		The new ControlId (or the legal ControlId) attribute is placed in front of the attribute+		list in the resulting WElementHandle list. This front position is assumed by+		setLayoutItems!+	In case a control has no ControlPos attribute then it becomes (RightTo previous,NoOffset).+-}+getLayoutItems :: OSWindowMetrics -> (Int,Int) -> (Int,Int) -> (Int,Int) -> [(ViewDomain,Origin)]+                                  -> [Id] -> Id -> [WElementHandle ls ps]+                 -> IO ([LayoutItem],[Id],   Id,   [WElementHandle ls ps])+getLayoutItems wMetrics hMargins vMargins spaces orientations prevIds prevId (itemH:itemHs)+	= do {+		(itPoss1,prevIds1,prevId1,itemH1)  <- getLayoutItem  wMetrics hMargins vMargins spaces orientations prevIds  prevId  itemH;+		(itPoss2,prevIds2,prevId2,itemHs1) <- getLayoutItems wMetrics hMargins vMargins spaces orientations prevIds1 prevId1 itemHs;+		return (itPoss1++itPoss2,prevIds2,prevId2,itemH1:itemHs1)+	  }+	where+		getLayoutItem :: OSWindowMetrics -> (Int,Int) -> (Int,Int) -> (Int,Int) -> [(ViewDomain,Origin)]+		                       -> [Id] -> Id -> WElementHandle ls ps+		      -> IO ([LayoutItem],[Id],   Id,   WElementHandle ls ps)+++		getLayoutItem wMetrics hMargins vMargins spaces orientations prevIds prevId (WExtendLSHandle addLS itemHs)+			= do {+				(itPoss,prevIds1,prevId1,itemHs1) <- getLayoutItems wMetrics hMargins vMargins spaces orientations prevIds prevId itemHs;+				return (itPoss,prevIds1,prevId1,WExtendLSHandle addLS itemHs1)+			  }++		getLayoutItem wMetrics hMargins vMargins spaces orientations prevIds prevId (WChangeLSHandle newLS itemHs)+			= do {+				(itPoss,prevIds1,prevId1,itemHs1) <- getLayoutItems wMetrics hMargins vMargins spaces orientations prevIds prevId itemHs;+				return (itPoss,prevIds1,prevId1,WChangeLSHandle newLS itemHs1)+			  }++		getLayoutItem wMetrics hMargins vMargins spaces orientations prevIds prevId (WListLSHandle itemHs)+			= do {+				(itPoss,prevIds1,prevId1,itemHs1) <- getLayoutItems wMetrics hMargins vMargins spaces orientations prevIds prevId itemHs;+				return (itPoss,prevIds1,prevId1,WListLSHandle itemHs1)+			  }++		getLayoutItem wMetrics hMargins vMargins spaces orientations prevIds prevId itemH@(WItemHandle {wItemVirtual=wItemVirtual})+			| wItemVirtual = return ([],prevIds,prevId,itemH)+			| otherwise+			= do {+				(itPos,prevIds1,prevId1,itemH1) <- getLayoutWItem wMetrics hMargins vMargins spaces orientations prevIds prevId itemH;+				return ([itPos],prevIds1,prevId1,itemH1)+			  }+			where+				getLayoutWItem :: OSWindowMetrics -> (Int,Int) -> (Int,Int) -> (Int,Int) -> [(ViewDomain,Origin)]+				                          -> [Id] -> Id -> WElementHandle ls ps+				           -> IO (LayoutItem,[Id],   Id,   WElementHandle ls ps)++				getLayoutWItem wMetrics hMargins vMargins spaces _ prevIds prevId itemH@(WItemHandle {wItemKind=IsButtonControl,wItemAtts=atts}) = do+					(id,prevIds1) <- getLayoutItemId (wItemId itemH) prevIds+					let itPos = newLayoutItem id pos (wItemSize itemH)+					return (itPos,prevIds1,id,itemH {wItemAtts=(ControlId id):atts})+					where+						pos           = getLayoutItemPos prevId atts++				getLayoutWItem wMetrics hMargins vMargins spaces _ prevIds prevId itemH@(WItemHandle {wItemKind=IsCustomButtonControl,wItemAtts=atts}) = do+					(id,prevIds1) <- getLayoutItemId (wItemId itemH) prevIds+					let itPos = newLayoutItem id pos (checkCustomSize (wItemSize itemH))+					return (itPos,prevIds1,id,itemH {wItemAtts=(ControlId id):atts})+					where+						pos           = getLayoutItemPos prevId atts						++				getLayoutWItem wMetrics hMargins vMargins spaces _ prevIds prevId itemH@(WItemHandle {wItemKind=IsTextControl,wItemAtts=atts}) = do+					(id,prevIds1) <- getLayoutItemId (wItemId itemH) prevIds+					let itPos = newLayoutItem id pos (wItemSize itemH)+					return (itPos,prevIds1,id,itemH {wItemAtts=(ControlId id):atts})+					where+						pos           = getLayoutItemPos prevId atts++				getLayoutWItem wMetrics hMargins vMargins spaces _ prevIds prevId itemH@(WItemHandle {wItemKind=IsEditControl,wItemAtts=atts}) = do+					(id,prevIds1) <- getLayoutItemId (wItemId itemH) prevIds+					let itPos = newLayoutItem id pos (wItemSize itemH)+					return (itPos,prevIds1,id,itemH {wItemAtts=(ControlId id):atts})+					where						+						pos           = getLayoutItemPos prevId atts++				getLayoutWItem wMetrics hMargins vMargins spaces _ prevIds prevId itemH@(WItemHandle{wItemKind=IsPopUpControl,wItemAtts=atts}) = do+					(id,prevIds1) <- getLayoutItemId (wItemId itemH) prevIds+					let itPos = newLayoutItem id pos (wItemSize itemH)+					return (itPos,prevIds1,id,itemH {wItemAtts=(ControlId id):atts})+					where						+						pos           = getLayoutItemPos prevId atts+						+				getLayoutWItem wMetrics hMargins vMargins spaces _ prevIds prevId itemH@(WItemHandle{wItemKind=IsListBoxControl,wItemAtts=atts}) = do+					(id,prevIds1) <- getLayoutItemId (wItemId itemH) prevIds+					let itPos = newLayoutItem id pos (wItemSize itemH)+					return (itPos,prevIds1,id,itemH {wItemAtts=(ControlId id):atts})+					where						+						pos           = getLayoutItemPos prevId atts++				getLayoutWItem wMetrics hMargins vMargins spaces _ prevIds prevId itemH@(WItemHandle {wItemKind=IsRadioControl,wItemAtts=atts,wItemInfo=wItemInfo})+					| null items+						= controlLayoutFatalError "RadioControl definition" "Empty list of RadioItem-s"+					| otherwise+						= let+							colitemsizes     = toColumns layout items+							colwidths        = map (map (\RadioItemInfo{radioItemSize=Size{w=w}}->w)) colitemsizes+							colmaxwidths     = map maximum colwidths+							width            = sum colmaxwidths+							height           = itemHeight*(length (head colwidths))							+							collaynoutitems  = position_items (\pos item->item{radioItemPos=pos}) itemHeight 0 colmaxwidths colitemsizes+							laynoutitems     = fromColumns layout collaynoutitems+							info'            = info{radioItems=laynoutitems}+						  in do+						  	(id,prevIds1) <- getLayoutItemId (wItemId itemH) prevIds+						  	let itPos = newLayoutItem id pos Size{w=width,h=height}+						  	return (itPos,prevIds1,id,itemH {wItemAtts=(ControlId id):atts,wItemInfo=WRadioInfo info'})+					where+						pos                 = getLayoutItemPos prevId atts						+						itemHeight          = osGetRadioControlItemHeight wMetrics+						info                = getWItemRadioInfo wItemInfo+						items               = radioItems  info+						layout              = radioLayout info++				getLayoutWItem wMetrics hMargins vMargins spaces _ prevIds prevId itemH@(WItemHandle {wItemKind=IsCheckControl,wItemAtts=atts,wItemInfo=wItemInfo})+					| null items+						= controlLayoutFatalError "CheckControl definition" "Empty list of CheckItem-s"+					| otherwise+						= let+							colitemsizes    = toColumns layout items+							colwidths       = map (map (w . checkItemSize)) colitemsizes+							colmaxwidths    = map maximum colwidths+							width           = sum colmaxwidths+							height          = itemHeight*(length (head colwidths))+							collaynoutitems = position_items (\pos item->item{checkItemPos=pos}) itemHeight 0 colmaxwidths colitemsizes+							laynoutitems    = fromColumns layout collaynoutitems+							info'           = info{checkItems=laynoutitems}+						  in do+						  	(id,prevIds1) <- getLayoutItemId (wItemId itemH) prevIds+						  	let itPos = newLayoutItem id pos Size{w=width,h=height}+						  	return (itPos,prevIds1,id,itemH {wItemAtts=(ControlId id):atts,wItemInfo=WCheckInfo info'})+					where+						pos           = getLayoutItemPos prevId atts						+						itemHeight    = osGetCheckControlItemHeight wMetrics+						info          = getWItemCheckInfo wItemInfo+						items         = checkItems info+						layout        = checkLayout info++				getLayoutWItem wMetrics hMargins vMargins spaces _ prevIds prevId itemH@(WItemHandle {wItemKind=IsCustomControl,wItemAtts=atts}) = do+					(id,prevIds1) <- getLayoutItemId (wItemId itemH) prevIds+					let itPos = newLayoutItem id pos (checkCustomSize (wItemSize itemH))+					return (itPos,prevIds1,id,itemH {wItemAtts=(ControlId id):atts})+					where+						pos           = getLayoutItemPos prevId atts++				getLayoutWItem wMetrics hMargins vMargins spaces _ prevIds prevId itemH@(WItemHandle {wItemKind=IsSliderControl,wItemAtts=atts}) = do+					(id,prevIds1) <- getLayoutItemId (wItemId itemH) prevIds+					let itPos = newLayoutItem id pos (wItemSize itemH)+					return (itPos,prevIds1,id,itemH{wItemAtts=(ControlId id):atts})+					where+						pos           = getLayoutItemPos prevId atts++				getLayoutWItem wMetrics hMargins vMargins spaces _ prevIds prevId itemH@(WItemHandle {wItemKind=IsReceiverControl,wItemAtts=atts}) = do+					(id,prevIds1) <- getLayoutItemId (wItemId itemH) prevIds+					let itPos = newLayoutItem id pos (wItemSize itemH)+					return (itPos,prevIds1,id,itemH {wItemAtts=(ControlId id):atts})+					where						+						pos           = getLayoutItemPos prevId atts++				getLayoutWItem wMetrics hMargins vMargins spaces orientations prevIds prevId+				               itemH@(WItemHandle {wItemKind=IsCompoundControl,wItemAtts=atts,wItems=wItems}) = do+					(size,info1,items,atts1) <- calcCompoundSize wMetrics hMargins vMargins spaces orientations info wItems atts+					(id,prevIds1) <- getLayoutItemId (wItemId itemH) prevIds+					let itPos = newLayoutItem id pos size+					return (itPos,prevIds1,id,itemH {wItemAtts=(ControlId id:atts1),wItems=items,wItemInfo=WCompoundInfo info1})+					where+						info          = getWItemCompoundInfo (wItemInfo itemH)						+						pos           = getLayoutItemPos prevId atts++						calcCompoundSize :: OSWindowMetrics -> (Int,Int) -> (Int,Int) -> (Int,Int) -> [(ViewDomain,Origin)]+						                          -> CompoundInfo -> [WElementHandle ls ps] -> [ControlAttribute ls ps]+						                 -> IO (Size,CompoundInfo,   [WElementHandle ls ps],   [ControlAttribute ls ps])+						calcCompoundSize wMetrics hMargins@(lMargin,rMargin) vMargins@(tMargin,bMargin) spaces orientations info itemHs atts+							= do {+								(derSize,itemHs1) <- layoutControls wMetrics newHMargins newVMargins newItemSpaces reqSize minSize newOrientations itemHs;+								let okDerivedSize  = validateDerivedCompoundSize wMetrics domainRect (hasHScroll,hasVScroll) derSize reqSize+								    info1          = layoutScrollbars wMetrics okDerivedSize info+								in  return (okDerivedSize,info1,itemHs1,if hadSize then atts2 else (ControlViewSize derSize):atts2)+							  }+							where+								origin          = compoundOrigin info+								domainRect      = compoundDomain info+								hasHScroll      = isJust (compoundHScroll info)+								hasVScroll      = isJust (compoundVScroll info)+								(minSize,atts1) = validateMinSize atts+								(hadSize,reqSize,atts2)+								                = validateCompoundSize wMetrics (rectToRectangle domainRect) (hasHScroll,hasVScroll) atts1+								(_,hMarginAtt)  = cselect isControlHMargin (ControlHMargin lMargin rMargin) atts2+								newHMargins     = validateControlMargin (getControlHMarginAtt hMarginAtt)+								(_,vMarginAtt)  = cselect isControlVMargin (ControlVMargin tMargin bMargin) atts2+								newVMargins     = validateControlMargin (getControlVMarginAtt vMarginAtt)+								(_,spaceAtt)    = cselect isControlItemSpace (ControlItemSpace (fst spaces) (snd spaces)) atts2+								newItemSpaces   = validateControlItemSpace (getControlItemSpaceAtt spaceAtt)+								domain          = rectToRectangle domainRect+								newOrientations = (domain,origin):orientations++								validateMinSize :: [ControlAttribute ls ps] -> (Size,[ControlAttribute ls ps])+								validateMinSize atts+									= (okMinSize,if hadMinSize then (ControlMinimumSize okMinSize):atts1 else atts1)+									where+										(defMinW,defMinH)         = osMinCompoundSize+										(hadMinSize,minAtt,atts1) = remove isControlMinimumSize (ControlMinimumSize (Size {w=defMinW,h=defMinH})) atts+										minSize                   = getControlMinimumSizeAtt minAtt+										okMinSize                 = Size {w=max defMinW (w minSize),h=max defMinH (h minSize)}++							{-	validateCompoundSize wMetrics viewDomain (hasHScroll,hasVScroll) atts+									validates the Control(View/Outer)Size attribute. The Boolean result is True iff the attribute list contains+									the Control(View/Outer)Size attribute.+									The Booleans hasHScroll hasVScroll should be True iff the compound has the ControlHScroll, ControlVScroll+									attribute set respectively.+									In addition, the ControlOuterSize attribute is mapped to ControlViewSize attribute.+							-}+								validateCompoundSize :: OSWindowMetrics -> ViewDomain -> (Bool,Bool) -> [ControlAttribute ls ps]+								                                                          -> (Bool,Size,[ControlAttribute ls ps])+								validateCompoundSize wMetrics domain hasScrolls atts+									| not hasSize+										= (False,zero,atts)+									| isControlViewSize sizeAtt =+										let+											size  = getControlViewSizeAtt sizeAtt+											size1 = Size {w=max (w size) (fst minSize),h=max (h size) (snd minSize)}+										in (True,size1,snd (creplace isControlViewSize (ControlViewSize size1) atts))+									| otherwise =+										let+											(w,h)       = toTuple (getControlOuterSizeAtt sizeAtt)+											visScrolls  = osScrollbarsAreVisible wMetrics (rectangleToRect domain) (w,h) hasScrolls+											viewSize    = rectSize (getCompoundContentRect wMetrics visScrolls (sizeToRect (Size {w=w,h=h})))+											(_,_,atts1) = remove isControlOuterSize undefined atts+											(_,_,atts2) = remove isControlViewSize  undefined atts1+										in (True,viewSize,(ControlViewSize viewSize):atts2)+									where+										(hasSize,sizeAtt) = cselect (\att->isControlViewSize att || isControlOuterSize att) undefined atts+										minSize           = osMinCompoundSize++								validateDerivedCompoundSize :: OSWindowMetrics -> Rect -> (Bool,Bool) -> Size -> Size -> Size+								validateDerivedCompoundSize wMetrics domain hasScrolls derSize reqSize+									| reqSize==zero = validateScrollbarSize wMetrics domain hasScrolls derSize+									| otherwise     = validateScrollbarSize wMetrics domain hasScrolls reqSize+									where+										validateScrollbarSize :: OSWindowMetrics -> Rect -> (Bool,Bool) -> Size -> Size+										validateScrollbarSize wMetrics domainRect (hasHScroll,hasVScroll) size@(Size {w=w,h=h})+											| domainSize==zero         = size+											| visHScroll && visVScroll = Size {w=w',h=h'}+											| visHScroll               = size {h=h'}+											| visVScroll               = size {w=w'}+											| otherwise                = size+											where+												domainSize = rectSize domainRect+												visHScroll = hasHScroll && osScrollbarIsVisible (rleft domainRect,rright domainRect)  w+												visVScroll = hasVScroll && osScrollbarIsVisible (rtop domainRect, rbottom domainRect) h+												(w',h')    = (w+osmVSliderWidth wMetrics,h+osmHSliderHeight wMetrics)++				getLayoutWItem wMetrics hMargins vMargins spaces orientations prevIds prevId+				               itemH@(WItemHandle {wItemKind=IsLayoutControl,wItemAtts=atts,wItems=wItems}) = do+					(size,items,atts1) <- calcLayoutSize wMetrics hMargins vMargins spaces orientations wItems atts					+					(id,prevIds1) <- getLayoutItemId (wItemId itemH) prevIds+					let itPos = newLayoutItem id pos size+					return (itPos,prevIds1,id,itemH {wItemAtts=(ControlId id):atts1,wItems=items})+					where+						pos           = getLayoutItemPos prevId atts++						calcLayoutSize :: OSWindowMetrics -> (Int,Int) -> (Int,Int) -> (Int,Int) -> [(ViewDomain,Origin)]+						                                  -> [WElementHandle ls ps] -> [ControlAttribute ls ps]+						                         -> IO (Size,[WElementHandle ls ps],   [ControlAttribute ls ps])+						calcLayoutSize wMetrics hMargins@(lMargin,rMargin) vMargins@(tMargin,bMargin) spaces orientations itemHs atts+							= do {+								(derSize,itemHs1) <- layoutControls wMetrics newHMargins newVMargins newItemSpaces reqSize minSize orientations itemHs;+								let okDerivedSize  = validateDerivedLayoutSize wMetrics derSize reqSize+								in  return (okDerivedSize,itemHs1,if hadSize then atts2 else (ControlViewSize okDerivedSize):atts2)+							  }+							where+								(minSize,atts1)         = validateMinSize atts+								(hadSize,reqSize,atts2) = validateLayoutSize wMetrics atts1+								(_,hMarginAtt)          = cselect isControlHMargin (ControlHMargin lMargin rMargin) atts2+								newHMargins             = validateControlMargin (getControlHMarginAtt hMarginAtt)+								(_,vMarginAtt)          = cselect isControlVMargin (ControlVMargin tMargin bMargin) atts2+								newVMargins             = validateControlMargin (getControlVMarginAtt vMarginAtt)+								(_,spaceAtt)            = cselect isControlItemSpace (ControlItemSpace (fst spaces) (snd spaces)) atts2+								newItemSpaces           = validateControlItemSpace (getControlItemSpaceAtt spaceAtt)++								validateMinSize :: [ControlAttribute ls ps] -> (Size,[ControlAttribute ls ps])+								validateMinSize atts+									= (okMinSize,if hadMinSize then (ControlMinimumSize okMinSize):atts1 else atts1)+									where+										(hadMinSize,minAtt,atts1) = remove isControlMinimumSize (ControlMinimumSize zero) atts+										minSize                   = getControlMinimumSizeAtt minAtt+										okMinSize                 = Size{w=max 0 (w minSize),h=max 0 (h minSize)}++							{-	validateLayoutSize wMetrics atts+									validates the Control(View/Outer)Size attribute. The Boolean result is True iff the attribute list contains+									the Control(View/Outer)Size attribute.+									In addition, the ControlOuterSize attribute is mapped to ControlViewSize attribute (identical value).+							-}+								validateLayoutSize :: OSWindowMetrics -> [ControlAttribute ls ps]+								                           -> (Bool,Size,[ControlAttribute ls ps])+								validateLayoutSize wMetrics atts+									| not hasSize+										= (False,zero,atts)+									| otherwise =+										let size1       = Size{w=max (w size) 0,h=max (h size) 0}+										    (_,_,atts1) = remove isControlOuterSize undefined atts+										    (_,_,atts2) = remove isControlViewSize  undefined atts1+										in (True,size1,(ControlViewSize size1):atts2)+									where+										(hasSize,sizeAtt) = cselect (\att->isControlViewSize att || isControlOuterSize att) undefined atts+										size              = if   isControlViewSize sizeAtt+										                    then getControlViewSizeAtt  sizeAtt+										                    else getControlOuterSizeAtt sizeAtt++				getLayoutWItem _ _ _ _ _ _ _ _+					= controlLayoutFatalError "getLayoutWItem" "unmatched control implementation alternative"++				getLayoutItemPos :: Id -> [ControlAttribute ls ps] -> ItemPos+				getLayoutItemPos prevId atts+					= (itemLoc1,offset)+					where+						(itemLoc,offset) = getControlPosAtt (snd (cselect isControlPos (ControlPos (RightTo prevId,{-NoOffset-}zero)) atts))+						itemLoc1         = if   isRelativeToPrev itemLoc+						                   then setRelativeTo prevId itemLoc+						                   else itemLoc++getLayoutItems _ _ _ _ _ prevIds prevId []+	= return ([],prevIds,prevId,[])+++{-	Functions shared above.+-}+validateControlMargin :: (Int,Int) -> (Int,Int)+validateControlMargin (a,b) = (max 0 a,max 0 b)++validateControlItemSpace :: (Int,Int) -> (Int,Int)+validateControlItemSpace (hspace,vspace) = (max 0 hspace,max 0 vspace)++validateDerivedLayoutSize :: OSWindowMetrics -> Size -> Size -> Size+validateDerivedLayoutSize wMetrics derSize reqSize+	| reqSize==zero = derSize+	| otherwise     = reqSize++--	Only used for CompoundControls+layoutScrollbars :: OSWindowMetrics -> Size -> CompoundInfo -> CompoundInfo+layoutScrollbars wMetrics size info@(CompoundInfo {compoundHScroll=compoundHScroll,compoundVScroll=compoundVScroll})+	= info { compoundHScroll=fmap (layoutScrollbar hRect) compoundHScroll+	       , compoundVScroll=fmap (layoutScrollbar vRect) compoundVScroll+	       }+	where+		hasScrolls = (isJust compoundHScroll,isJust compoundVScroll)	-- PA: this should actually become: (visHScroll,visVScroll)!!+		rect       = sizeToRect size+		hRect      = getCompoundHScrollRect wMetrics hasScrolls rect+		vRect      = getCompoundVScrollRect wMetrics hasScrolls rect++		layoutScrollbar :: Rect -> ScrollInfo -> ScrollInfo+		layoutScrollbar r scrollInfo+			= scrollInfo {scrollItemPos=Point2{x=rleft r,y=rtop r},scrollItemSize=rectSize r}+++position_items :: (Point2 -> x -> x) -> Int -> Int -> [Int] -> [[x]] -> [[x]]+position_items setPosition itemHeight left (maxwidth:maxwidths) (col:cols)+	= let+		col1  = position_items' setPosition itemHeight (Point2 {x=left,y=0}) col+		cols1 = position_items  setPosition itemHeight (left+maxwidth) maxwidths cols+	  in col1:cols1+	where+		position_items' :: (Point2 -> x -> x) -> Int -> Point2 -> [x] -> [x]+		position_items' setPosition itemHeight pos (item:items)+			= (setPosition pos item) : (position_items' setPosition itemHeight (pos {y=y pos+itemHeight}) items)+		position_items' _ _ _ _+			= []+position_items _ _ _ _ _+	= []++toColumns :: RowsOrColumns -> [x] -> [[x]]+toColumns (Columns n) items+	= repeat_splitting perColumn items+	where+		nrItems   = length items+		n'        = max 1 n+		perColumn = if (nrItems `rem` n') == 0 then nrItems `div` n' else (nrItems `div` n') + 1++		repeat_splitting :: Int -> [x] -> [[x]]+		repeat_splitting n items+			| null after  = [before]+			| otherwise   = before : repeat_splitting n after+			where+				(before,after) = split n items+toColumns (Rows n) items+	= repeat_spreading nrColumns items cols+	where+		nrItems   = length items+		n'        = setBetween n 1 nrItems+		nrColumns = if (nrItems `rem` n') == 0 then nrItems `div` n' else (nrItems `div` n') + 1+		cols      = take nrColumns (repeat [])++		repeat_spreading :: Int -> [x] -> [[x]] -> [[x]]+		repeat_spreading n items cols+			| null after = spread before cols+			| otherwise  = spread before (repeat_spreading n after cols)+			where+				(before,after) = split n items++				spread :: [a] -> [[a]] -> [[a]]+				spread (x:xs) (ys:zs) = (x:ys):spread xs zs+				spread [] zs          = zs++fromColumns :: RowsOrColumns -> [[x]] -> [x]+fromColumns (Columns _) items+	= concat items+fromColumns (Rows _) items+	= repeat_collecting items+	where+		repeat_collecting :: [[x]] -> [x]+		repeat_collecting items+			| null after = before+			| otherwise  = before ++ repeat_collecting after+			where+				(before,after) = collect items++				collect :: [[x]] -> ([x],[[x]])+				collect ((x:xs):ys)+					= let (zs,ys1) = collect ys+					  in  (x:zs,xs:ys1)+				collect _+					= ([],[])++checkCustomSize :: Size -> Size+checkCustomSize size = Size {w=max 0 (w size),h=max 0 (h size)}++getLayoutItemId :: Maybe Id -> [Id] -> IO (Id,[Id])+getLayoutItemId maybeId prevIds = +	case maybeId of+		Nothing -> do+			u <- newUnique			+			return (toId u,prevIds)+		Just id | id `elem` prevIds -> do			+			u <- newUnique+			return (toId u,prevIds)			+		Just id -> return (id, id:prevIds)++newLayoutItem :: Id -> ItemPos -> Size -> LayoutItem+newLayoutItem id pos size+	= LayoutItem {liId=id,liItemPos=pos,liItemSize=size}++isRelativeToPrev :: ItemLoc -> Bool+isRelativeToPrev itemLoc = itemLoc==LeftOfPrev || itemLoc==RightToPrev || itemLoc==AbovePrev || itemLoc==BelowPrev++setRelativeTo :: Id -> ItemLoc -> ItemLoc+setRelativeTo id LeftOfPrev  = LeftOf  id+setRelativeTo id RightToPrev = RightTo id+setRelativeTo id AbovePrev   = Above   id+setRelativeTo id BelowPrev   = Below   id+++{-	After calculating the layout of the elements, the calculated control positions and sizes must be added+	to the original WElementHandle list.+	In case of recursive WElementHandles (WList/WExtend/WChange(LSHandle), and (Compound/Layout)Controls)+	the recursively calculated positions must also be added.+	In case of (Radio/Check)Controls the already calculated (radio/check) control positions that are+	oriented at base zero need to be shifted to the calculated base position of the (Radio/Check)Control.++	Note that setLayoutItems relies on the fact that the hd element of the attribute+	list contains the ControlId attribute, used for computing the layout (as provided by+	getLayoutItems)! It will remove this element from the attribute list.+-}+setLayoutItems :: [Root] -> [WElementHandle ls ps] -> ([Root],[WElementHandle ls ps])+setLayoutItems roots (itemH:itemHs)+	= let+		(roots1,itemH1 ) = setLayoutItem  roots  itemH+		(roots2,itemHs1) = setLayoutItems roots1 itemHs+	  in (roots2,itemH1:itemHs1)+	where+		setLayoutItem :: [Root] -> WElementHandle ls ps -> ([Root],WElementHandle ls ps)++		setLayoutItem roots (WExtendLSHandle addLS itemHs)+			= let (roots1,itemHs1) = setLayoutItems roots itemHs+			  in  (roots1,WExtendLSHandle addLS itemHs1)++		setLayoutItem roots (WChangeLSHandle newLS itemHs)+			= let (roots1,itemHs1) = setLayoutItems roots itemHs+			  in  (roots1,WChangeLSHandle newLS itemHs1)++		setLayoutItem roots (WListLSHandle itemHs)+			= let (roots1,itemHs1) = setLayoutItems roots itemHs+			  in  (roots1,WListLSHandle itemHs1)++		setLayoutItem roots itemH@(WItemHandle {wItemVirtual=wItemVirtual})+			| wItemVirtual = (roots,itemH)+			| otherwise+			= setLayoutWItem roots itemH+			where+				setLayoutWItem :: [Root] -> WElementHandle ls ps -> ([Root],WElementHandle ls ps)+				setLayoutWItem roots itemH@(WItemHandle {wItemAtts=(ControlId id:atts)})+					= ( roots1+					  , itemH { wItemAtts       = atts+					          , wItemInfo       = info+					          , wItems          = itemHs+					          , wItemPos        = Point2 {x=vx corner,y=vy corner}+					          , wItemSize       = size+					          , wItemLayoutInfo = layoutInfo+					          }+					  )+					where+						(layoutInfo,corner,size,roots1) = getLayoutItem id roots+						itemHs                          = map (shiftCompounds layoutInfo corner) (wItems itemH)+						info                            = shiftWItemInfo corner (wItemInfo itemH)++						shiftCompounds :: LayoutInfo -> Vector2 -> WElementHandle ls ps -> WElementHandle ls ps+						shiftCompounds layoutInfo offset itemH@(WItemHandle{wItemPos=wItemPos,wItemInfo=wItemInfo,wItemLayoutInfo=wItemLayoutInfo,wItems=wItems})+							= itemH { wItemPos        = movePoint offset wItemPos+							        , wItems          = itemHs+							        , wItemInfo       = info+							        , wItemLayoutInfo = layoutInfo+							        }+							where+								layoutInfo1 = if layoutInfo==LayoutFix then layoutInfo else wItemLayoutInfo+								itemHs      = map (shiftCompounds layoutInfo1 offset) wItems+								info        = shiftWItemInfo offset wItemInfo++						shiftCompounds layoutInfo offset (WListLSHandle itemHs)+							= WListLSHandle (map (shiftCompounds layoutInfo offset) itemHs)++						shiftCompounds layoutInfo offset (WExtendLSHandle addLS itemHs)+							= WExtendLSHandle addLS (map (shiftCompounds layoutInfo offset) itemHs)++						shiftCompounds layoutInfo offset (WChangeLSHandle newLS itemHs)+							= WChangeLSHandle newLS (map (shiftCompounds layoutInfo offset) itemHs)++						shiftWItemInfo :: Vector2 -> WItemInfo ls ps -> WItemInfo ls ps+						shiftWItemInfo offset (WCheckInfo info)+							= WCheckInfo (info{checkItems=map shiftCheckItem (checkItems info)})+							where+								shiftCheckItem :: CheckItemInfo ls ps -> CheckItemInfo ls ps+								shiftCheckItem item+									= item {checkItemPos=movePoint offset (checkItemPos item)}+						shiftWItemInfo offset (WRadioInfo info)+							= WRadioInfo (info{radioItems=map shiftRadioItem (radioItems info)})+							where+								shiftRadioItem :: RadioItemInfo ls ps -> RadioItemInfo ls ps+								shiftRadioItem item+									= item {radioItemPos=movePoint offset (radioItemPos item)}+						shiftWItemInfo offset (WCompoundInfo info)+							= WCompoundInfo (info{compoundHScroll=fmap shiftScrollbar (compoundHScroll info)+							       , compoundVScroll=fmap shiftScrollbar (compoundVScroll info)+							       })+							where+								shiftScrollbar :: ScrollInfo -> ScrollInfo+								shiftScrollbar info+									= info {scrollItemPos=movePoint offset (scrollItemPos info)}+						shiftWItemInfo _ info+							= info++				setLayoutWItem _ _+					= controlLayoutFatalError "setLayoutWItem" "WElementHandle has no ControlId"++setLayoutItems roots itemHs+	= (roots,itemHs)
+ Graphics/UI/ObjectIO/Control/Pos.hs view
@@ -0,0 +1,145 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Pos+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Control.Pos(moveWindowViewFrame) where+++import	Graphics.UI.ObjectIO.CommonDef+import  Graphics.UI.ObjectIO.StdWindowAttribute+import  Graphics.UI.ObjectIO.Control.Layout(layoutControls)+import  Graphics.UI.ObjectIO.Control.Relayout(relayoutControls)+import  Graphics.UI.ObjectIO.Window.Access+import  Graphics.UI.ObjectIO.Window.ClipState(forceValidWindowClipState)+import 	Graphics.UI.ObjectIO.Window.Draw(drawWindowLook')+import  Graphics.UI.ObjectIO.Window.Update(updateWindowBackgrounds)+import  Graphics.UI.ObjectIO.OS.Picture(pictScroll, Draw(..))+import  Graphics.UI.ObjectIO.OS.Rgn(osGetRgnBox)+import  Graphics.UI.ObjectIO.OS.Types(Rect)+import  Graphics.UI.ObjectIO.OS.Window(OSWindowMetrics, osScrollbarsAreVisible, osSetWindowSliderThumb, toOSscrollbarRange, osMinWindowSize, osSetCaretPos)+import  Control.Monad(when)+++controlPosFatalError :: String -> String -> x+controlPosFatalError function error+	= dumpFatalError function "controlpos" error++{-	moveWindowViewFrame moves the current view frame of the WindowHandle by the given Vector2. +	moveWindowViewFrame assumes that the argument WindowHandle is a Window.+-}+moveWindowViewFrame :: OSWindowMetrics -> Vector2 -> WIDS -> WindowHandle ls ps -> IO (WindowHandle ls ps)+moveWindowViewFrame wMetrics v wids@(WIDS {wPtr=wPtr}) wH@(WindowHandle {whItems=oldItems,whSize=whSize,whAtts=whAtts,whSelect=whSelect,whShow=whShow}) =+	if newOrigin == oldOrigin then return wH		-- origin has not changed+	else do	 +		setSliderThumb (hasHScroll && (x newOrigin) /= (x oldOrigin)) wMetrics wPtr True  (minx,x newOrigin,maxx) vieww (toTuple whSize)+		setSliderThumb (hasVScroll && (y newOrigin) /= (y oldOrigin)) wMetrics wPtr False (miny,y newOrigin,maxy) viewh (toTuple whSize)+		when hasCaret (osSetCaretPos wPtr (x caretPos - x newOrigin) (y caretPos - y newOrigin))+		(if null oldItems then		-- there are no controls: do only visual updates+		  let wH1 = wH {whWindowInfo=windowInfo{windowOrigin=newOrigin}}+		      (updArea,updAction) = +		          if (not (lookSysUpdate lookInfo) || toMuch)+		          then ([newFrame],return [])+		          else calcScrollUpdateArea oldOrigin newOrigin contentRect+		      updState = UpdateState{oldFrame=posSizeToRectangle oldOrigin contentSize,newFrame=newFrame,updArea=updArea}+		  in drawWindowLook' wMetrics wPtr updAction updState wH1+		 else do+		     let reqSize = Size   -- there are controls: recalculate layout and do visual updates+		             { w=(w contentSize)-(fst hMargins)-(snd hMargins)+		     	     , h=(h contentSize)-(fst vMargins)-(snd vMargins)+		     	     }+		     (_, newItems) <- layoutControls wMetrics hMargins vMargins spaces reqSize minSize [(domain,newOrigin)] oldItems+		     let wH1 = wH{whItems=newItems,whWindowInfo=windowInfo{windowOrigin=newOrigin}}+		     wH2 <- forceValidWindowClipState wMetrics True wPtr wH1+		     (isRect,areaRect) <- (case whWindowInfo wH2 of+					      WindowInfo{windowClip=ClipState{clipRgn=clipRgn}} -> osGetRgnBox clipRgn+					      NoWindowInfo -> controlPosFatalError "moveWindowViewFrame" "unexpected whWindowInfo field")+		     updRgn <- relayoutControls wMetrics whSelect whShow contentRect contentRect zero zero wPtr (whDefaultId wH2) oldItems (whItems wH2)+		     wH3 <- updateWindowBackgrounds wMetrics updRgn wids wH2+		     let (updArea,updAction) = +		     	     if (not (lookSysUpdate lookInfo) || toMuch || not isRect)+		     	     then ([newFrame],return [])+		     	     else calcScrollUpdateArea oldOrigin newOrigin areaRect+		     let updState = UpdateState{oldFrame=posSizeToRectangle oldOrigin contentSize,newFrame=newFrame,updArea=updArea}+		     drawWindowLook' wMetrics wPtr updAction updState wH3)+	where+		windowInfo = whWindowInfo wH+		(oldOrigin,domainRect,hasHScroll,hasVScroll,lookInfo)+			= ( windowOrigin windowInfo+			  , windowDomain windowInfo+			  , isJust (windowHScroll windowInfo)+			  , isJust (windowVScroll windowInfo)+			  , windowLook windowInfo+			  )		+			  +		domain = rectToRectangle domainRect+		visScrolls = osScrollbarsAreVisible wMetrics domainRect (toTuple whSize) (hasHScroll,hasVScroll)+		contentRect = getWindowContentRect wMetrics visScrolls (sizeToRect whSize)+		contentSize = rectSize contentRect+		Size {w=w',h=h'}  = contentSize+		(minx,maxx,vieww) = (rleft domainRect, rright  domainRect, w contentSize)+		(miny,maxy,viewh) = (rtop  domainRect, rbottom domainRect, h contentSize)+		newOrigin = Point2+			{ x = setBetween ((x oldOrigin)+(vx v)) minx (max minx (maxx-vieww))+			, y = setBetween ((y oldOrigin)+(vy v)) miny (max miny (maxy-viewh))+			}+		newFrame		= posSizeToRectangle newOrigin contentSize+		toMuch			= (abs ((x newOrigin)-(x oldOrigin))>=w') || (abs ((y newOrigin)-(y oldOrigin))>=h')+		(defMinW,defMinH)	= osMinWindowSize+		minSize			= Size{w=defMinW,h=defMinH}+		hMargins		= getWindowHMargins   IsWindow wMetrics whAtts+		vMargins		= getWindowVMargins   IsWindow wMetrics whAtts+		spaces			= getWindowItemSpaces IsWindow wMetrics whAtts+		(hasCaret,catt)  = cselect isWindowCaret undefined whAtts+		(caretPos,_)     = getWindowCaretAtt catt++		setSliderThumb :: Bool -> OSWindowMetrics -> OSWindowPtr -> Bool -> (Int,Int,Int) -> Int -> (Int,Int) -> IO ()+		setSliderThumb hasScroll wMetrics wPtr isHScroll scrollValues viewSize maxcoords+			| hasScroll	= osSetWindowSliderThumb wMetrics wPtr isHScroll osThumb maxcoords True+			| otherwise	= return ()+			where+				(_,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],Draw [Rect])+calcScrollUpdateArea oldOrigin newOrigin areaRect =+    (map rectToRectangle updArea,scroll newOriginAreaRect{rright=rright+1,rbottom=rbottom+1} restArea v)+    where+	newOriginAreaRect		= addVector (toVector newOrigin) areaRect+	Rect{rleft=rleft,rtop=rtop,rright=rright,rbottom=rbottom}	= newOriginAreaRect+	v				= toVector (oldOrigin-newOrigin)+	Vector2{vx=vx,vy=vy}		= v+	(updArea,restArea)		= +		if vx<=0 && vy<=0 then+		    (	[newOriginAreaRect{rleft=rright+vx,rbottom=rbottom+vy},newOriginAreaRect{rtop=rbottom+vy}]+		    ,	 newOriginAreaRect{rright=rright+vx,rbottom=rbottom+vy}+		    )+		else if vx<=0 && vy>=0 then+		    (	[newOriginAreaRect{rbottom=rtop+vy},newOriginAreaRect{rleft=rright+vx,rtop=rtop+vy}]+		    ,	 newOriginAreaRect{rtop=rtop+vy,rright=rright+vx}+		    )+		else if vx>=0 && vy<=0 then+		    (	[newOriginAreaRect{rright=rleft+vx,rbottom=rbottom+vy},newOriginAreaRect{rtop=rbottom+vy}]+		    ,	 newOriginAreaRect{rleft=rleft+vx,rbottom=rbottom+vy}+		    )+		else+		    (	[newOriginAreaRect{rbottom=rtop+vy},newOriginAreaRect{rtop=rtop+vy,rright=rleft+vx}]+		    ,	 newOriginAreaRect{rleft=rleft+vx,rtop=rtop+vy}+		    )++	scroll :: Rect -> Rect -> Vector2 -> Draw [Rect]+	scroll scrollRect restRect v = do+		updRect <- pictScroll scrollRect v+		return (if updRect==zero then [] else [restRect])
+ Graphics/UI/ObjectIO/Control/Relayout.hs view
@@ -0,0 +1,141 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Relayout+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Control.Relayout where+++import Graphics.UI.ObjectIO.Relayout+import Graphics.UI.ObjectIO.Window.Access+import Graphics.UI.ObjectIO.Window.ClipState+import Graphics.UI.ObjectIO.OS.Rgn(OSRgnHandle)+import Graphics.UI.ObjectIO.OS.System(OSWindowMetrics)+++{-	relayoutControls wMetrics isAble oldFrame newFrame oldParentPos newParentPos parentPtr defaultId old new+	resizes, moves, and updates changed WElementHandle(`)s. +		isAble							is True iff the parent window/compound is Able.+		oldFrame						is the clipping rect of the parent window/compound at the original location and size.+		newFrame						is the clipping rect of the parent window/compound at the new location and size.+		oldParentPos and newParentPos	are the positions of the respective parent window/compound of the elements.+		parentPtr						is the parent window/dialog.+		defaultId						is the optional Id of the default control.+		old								contains the elements at their original location and size.+		new								contains the elements at their new location and size.+	relayoutControls assumes that the two lists contain elements that are identical except for size and position.+		If this is not the case, a runtime error will occur.+	relayoutControls assumes that the ClipStates of all compound elements are valid.+	The return OSRgnHandle is the area of the window that requires to be updated (use updatewindowbackgrounds [windowupdate] for this purpose).+-}+relayoutControls :: OSWindowMetrics -> Bool -> Bool -> Rect -> Rect -> Point2 -> Point2 -> OSWindowPtr -> Maybe Id ->+					[WElementHandle ls ps] -> [WElementHandle ls ps] -> IO OSRgnHandle+relayoutControls wMetrics isAble isVisible oldFrame newFrame oldParentPos newParentPos wPtr defaultId oldHs newHs =+     relayoutItems wMetrics oldFrame newFrame oldParentPos newParentPos wPtr+					(wElementHandlesToRelayoutItems isAble isVisible oldHs [])+					(wElementHandlesToRelayoutItems isAble isVisible newHs [])+     where+	wElementHandlesToRelayoutItems :: Bool -> Bool -> [WElementHandle ls ps] -> [RelayoutItem] -> [RelayoutItem]+	wElementHandlesToRelayoutItems isAble isVisible (itemH:itemHs) items =+	    wElementHandleToRelayoutItems isAble isVisible itemH (wElementHandlesToRelayoutItems isAble isVisible itemHs items)+	    where+		wElementHandleToRelayoutItems :: Bool -> Bool -> WElementHandle ls ps -> [RelayoutItem] -> [RelayoutItem]+		wElementHandleToRelayoutItems isAble isVisible itemH@(WItemHandle {wItemKind=wItemKind}) items =+		    wItemHandleToRelayoutItems wItemKind isAble isVisible itemH items+		    where+		      wItemHandleToRelayoutItems :: ControlKind -> Bool -> Bool -> WElementHandle ls ps -> [RelayoutItem] -> [RelayoutItem]+		      wItemHandleToRelayoutItems controlKind@IsRadioControl isAble isVisible itemH@(WItemHandle {wItemSelect=wItemSelect,wItemShow=wItemShow}) items =+			  radioItemToRelayoutItems (isAble && wItemSelect) (isVisible && wItemShow) (radioItems (getWItemRadioInfo (wItemInfo itemH))) items+			  where+			    radioItemToRelayoutItems :: Bool -> Bool -> [RadioItemInfo ls ps] -> [RelayoutItem] -> [RelayoutItem]+			    radioItemToRelayoutItems isAble isVisible (radio:radios) items =					+				radioItemInfoToRelayoutItem isAble isVisible radio :+				radioItemToRelayoutItems isAble isVisible radios items+				where+				  radioItemInfoToRelayoutItem :: Bool -> Bool -> RadioItemInfo ls ps -> RelayoutItem+				  radioItemInfoToRelayoutItem isAble isVisible info =+				      RelayoutItem+					  { rliItemKind	= controlKind+					  , rliItemPtr	= radioItemPtr  info+					  , rliItemPos	= radioItemPos  info+					  , rliItemSize	= radioItemSize info+					  , rliItemSelect=isAble+					  , rliItemShow	= isVisible+					  , rliItemInfo	= undefined+					  , rliItemLook	= undefined+					  , rliItems	= []+					  }+			    radioItemToRelayoutItems _ _ _ items = items++		      wItemHandleToRelayoutItems controlKind@IsCheckControl isAble isVisible itemH@(WItemHandle {wItemSelect=wItemSelect,wItemShow=wItemShow}) items =+			  checkItemToRelayoutItems (isAble && wItemSelect) (isVisible && wItemShow) (checkItems (getWItemCheckInfo (wItemInfo itemH))) items+			  where+			    checkItemToRelayoutItems :: Bool -> Bool -> [CheckItemInfo ls ps] -> [RelayoutItem] -> [RelayoutItem]+			    checkItemToRelayoutItems isAble isVisible (check:checks) items =+				checkItemInfoToRelayoutItem isAble isVisible check :+				checkItemToRelayoutItems isAble isVisible checks items+				where+				  checkItemInfoToRelayoutItem :: Bool -> Bool -> CheckItemInfo ls ps -> RelayoutItem+				  checkItemInfoToRelayoutItem isAble isVisible info =+				      RelayoutItem+					  { rliItemKind	= controlKind+					  , rliItemPtr	= checkItemPtr info+					  , rliItemPos	= checkItemPos info+					  , rliItemSize	= checkItemSize info+					  , rliItemSelect=isAble+					  , rliItemShow	= isVisible+					  , rliItemInfo	= undefined+					  , rliItemLook	= undefined+					  , rliItems	= []+					  }+			    checkItemToRelayoutItems _ _ _ items = items++		      wItemHandleToRelayoutItems controlKind isAble isVisible itemH items =+			  let item = RelayoutItem+				  { rliItemKind	= controlKind+				  , rliItemPtr	= wItemPtr  itemH+				  , rliItemPos	= wItemPos  itemH+				  , rliItemSize	= wItemSize itemH+				  , rliItemSelect=isAble'+				  , rliItemShow	= isVisible'+				  , rliItemInfo	= info+				  , rliItemLook	= look+				  , rliItems	= items'+				  }+			  in (item:items)+			  where+			      isAble' = isAble && wItemSelect itemH+			      isVisible' = isVisible && wItemShow itemH+			      (info,look,items') = getInfo controlKind isAble' isVisible' itemH++			      getInfo :: ControlKind -> Bool -> Bool -> WElementHandle ls ps -> (CompoundInfo,LookInfo,[RelayoutItem])+			      getInfo IsCompoundControl isAble isVisible (WItemHandle {wItemInfo=wItemInfo,wItems=wItems}) =+				  (info,compoundLook (compoundLookInfo info),wElementHandlesToRelayoutItems isAble isVisible wItems [])+				  where+				     info	= getWItemCompoundInfo wItemInfo+			      getInfo IsCustomButtonControl _ _ (WItemHandle {wItemInfo=wItemInfo}) =+				  (undefined,cButtonInfoLook (getWItemCustomButtonInfo wItemInfo),[])+			      getInfo IsCustomControl _ _ (WItemHandle {wItemInfo=wItemInfo}) =+				  (undefined,customInfoLook (getWItemCustomInfo wItemInfo),[])+			      getInfo IsLayoutControl isAble isVisible (WItemHandle {wItems=wItems}) =+				  (undefined,undefined,wElementHandlesToRelayoutItems isAble isVisible wItems [])+			      getInfo _ _ _ _ = (undefined,undefined,[])+		+		wElementHandleToRelayoutItems isAble isVisible (WListLSHandle itemHs) items =+		    wElementHandlesToRelayoutItems isAble isVisible itemHs items+		+		wElementHandleToRelayoutItems isAble isVisible (WExtendLSHandle exLS itemHs) items =+		    wElementHandlesToRelayoutItems isAble isVisible itemHs items+		+		wElementHandleToRelayoutItems isAble isVisible (WChangeLSHandle chLS itemHs) items =+		    wElementHandlesToRelayoutItems isAble isVisible itemHs items+	+	wElementHandlesToRelayoutItems _ _ _ items = items
+ Graphics/UI/ObjectIO/Control/Resize.hs view
@@ -0,0 +1,233 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Resize+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Control.Resize(resizeControls) where++++import	Graphics.UI.ObjectIO.CommonDef as C+import	Graphics.UI.ObjectIO.StdControlAttribute(isControlResize, getControlResizeFun,+			    			 isControlMinimumSize, getControlMinimumSizeAtt,+			    			 isControlPos, getControlPosAtt, isControlViewSize)+import	Graphics.UI.ObjectIO.Control.Layout(layoutControls)+import	Graphics.UI.ObjectIO.Control.Relayout(relayoutControls)+import	Graphics.UI.ObjectIO.Window.Handle+import	Graphics.UI.ObjectIO.Window.Access(getWItemCompoundInfo, getWItemEditInfo, getWItemSliderInfo, +		     			   getCompoundContentRect,+		     			   getWindowHMargins, getWindowVMargins, getWindowItemSpaces)+import	Graphics.UI.ObjectIO.Window.ClipState(forceValidWindowClipState, invalidateCompoundClipState)+import	Graphics.UI.ObjectIO.Window.Draw(drawWindowLook)+import	Graphics.UI.ObjectIO.Window.Update(updateWindowBackgrounds)+import	Graphics.UI.ObjectIO.OS.System(OSWindowMetrics(..))+import	Graphics.UI.ObjectIO.OS.Types(Rect, OSWindowPtr)+import	Graphics.UI.ObjectIO.OS.Window(osMinWindowSize, osMinCompoundSize, osScrollbarsAreVisible)++{-	resizeControls proceeds as follows:+	-	Apply to every control its ControlResizeFunction if applicable.+	-	If some controls have changed size or have been layout relative to the window view frame:+		-	Calculate the new layout.+		-	Reposition and resize the appropriate controls.+-}+resizeControls :: OSWindowMetrics -> Bool -> Bool -> WIDS -> Origin -> Size -> Size -> WindowHandle ls ps -> IO (WindowHandle ls ps)+resizeControls wMetrics isActive updateAll wids@(WIDS {wPtr=wPtr}) oldOrigin oldWSize newWSize wH@(WindowHandle {whWindowInfo=windowInfo,whItems=oldItems,whAtts=whAtts,whDefaultId=whDefaultId}) =+	let (layoutChanged,newItems) = calcNewControlsSize wMetrics originShifted oldWSize newWSize oldItems+	in+	   if not layoutChanged && (w newWSize) <= (w oldWSize) && (h newWSize) <= (h oldWSize)+	   then do	   	   +	   	   wH <- forceValidWindowClipState wMetrics True wPtr wH{whItems=newItems}+		   (if lookSysUpd && not updateAll then return wH+		    else drawWindowLook wMetrics wPtr (return ()) UpdateState{oldFrame=oldFrame,newFrame=newFrame,updArea=[newFrame]} wH)+	   else do+		   (_,newItems) <- layoutControls wMetrics hMargins vMargins spaces newWSize minSize [(domain,newOrigin)] newItems		  +		   wH <- forceValidWindowClipState wMetrics True wPtr wH{whItems=newItems}+		   updRgn <- relayoutControls wMetrics (whSelect wH) (whShow wH) (sizeToRect oldWSize) (sizeToRect newWSize) zero zero wPtr whDefaultId oldItems (whItems wH)+		   wH <- updateWindowBackgrounds wMetrics updRgn wids wH+		   let Point2{x=x,y=y} = oldOrigin+		   let (oldw,oldh) = toTuple oldWSize+		   let (neww,newh) = toTuple newWSize+		   let updArea = if (lookSysUpd && not originShifted && (neww>oldw || newh>oldh) && isActive && not updateAll)+		   	 	 then (	 (if (neww>oldw) then [Rectangle {corner1=oldOrigin{x=x+oldw},corner2=Point2{x=x+neww,y=y+min oldh newh}}] else [])+		  		      ++ (if (newh>oldh) then [Rectangle {corner1=oldOrigin{y=y+oldh},corner2=Point2{x=x+neww,y=y+newh}}]          else [])+		  		      )+		  		 else [newFrame]+		   let updState	= UpdateState{oldFrame=oldFrame,newFrame=newFrame,updArea=updArea}+		   drawWindowLook wMetrics wPtr (return ()) updState wH+	where+		originShifted			= oldOrigin /= newOrigin		+		(newOrigin,domainRect,lookInfo) = (windowOrigin windowInfo,windowDomain windowInfo,windowLook windowInfo)+		domain				= rectToRectangle domainRect+		lookSysUpd			= lookSysUpdate lookInfo+		(defMinW,   defMinH)		= osMinWindowSize		+		hMargins			= getWindowHMargins   (whKind wH) wMetrics whAtts+		vMargins			= getWindowVMargins   (whKind wH) wMetrics whAtts+		spaces				= getWindowItemSpaces (whKind wH) wMetrics whAtts+		minSize				= Size{w=defMinW,h=defMinH}+		oldFrame			= posSizeToRectangle oldOrigin oldWSize+		newFrame			= posSizeToRectangle newOrigin newWSize+++{-	calcNewControlsSize applies to a Control its ControlResizeFunction if it has one.+	The Boolean result holds iff some Control has changed its size or may cause change of layout.+-}+calcNewControlsSize :: OSWindowMetrics -> Bool -> Size -> Size -> [WElementHandle ls ps]  -> (Bool,[WElementHandle ls ps])+calcNewControlsSize wMetrics originShifted oldWSize newWSize [] = (False,[])+calcNewControlsSize wMetrics originShifted oldWSize newWSize (itemH:itemHs) =+   let +	(layoutChanged1,itemH1)	 = calcNewControlSize  wMetrics originShifted oldWSize newWSize itemH+	(layoutChanged2,itemHs1) = calcNewControlsSize wMetrics originShifted oldWSize newWSize itemHs+   in+	(layoutChanged1 || layoutChanged2,itemH1:itemHs1)+   where+	calcNewControlSize :: OSWindowMetrics -> Bool -> Size -> Size -> WElementHandle ls ps -> (Bool,WElementHandle ls ps)+	calcNewControlSize wMetrics originShifted oldWSize newWSize itemH@(WItemHandle {wItemAtts=atts})+	    | not resizable = (isViewFrameSensitive || isOriginSensitive,itemH)+	    | otherwise =+		let (layoutChanged,itemH1) = calcNewWItemSize wMetrics originShifted (\oldCSize -> resizeF oldCSize oldWSize newWSize) itemH+		in (isViewFrameSensitive || isOriginSensitive || layoutChanged,itemH1)+	    where		+		(resizable,resizeAtt)	= cselect isControlResize undefined atts+		(hasPos,posAtt)		= cselect isControlPos undefined atts+		itemPos			= getControlPosAtt posAtt+		resizeF			= getControlResizeFun resizeAtt+		isViewFrameSensitive	= if hasPos+					  then	(case (fst itemPos) of+							LeftBottom	-> True+							RightTop	-> True+							RightBottom	-> True+							Center		-> True+							C.Right		-> True+							Fix		-> originShifted+							_		-> False+						)+					  else False+		isOriginSensitive	= False+		-- should be:+		{-			if hasPos+					  then  (case (snd itemPos) of+							OffsetFun _ _	-> True+							_		-> False+						)+					  else False -}+		+		calcNewWItemSize :: OSWindowMetrics -> Bool -> (IdFun Size) -> WElementHandle ls ps -> (Bool,WElementHandle ls ps)+		+{-	PA: the current size argument of the resize function must be the outer size, not the view size.+		Similar: the result size is also the outer size. +-}		calcNewWItemSize wMetrics originShifted resizeF itemH@(WItemHandle {wItemKind=IsCompoundControl}) =+			let +				visOldScrolls	= osScrollbarsAreVisible wMetrics domainRect (toTuple oldSize) hasScrolls+			  	oldFrameSize	= rectSize (getCompoundContentRect wMetrics visOldScrolls (sizeToRect oldSize))+			  	newSize1	= resizeF oldSize+			  	newSize		= Size {w=max (w minSize) (w newSize1),h=max (h minSize) (h newSize1)}+			  	visNewScrolls	= osScrollbarsAreVisible wMetrics domainRect (toTuple newSize) hasScrolls+			  	newFrameSize	= rectSize (getCompoundContentRect wMetrics visNewScrolls (sizeToRect newSize))+			in				+				if newFrameSize==oldFrameSize then (False,itemH)+				else+					let +						newOrigin	= calcNewOrigin origin domainRect newFrameSize+						newInfo		= WCompoundInfo info{compoundOrigin=newOrigin}+						(_,itemHs)	= calcNewControlsSize wMetrics (originShifted || newOrigin/=origin) oldFrameSize newFrameSize (wItems itemH)+						itemH1		= itemH{wItemSize=newSize,wItemAtts=replaceSizeAtt newFrameSize atts,wItemInfo=newInfo,wItems=itemHs}+						itemH2		= invalidateCompoundClipState itemH1+					in (True,itemH2)+			where+				atts			= wItemAtts itemH+				oldSize			= wItemSize itemH+				info			= getWItemCompoundInfo (wItemInfo itemH)+				origin			= compoundOrigin info+				domainRect		= compoundDomain info+				hasScrolls		= (isJust (compoundHScroll info),isJust (compoundVScroll info))+				(defMinW,defMinH)	= osMinCompoundSize+				minSize			= getControlMinimumSizeAtt (snd (cselect isControlMinimumSize (ControlMinimumSize (Size{w=defMinW,h=defMinH})) atts))+			+				calcNewOrigin :: Point2 -> Rect -> Size -> Point2	-- This code also appears at windowdevice: windowStateSizeAction+				calcNewOrigin (Point2 {x=x,y=y}) (Rect {rleft=rleft,rtop=rtop,rright=rright,rbottom=rbottom}) (Size{w=w,h=h})+					= Point2{x=x',y=y'}+					where+						x'	= if x+w > rright  then (max (rright -w) rleft) else x+						y'	= if y+h > rbottom then (max (rbottom-h) rtop ) else y+		+		calcNewWItemSize _ originShifted resizeF itemH@(WItemHandle {wItemKind=IsCustomControl}) =			+			(newSize1/=oldSize,itemH{wItemSize=newSize1,wItemAtts=replaceSizeAtt newSize1 (wItemAtts itemH)})+			where+				oldSize		= wItemSize itemH+				newSize		= resizeF oldSize+				newSize1	= Size{w=max 0 (w newSize),h=max 0 (h newSize)}+		+		calcNewWItemSize _ originShifted resizeF itemH@(WItemHandle {wItemKind=IsCustomButtonControl}) =+			(newSize1/=oldSize,itemH{wItemSize=newSize1,wItemAtts=replaceSizeAtt newSize1 (wItemAtts itemH)})+			where+				oldSize		= wItemSize itemH+				newSize		= resizeF oldSize+				newSize1	= Size{w=max 0 (w newSize),h=max 0 (h newSize)}+		+		calcNewWItemSize wMetrics originShifted resizeF itemH@(WItemHandle {wItemKind=IsEditControl}) =			+			(newSize1/=oldSize,itemH{wItemSize=newSize1,wItemInfo=editInfo,wItemAtts=replaceSizeAtt newSize1 (wItemAtts itemH)})+			where+				oldSize		= wItemSize itemH+				newSize		= resizeF oldSize+				info		= getWItemEditInfo (wItemInfo itemH)+				lineHeight	= osmHeight wMetrics+				nrLines1	= max 1 ((h newSize) `div` lineHeight)+				newSize1	= Size {w=max 0 (w newSize),h=nrLines1*lineHeight}+				editInfo	= WEditInfo info{editInfoWidth=w newSize1,editInfoNrLines=nrLines1}+		+		calcNewWItemSize wMetrics originShifted resizeF itemH@(WItemHandle {wItemKind=IsLayoutControl}) =+			let +				newSize1 = resizeF oldSize+			  	newSize	 = Size {w=max (w minSize) (w newSize1),h=max (h minSize) (h newSize1)}+			in+				if newSize==oldSize then (False,itemH)+				else +					let (_,itemHs) = calcNewControlsSize wMetrics originShifted oldSize newSize (wItems itemH)+					in (True,itemH{wItemSize=newSize,wItemAtts=replaceSizeAtt newSize atts,wItems=itemHs})+			where+				atts	= wItemAtts itemH+				oldSize	= wItemSize itemH+				minSize	= getControlMinimumSizeAtt (snd (cselect isControlMinimumSize (ControlMinimumSize zero) atts))+		+		calcNewWItemSize wMetrics originShifted resizeF itemH@(WItemHandle {wItemKind=IsSliderControl}) =			+			(newSize1/=oldSize,itemH{wItemSize=newSize1,wItemInfo=sliderInfo,wItemAtts=replaceSizeAtt newSize1 (wItemAtts itemH)})+			where+				oldSize		= wItemSize itemH+				newSize		= resizeF oldSize+				info		= getWItemSliderInfo (wItemInfo itemH)+				horizontal	= sliderInfoDir info==Horizontal+				newSize1	= if horizontal	+						  then Size{w=max (w newSize) 0,h=osmHSliderHeight wMetrics}+						  else Size{w=osmVSliderWidth wMetrics,h=max (h newSize) 0}+				sSize		= (if horizontal then w else h) newSize1+				sliderInfo	= WSliderInfo info{sliderInfoLength=sSize}+		+		calcNewWItemSize _ _ _ itemH = (False,itemH)+	+	calcNewControlSize wMetrics originShifted oldWSize newWSize (WListLSHandle itemHs) =+		let (layoutChanged,itemHs1) = calcNewControlsSize wMetrics originShifted oldWSize newWSize itemHs+		in (layoutChanged,WListLSHandle itemHs1)+	+	calcNewControlSize wMetrics originShifted oldWSize newWSize (WExtendLSHandle exLS itemHs) =+		let (layoutChanged,itemHs1) = calcNewControlsSize wMetrics originShifted oldWSize newWSize itemHs+		in (layoutChanged,WExtendLSHandle exLS itemHs1)+	+	calcNewControlSize wMetrics originShifted oldWSize newWSize (WChangeLSHandle chLS itemHs) =+		let (layoutChanged,itemHs1) = calcNewControlsSize wMetrics originShifted oldWSize newWSize itemHs+		in (layoutChanged,WChangeLSHandle chLS itemHs1)+	+	replaceSizeAtt :: Size -> [ControlAttribute ls ps] -> [ControlAttribute ls ps]+	replaceSizeAtt size atts	+		| replaced  = atts1+		| otherwise = atts++[sizeAtt]+		where+			(replaced,atts1) = creplace isControlViewSize sizeAtt atts+			sizeAtt		 = ControlViewSize size
+ Graphics/UI/ObjectIO/Control/Validate.hs view
@@ -0,0 +1,101 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Validate+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Control.Validate contains control validation functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Control.Validate+		( validateControlTitle, validateSliderState+		, getWElementControlIds+                , noDuplicateControlIds, disjointControlIds+                , controlIdsAreConsistent+                ) where+++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.Window.Handle+import Graphics.UI.ObjectIO.Receiver.Handle+import Graphics.UI.ObjectIO.OS.Window+import qualified Data.Map as Map+++controlvalidateFatalError :: String -> String -> x+controlvalidateFatalError function error+	= dumpFatalError function "ControlValidate" error+++--	Validate the title of a control.++validateControlTitle :: String -> String+validateControlTitle string+	= removeSpecialChars osControlTitleSpecialChars string+++--	Validate the settings of a slider.++validateSliderState :: SliderState -> SliderState+validateSliderState (SliderState{sliderMin=sMin, sliderMax=sMax, sliderThumb=thumb})+	= SliderState+	  { sliderMin	= min'+	  , sliderMax	= max'+	  , sliderThumb	= setBetween thumb min' max'+	  }+	where+		min' = min sMin sMax+		max' = max sMin sMax+	+--	Collect all Ids of the given [WElementHandle].++getWElementControlIds :: [WElementHandle ls ps] -> [Id]+getWElementControlIds [] = []+getWElementControlIds (itemH:itemHs) = ids1++ids2+	where+		ids1 = getWElementIds itemH+		ids2 = getWElementControlIds itemHs+		++		getWElementIds :: (WElementHandle ls ps) -> [Id]+		getWElementIds (WItemHandle {wItemId=id,wItems=itemHs}) = maybeToList id ++ getWElementControlIds itemHs+		getWElementIds (WListLSHandle itemHs) = getWElementControlIds itemHs+		getWElementIds (WExtendLSHandle addLS itemHs) = getWElementControlIds itemHs+		getWElementIds (WChangeLSHandle newLS itemHs) = getWElementControlIds itemHs			  +++--	Id occurrence checks on [WElementHandle ls ps] and [WElementHandle`].++--	There are no duplicate (ControlId id) attributes:+++noDuplicateControlIds :: [WElementHandle ls ps] -> Bool+noDuplicateControlIds itemHs = noDuplicates (getWElementControlIds itemHs)+	  ++--	The list of Ids does not occur in any (ControlId id) attribute:++disjointControlIds :: [Id] -> [WElementHandle ls ps] -> Bool+disjointControlIds ids itemHs = disjointLists ids (getWElementControlIds itemHs)+++{-	controlIdsAreConsistent checks whether the WElementHandles contain (R(2))Ids that have already been+	associated with open receivers or other I/O objects and if there are no duplicate Ids. +	The ReceiverTable is not changed if there are duplicate (R(2))Ids; otherwise all (R(2))Ids have been bound.+-}++controlIdsAreConsistent :: SystemId -> Id -> [WElementHandle ls ps] -> IdTable -> Maybe IdTable+controlIdsAreConsistent ioId wId itemHs it+	| not (okMembersIdTable ids it) = Nothing	+	| otherwise = Just it1+	where+		ids 	      = getWElementControlIds itemHs+		idParent      = IdParent {idpIOId=ioId,idpDevice=WindowDevice,idpId=wId}+		it1           = foldr (\id tbl -> Map.insert id idParent tbl) it ids
+ Graphics/UI/ObjectIO/Device/Events.hs view
@@ -0,0 +1,143 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Device.Events+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Device.Events contains all type definitions for OS independent events.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Device.Events where++++import Graphics.UI.ObjectIO.StdIOCommon+import Graphics.UI.ObjectIO.Window.Handle(WIDS(..))+import Graphics.UI.ObjectIO.Timer.Table(TimerEvent(..))+import Graphics.UI.ObjectIO.OS.Event+import Graphics.UI.ObjectIO.OS.Types(Rect, OSWindowPtr, OSPictContext)++data	DeviceEvent+ --	Menu events:+ =	MenuTraceEvent		!MenuTraceInfo			-- Menu item has been selected+ |	ToolbarSelection	!Int				-- Toolbar item has been selected (consist item nr)+ --	Receiver events:+ |	ReceiverEvent           !Id				-- A (bi/uni)directional (a)synchronous message event+ --	Timer events:+ |	TimerDeviceEvent	!TimerEvent			-- A timer event+ --	Window/Dialog events:+ |	CompoundScrollAction	!CompoundScrollActionInfo	-- Scrolling should occur in a compound control+ |	ControlGetKeyFocus	!ControlKeyFocusInfo		-- Control has obtained keyboard focus	+ |	ControlLooseKeyFocus	!ControlKeyFocusInfo		-- Control has lost keyboard focus+ |	ControlMouseAction	!ControlMouseActionInfo		-- Mouse action in a control	+ |	ControlSliderAction	!ControlSliderInfo		-- Slider control has been selected	+ |	WindowCANCEL		!WIDS				-- The Cancel button has been pressed+ |	WindowKeyboardAction	!WindowKeyboardActionInfo	-- Keyboard action in a window+ |	WindowMouseAction	!WindowMouseActionInfo		-- Mouse action in a window+ |	WindowOK		!WIDS				-- The Ok button has been pressed	+ |	WindowScrollAction	!WindowScrollActionInfo		-- Scrolling should occur in a window	+ |	WindowUpdate		!UpdateInfo			-- Window and its controls should be updated	+ |	ControlKeyboardAction   !ControlKeyboardActionInfo	-- Keyboard action in a control+ |	ControlSelection        !ControlSelectInfo		-- Control has been selected+ |	WindowActivation        !WIDS				-- Window with id has been made activate+ |	WindowCreateControls    !WIDS				-- Window with id can create its controls+ |	WindowDeactivation      !WIDS				-- Window with id has been made inactivate+ |	WindowInitialise        !WIDS				-- Window with id can evaluate its initialisation action+ |	WindowRequestClose      !WIDS				-- Window with id should be closed+ |	WindowSizeAction        !WindowSizeActionInfo		-- Window has obtained a new size+ --	Process events:+ |	ProcessInitialise					-- The initial event that allows process initialisation+ |	ProcessRequestClose					-- The process should be closed+ |	ProcessRequestOpenFiles	![String]			-- The process should open files+ +data 	MenuTraceInfo+ =	MenuTraceInfo+ 		{ mtId		  :: !Id			-- The Id of the menu that contains the menu item+	  	, mtParents	  :: ![Int]			-- The submenus starting from mtId that contain the menu item (zero based index)+		, mtItemNr	  :: !Int			-- The menu item that has been selected (zero based index)+		, mtModifiers	  :: !Modifiers			-- The modifiers that were pressed at the moment of selection+		}+data	UpdateInfo+ =	UpdateInfo+		{ updWIDS         :: !WIDS			-- The Id of the window/dialogue to be updated+		, updWindowArea   :: !Rect			-- The area of the window/dialogue to be updated (case zero, no update)+		, updControls     :: ![ControlUpdateInfo]	-- For each control to be updated: its item nr and area (in window coordinates)+		, updGContext     :: !(Maybe OSPictContext)	-- The graphics context to be used+		}+data	ControlUpdateInfo+ =	ControlUpdateInfo+		{ cuItemNr        :: !Int			-- The wItemNr of the control+		, cuItemPtr       :: !OSWindowPtr		-- The wItemPtr to the control (can be OSNoWindowPtr)+		, cuArea          :: !Rect			-- The update area of the control (in window coordinates)+		} +data    CompoundScrollActionInfo+ =	CompoundScrollActionInfo+ 		{ csaWIDS	  :: !WIDS			-- The Id/Ptr of the window/dialogue that contains the compound control+		, csaItemNr	  :: !Int			-- The wItemNr  of the compound control+		, csaItemPtr	  :: !OSWindowPtr		-- The wItemPtr of the compound control+		, csaSliderMove	  :: !SliderMove		-- The user action on the compound control+		, csaDirection	  :: !Direction			-- The direction of the scrollbar that is being selected+		}+data	ControlKeyFocusInfo+ =	ControlKeyFocusInfo+ 		{ ckfWIDS	  :: !WIDS			-- The Id/Ptr of the window/dialogue that contains the control+		, ckfItemNr	  :: !Int			-- The wItemNr  of the control+		, ckfItemPtr	  :: !OSWindowPtr		-- The wItemPtr of the control+		}+data	ControlKeyboardActionInfo+ =	ControlKeyboardActionInfo+ 		{ ckWIDS	  :: !WIDS			-- The Id/Ptr of the window/dialogue that contains the control+		, ckItemNr	  :: !Int			-- The wItemNr  of the control+		, ckItemPtr	  :: !OSWindowPtr		-- The wItemPtr of the control+		, ckKeyboardState :: !KeyboardState		-- The KeyboardState of the action+		}+data	ControlMouseActionInfo+ =	ControlMouseActionInfo+ 		{ cmWIDS	  :: !WIDS			-- The Id/Ptr of the window/dialogue that contains the control+		, cmItemNr        :: !Int			-- The wItemNr  of the control+		, cmItemPtr       :: !OSWindowPtr		-- The wItemPtr of the control+		, cmMouseState    :: !MouseState		-- The MouseState of the action+		}+data	ControlSelectInfo+ =	ControlSelectInfo+ 		{ csWIDS	  :: !WIDS			-- The Id/Ptr of the window/dialogue that contains the control+		, csItemNr	  :: !Int			-- The wItemNr  of the selected control+		, csItemPtr	  :: !OSWindowPtr		-- The wItemPtr of the selected control+		, csMoreData	  :: !Int			-- Additional data (index in case of PopUpControls; otherwise zero)+		, csModifiers	  :: !Modifiers			-- The modifiers that were active when the control was selected+		}+data	ControlSliderInfo+ =	ControlSliderInfo+ 		{ cslWIDS	  :: !WIDS			-- The Id/Ptr of the window/dialogue that contains the slider+		, cslItemNr	  :: !Int			-- The wItemNr  of the selected slider+		, cslItemPtr	  :: !OSWindowPtr		-- The wItemPtr of the selected slider+		, cslSliderMove	  :: !SliderMove		-- The user action on the slider+		}+data	WindowKeyboardActionInfo+ =	WindowKeyboardActionInfo+ 		{ wkWIDS	  :: !WIDS			-- The Id/Ptr of the window+		, wkKeyboardState :: !KeyboardState		-- The KeyboardState of the action+		}+data	WindowMouseActionInfo+ =	WindowMouseActionInfo+ 		{ wmWIDS	  :: !WIDS			-- The Id/Ptr of the window+		, wmMouseState	  :: !MouseState		-- The MouseState of the action+		}+data	WindowScrollActionInfo+ =	WindowScrollActionInfo+ 		{ wsaWIDS	  :: !WIDS			-- The Id/Ptr of the window+		, wsaSliderMove	  :: !SliderMove		-- The user action on the window+		, wsaDirection	  :: !Direction			-- The direction of the scrollbar that is being selected+		}+data	WindowSizeActionInfo+ =	WindowSizeActionInfo+ 		{ wsWIDS	  :: !WIDS			-- The Id/Ptr of the window+		, wsSize	  :: !Size			-- The new size of the window (including scrollbars)+		, wsUpdateAll	  :: !Bool			-- The complete content of the window must be redrawn+		}
+ Graphics/UI/ObjectIO/Device/SystemState.hs view
@@ -0,0 +1,54 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Device.Events+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Device.SystemState defines the device administration types and unwrapper +-- functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Device.SystemState+		( module Graphics.UI.ObjectIO.Device.SystemState+		, module Graphics.UI.ObjectIO.Device.Types+		) where+++import Graphics.UI.ObjectIO.Device.Types+import Graphics.UI.ObjectIO.Receiver.Handle+import Graphics.UI.ObjectIO.Window.Handle+import Graphics.UI.ObjectIO.Timer.Handle+import Graphics.UI.ObjectIO.Menu.Handle+++data	DeviceSystemState ps+	= MenuSystemState	(MenuHandles		ps)+	| ReceiverSystemState   (ReceiverHandles 	ps)+	| TimerSystemState	(TimerHandles		ps)+	| WindowSystemState     (WindowHandles 		ps)++toDevice :: DeviceSystemState ps -> Device+toDevice (ReceiverSystemState _) = ReceiverDevice+toDevice (WindowSystemState   _) = WindowDevice+toDevice (TimerSystemState   _)  = TimerDevice+toDevice (MenuSystemState     _) = MenuDevice+++receiverSystemStateGetReceiverHandles :: DeviceSystemState ps -> ReceiverHandles ps+receiverSystemStateGetReceiverHandles (ReceiverSystemState rsHs) = rsHs ++windowSystemStateGetWindowHandles :: DeviceSystemState ps -> WindowHandles ps+windowSystemStateGetWindowHandles (WindowSystemState wsHs) = wsHs++timerSystemStateGetTimerHandles :: DeviceSystemState ps -> TimerHandles ps+timerSystemStateGetTimerHandles (TimerSystemState tsHs) = tsHs++menuSystemStateGetMenuHandles :: DeviceSystemState ps -> MenuHandles ps+menuSystemStateGetMenuHandles (MenuSystemState msHs) = msHs+
+ Graphics/UI/ObjectIO/Device/Types.hs view
@@ -0,0 +1,39 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Device.Types+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Device defines the set of devices and their priority.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Device.Types where+++data	Device				-- The set of devices+	= TimerDevice+	| MenuDevice+	| WindowDevice+	| ReceiverDevice+	| ProcessDevice+	deriving (Eq,Show)++priorityDevice :: Device -> Int+priorityDevice ReceiverDevice = 6+priorityDevice TimerDevice    = 4+priorityDevice MenuDevice     = 3+priorityDevice WindowDevice   = 2+priorityDevice ProcessDevice  = 0++devices = [ ReceiverDevice+	  , TimerDevice+	  , MenuDevice+	  , WindowDevice+	  , ProcessDevice+	  ]
+ Graphics/UI/ObjectIO/Id.hs view
@@ -0,0 +1,119 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Id+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Id defines the various kinds of identification values that identify GUI+-- objects. In addition, an IdTable (implemented as 'FiniteMap') is defined+-- in which all bound GUI objects are administered. +--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Id+          ( Id, RId, R2Id, IdTable+          , IdParent (..)          +          , toId, toRId, toR2Id+          , r2IdtoId, rIdtoId+          , getRIdIn, getR2IdIn, getR2IdOut+          , okMembersIdTable+          , module Graphics.UI.ObjectIO.Device.Types+          , module Graphics.UI.ObjectIO.SystemId+          ) where++++import Graphics.UI.ObjectIO.Device.Types+import Graphics.UI.ObjectIO.SystemId+import Data.IORef+import Data.Unique+import qualified Data.Map as Map++type	Id = Unique++data	RId mess					-- The identification of bi-directional receivers:+ =	RId+ 		{ rid        :: !Unique			-- The identification value+ 		, ridIn      :: !(IORef [mess])		-- The message input  channel+ 		}+ 		+data	R2Id mess resp					-- The identification of bi-directional receivers:+ =	R2Id+ 		{ r2id       :: !Unique			-- The identification value+ 		, r2idIn     :: !(IORef mess)		-- The message input+ 		, r2idOut    :: !(IORef resp)		-- The message output+ 		}+ 		+type	IdTable = Map.Map Unique IdParent		-- all Id entries++data	IdParent+	= IdParent+		{ idpIOId     :: !SystemId		-- Id of parent process+		, idpDevice   :: !Device		-- Device kind of parent GUI object+		, idpId       :: !Id			-- Id of parent GUI object+		}+++toId :: Unique -> Id+toId i = i++toRId :: Unique -> IORef [mess] -> RId mess+toRId i cIn = RId {rid=i,ridIn=cIn}++toR2Id :: Unique -> IORef mess -> IORef resp -> R2Id mess resp+toR2Id i cIn cOut = R2Id {r2id=i,r2idIn=cIn,r2idOut=cOut}++instance Eq (RId mess) where+	(==) rid1 rid2 = rid rid1 == rid rid2++instance Eq (R2Id mess resp) where+	(==) rid1 rid2 = r2id rid1 == r2id rid2+++rIdtoId :: RId mess -> Id+rIdtoId id = rid id++r2IdtoId :: R2Id mess resp -> Id+r2IdtoId id = r2id id+++instance Show Id where+	show id = "Id"+++{-	Additional R(2)Id access operations:+-}++getRIdIn :: RId msg -> IORef [msg]+getRIdIn id = ridIn id++getR2IdIn :: R2Id msg resp -> IORef msg+getR2IdIn id = r2idIn id++getR2IdOut :: R2Id msg resp -> IORef resp+getR2IdOut id = r2idOut id+++--	IdTable operations:++okMembersIdTable :: [Id] -> IdTable -> Bool+okMembersIdTable ids tbl+	= noDuplicates ids && not (any (\key -> elem key $ Map.keys tbl) ids)+	where+		noDuplicates :: (Eq x) => [x] -> Bool+		noDuplicates (x:xs) = not (x `elem` xs) && noDuplicates xs+		noDuplicates _      = True++++		+++++
+ Graphics/UI/ObjectIO/Key.hs view
@@ -0,0 +1,178 @@+-- #hide+-----------------------------------------------------------------------------+-- Module      :  Key+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Key defines the key identifiers for keyboard input and two conversion functions+-- that should be used only internally.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Key+            (	SpecialKey, +		backSpaceKey, beginKey, +		clearKey, +		deleteKey, downKey, +		endKey, enterKey, escapeKey, +		f1Key,  f2Key,  f3Key,  f4Key,  f5Key,  +		f6Key,  f7Key,  f8Key,  f9Key,  f10Key,+		f11Key, f12Key, f13Key, f14Key, f15Key, +		helpKey, +		leftKey, +		pgDownKey, pgUpKey, +		rightKey, +		upKey,+		toSpecialKey, isSpecialKey+	   ) where+++data	SpecialKey = SpecialKey { virtual :: !Int }+	deriving (Eq)++backSpaceVirtualCode	=   8+beginVirtualCode	= 115+clearVirtualCode	=  71+deleteVirtualCode	= 117+downVirtualCode		= 125+endVirtualCode		= 119+enterVirtualCode	=  13+escapeVirtualCode	=  53+f1VirtualCode		= 122+f2VirtualCode		= 120+f3VirtualCode		=  99+f4VirtualCode		= 118+f5VirtualCode		=  96+f6VirtualCode		=  97+f7VirtualCode		=  98+f8VirtualCode		= 100+f9VirtualCode		= 101+f10VirtualCode		= 109+f11VirtualCode		= 103+f12VirtualCode		= 111+f13VirtualCode		= 105+f14VirtualCode		= 107+f15VirtualCode		= 113+helpVirtualCode		= 114+leftVirtualCode		= 123+pgDownVirtualCode	= 121+pgUpVirtualCode		= 116+rightVirtualCode	= 124+upVirtualCode		= 126++instance Show SpecialKey where		-- Name of the SpecialKey+	show key+		= if code==backSpaceVirtualCode then "BackSpaceKey" else -- BackSpace+		  if code==beginVirtualCode     then "BeginKey"     else -- Begin of text+		  if code==clearVirtualCode     then "ClearKey"     else -- Clear+		  if code==deleteVirtualCode    then "DeleteKey"    else -- Delete+		  if code==downVirtualCode      then "DownKey"      else -- Arrow down+		  if code==endVirtualCode       then "EndKey"       else -- End of text+		  if code==enterVirtualCode     then "EnterKey"     else -- Enter+		  if code==escapeVirtualCode    then "EscapeKey"    else -- Escape+		  if code==f1VirtualCode        then "F1Key"        else -- Function 1+		  if code==f2VirtualCode        then "F2Key"        else -- Function 2+		  if code==f3VirtualCode        then "F3Key"        else -- Function 3+		  if code==f4VirtualCode        then "F4Key"        else -- Function 4+		  if code==f5VirtualCode        then "F5Key"        else -- Function 5+		  if code==f6VirtualCode        then "F6Key"        else -- Function 6+		  if code==f7VirtualCode        then "F7Key"        else -- Function 7+		  if code==f8VirtualCode        then "F8Key"        else -- Function 8+		  if code==f9VirtualCode        then "F9Key"        else -- Function 9+		  if code==f10VirtualCode       then "F10Key"       else -- Function 10+		  if code==f11VirtualCode       then "F11Key"       else -- Function 11+		  if code==f12VirtualCode       then "F12Key"       else -- Function 12+		  if code==f13VirtualCode       then "F13Key"       else -- Function 13+		  if code==f14VirtualCode       then "F14Key"       else -- Function 14+		  if code==f15VirtualCode       then "F15Key"       else -- Function 15+		  if code==helpVirtualCode      then "HelpKey"      else -- Help+		  if code==leftVirtualCode      then "LeftKey"      else -- Arrow left+		  if code==pgDownVirtualCode    then "PgDownKey"    else -- Page down+		  if code==pgUpVirtualCode      then "PgUpKey"      else -- Page up+		  if code==rightVirtualCode     then "RightKey"     else -- Arrow right+		  if code==upVirtualCode        then "UpKey"        else --Arrow up+		                                     "toSpecialKey " ++ show code+		where+			code = virtual key++backSpaceKey	:: SpecialKey;		backSpaceKey	= SpecialKey {virtual=backSpaceVirtualCode}	-- BackSpace+beginKey	:: SpecialKey;		beginKey	= SpecialKey {virtual=beginVirtualCode}		-- Begin of text+clearKey	:: SpecialKey;		clearKey	= SpecialKey {virtual=clearVirtualCode}		-- Clear+deleteKey	:: SpecialKey;		deleteKey	= SpecialKey {virtual=deleteVirtualCode}	-- Delete+downKey		:: SpecialKey;		downKey		= SpecialKey {virtual=downVirtualCode}		-- Arrow down+endKey		:: SpecialKey;		endKey		= SpecialKey {virtual=endVirtualCode}		-- End of text+enterKey	:: SpecialKey;		enterKey	= SpecialKey {virtual=enterVirtualCode}		-- Enter+escapeKey	:: SpecialKey;		escapeKey	= SpecialKey {virtual=escapeVirtualCode}	-- Escape+f1Key		:: SpecialKey;		f1Key		= SpecialKey {virtual=f1VirtualCode}		-- Function 1+f2Key		:: SpecialKey;		f2Key		= SpecialKey {virtual=f2VirtualCode}		-- Function 2+f3Key		:: SpecialKey;		f3Key		= SpecialKey {virtual=f3VirtualCode}		-- Function 3+f4Key		:: SpecialKey;		f4Key		= SpecialKey {virtual=f4VirtualCode}		-- Function 4+f5Key		:: SpecialKey;		f5Key		= SpecialKey {virtual=f5VirtualCode}		-- Function 5+f6Key		:: SpecialKey;		f6Key		= SpecialKey {virtual=f6VirtualCode}		-- Function 6+f7Key		:: SpecialKey;		f7Key		= SpecialKey {virtual=f7VirtualCode}		-- Function 7+f8Key		:: SpecialKey;		f8Key		= SpecialKey {virtual=f8VirtualCode}		-- Function 8+f9Key		:: SpecialKey;		f9Key		= SpecialKey {virtual=f9VirtualCode}		-- Function 9+f10Key		:: SpecialKey;		f10Key		= SpecialKey {virtual=f10VirtualCode}		-- Function 10+f11Key		:: SpecialKey;		f11Key		= SpecialKey {virtual=f11VirtualCode}		-- Function 11+f12Key		:: SpecialKey;		f12Key		= SpecialKey {virtual=f12VirtualCode}		-- Function 12+f13Key		:: SpecialKey;		f13Key		= SpecialKey {virtual=f13VirtualCode}		-- Function 13+f14Key		:: SpecialKey;		f14Key		= SpecialKey {virtual=f14VirtualCode}		-- Function 14+f15Key		:: SpecialKey;		f15Key		= SpecialKey {virtual=f15VirtualCode}		-- Function 15+helpKey		:: SpecialKey;		helpKey		= SpecialKey {virtual=helpVirtualCode}		-- Help+leftKey		:: SpecialKey;		leftKey		= SpecialKey {virtual=leftVirtualCode}		-- Arrow left+pgDownKey	:: SpecialKey;		pgDownKey	= SpecialKey {virtual=pgDownVirtualCode}	-- Page down+pgUpKey		:: SpecialKey;		pgUpKey		= SpecialKey {virtual=pgUpVirtualCode}		-- Page up+rightKey	:: SpecialKey;		rightKey	= SpecialKey {virtual=rightVirtualCode}		-- Arrow right+upKey		:: SpecialKey;		upKey		= SpecialKey {virtual=upVirtualCode}		-- Arrow up++toSpecialKey :: Int -> SpecialKey	-- Convert Int to SpecialKey+toSpecialKey specialkey+	= SpecialKey {virtual=specialkey}++isSpecialKey :: Int -> Bool		-- Check for one of the upper SpecialKeys+isSpecialKey specialKey+	= containsSorted specialKey virtualKeyCodes+	where+		containsSorted :: Int -> [Int] -> Bool+		containsSorted x (y:ys)+			| x>y       = containsSorted x ys+			| otherwise = x==y+		containsSorted _ _+			= False++virtualKeyCodes :: [Int]		-- The < sorted list of virtual key codes+virtualKeyCodes+	= [ backSpaceVirtualCode	--   8+	  , escapeVirtualCode		--  53+	  , clearVirtualCode		--  71+	  , enterVirtualCode		--  76+	  , f5VirtualCode		--  96+	  , f6VirtualCode		--  97+	  , f7VirtualCode		--  98+	  , f3VirtualCode		--  99+	  , f8VirtualCode		-- 100+	  , f9VirtualCode		-- 101+	  , f11VirtualCode		-- 103+	  , f13VirtualCode		-- 105+	  , f14VirtualCode		-- 107+	  , f10VirtualCode		-- 109+	  , f12VirtualCode		-- 111+	  , f15VirtualCode		-- 113+	  , helpVirtualCode		-- 114+	  , beginVirtualCode		-- 115+	  , pgUpVirtualCode		-- 116+	  , deleteVirtualCode		-- 117+	  , f4VirtualCode		-- 118+	  , endVirtualCode		-- 119+	  , f2VirtualCode		-- 120+	  , pgDownVirtualCode		-- 121+	  , f1VirtualCode		-- 122+	  , leftVirtualCode		-- 123+	  , rightVirtualCode		-- 124+	  , downVirtualCode		-- 125+	  , upVirtualCode		-- 126+	  ]
+ Graphics/UI/ObjectIO/KeyFocus.hs view
@@ -0,0 +1,122 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  KeyFocus+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.KeyFocus where++++import	Graphics.UI.ObjectIO.CommonDef+import  Data.List(find)+++data	KeyFocus+	= KeyFocus+		{ kfItem    :: !(Maybe Int)	-- Case (Just nr): the item with (wItemNr nr) has the keyboard input focus; Nothing: no item has focus+		, kfItems   :: ![FocusItem]	-- The items of the window that can have the keyboard input focus+		}+data	FocusItem+	= FocusItem+		{ focusNr   :: !Int		-- The item nr of the item+		, focusShow :: !Bool		-- Flag: True iff item is visible+		}++isShownFocusItem :: FocusItem -> Bool+isShownFocusItem = focusShow++eqFocusItemNr :: Int -> FocusItem -> Bool+eqFocusItemNr nr item = nr == focusNr item++newFocusItems :: [FocusItem] -> KeyFocus+newFocusItems items+	= KeyFocus+		{ kfItem  = fmap focusNr (find isShownFocusItem items)+		, kfItems = items+		}++openFocusItems :: (Maybe Int) -> [FocusItem] -> KeyFocus -> KeyFocus+openFocusItems (Just behind) new kf@(KeyFocus{kfItems=kfItems})+	= kf{kfItems=openFocusItems' behind new kfItems}+	where+		openFocusItems' :: Int -> [FocusItem] -> [FocusItem] -> [FocusItem]+		openFocusItems' behind new ((item@(FocusItem{focusNr=focusNr})):items)+			| behind==focusNr	= (item : (new++items))+			| otherwise		= (item : openFocusItems' behind new items)+		openFocusItems' _ new _+			= new+openFocusItems _ items kf@(KeyFocus{kfItems=kfItems})+	= kf{kfItems = kfItems++items}++closeFocusItems :: [Int] -> KeyFocus -> KeyFocus+closeFocusItems nrs kf@(KeyFocus{kfItem=kfItem,kfItems=kfItems})+	= kf{ kfItems = closeFocusItems' nrs kfItems+	    , kfItem  = case kfItem of+	    		  Nothing     -> Nothing+	    		  Just kfItem -> if kfItem `elem` nrs then Nothing else Just kfItem+	    }+	where+		closeFocusItems' :: [Int] -> [FocusItem] -> [FocusItem]+		closeFocusItems' []   _ = []+		closeFocusItems' nrs [] = []+		closeFocusItems' nrs (item:items) =+		    if found then closeFocusItems' nrs1 items+		    else (item : closeFocusItems' nrs1 items)+		    where+			(found,nrs1) = removeCheck (focusNr item) nrs++showFocusItems :: [Int] -> KeyFocus -> KeyFocus+showFocusItems nrs kf@(KeyFocus{kfItems=kfItems})+	= kf{kfItems=setShowFocusItems True nrs kfItems}++setShowFocusItems :: Bool -> [Int] -> [FocusItem] -> [FocusItem]+setShowFocusItems show  [] _  = []+setShowFocusItems show nrs [] = []+setShowFocusItems show nrs (item:items) =	+	(if found then item{focusShow=show} else item) : setShowFocusItems show nrs1 items+	where+	   (found,nrs1)	= removeCheck (focusNr item) nrs+	   ++hideFocusItems :: [Int] -> KeyFocus -> KeyFocus+hideFocusItems nrs kf@(KeyFocus {kfItem=kfItem,kfItems=kfItems})+	= kf{ kfItems	= setShowFocusItems False nrs kfItems+	    , kfItem	= case kfItem of +	     		    Nothing 	-> Nothing+	     		    Just kfItem -> if kfItem `elem` nrs then Nothing else Just kfItem+	    }++getCurrentFocusItem :: KeyFocus -> Maybe Int+getCurrentFocusItem = kfItem++setNoFocusItem :: KeyFocus -> KeyFocus+setNoFocusItem kf = kf{kfItem=Nothing}++setNewFocusItem :: Int -> KeyFocus -> KeyFocus+setNewFocusItem new kf+	= kf{kfItem=Just new}++setNextFocusItem :: (Maybe Int) -> KeyFocus -> (Maybe Int,KeyFocus)+setNextFocusItem (Just behind) kf@(KeyFocus {kfItems=kfItems}) =+	let (before,item_after)	= span (not . (eqFocusItemNr behind)) kfItems+	in +	  if null item_after then (Nothing,kf)+	  else+	     case find isShownFocusItem (tail item_after) of+	       Just (item@(FocusItem {focusNr=nr})) -> (Just nr, kf{kfItem=Just nr})+	       Nothing -> case find isShownFocusItem before of+	  		    Just (item@(FocusItem {focusNr=nr})) -> (Just nr, kf{kfItem=Just nr})+			    Nothing -> (Nothing, kf)+			 +setNextFocusItem Nothing kf@(KeyFocus {kfItems=kfItems}) =+	case find isShownFocusItem kfItems of+	  Nothing -> (Nothing,kf{kfItem=Nothing})+ 	  Just (item@(FocusItem {focusNr=nr})) -> (Just nr, kf{kfItem=Just nr})
+ Graphics/UI/ObjectIO/Layout.hs view
@@ -0,0 +1,533 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  KeyFocus+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Layout contains the basic layout calculation functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Layout+		( LayoutItem(..), Root(..), Relative+              	, getLayoutItem, layoutItems+              	) where+++import Prelude hiding (Either(..))	-- Added to hide Left and Right+import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.Window.Handle(LayoutInfo(..), Origin)+++layoutFatalError :: String -> String -> x+layoutFatalError rule message+	= dumpFatalError rule "Layout" message+++--	The data types used for calculating the layout:+data	LayoutItem+	= LayoutItem+		{ liId        :: !Id		-- The Id      of the item+		, liItemPos   :: ItemPos	-- The ItemPos of the item+		, liItemSize  :: !Size		-- The Size    of the item+		}+data	Root+	= Root+		{ rootItem    :: !LayoutItem	-- The original item that has been laid out+		, rootPos     :: !Vector2	-- The exact location of the item relative to current origin+		, rootTree    :: ![Relative]	-- The dependent items+		}+data	Relative+	= Relative+		{ relativeItem :: !LayoutItem	-- The original item that has been laid out+		, relativePos  :: !Vector2	-- The exact location of the item relative to current origin+		}++--	Basic operations on LayoutItems, Roots, and Relatives:+identifyLayoutItem :: Id -> LayoutItem -> Bool+identifyLayoutItem id item+	= id==liId item++identifyRoot :: Id -> Root -> Bool+identifyRoot id root+	= identifyLayoutItem id (rootItem root)++identifyRelative :: Id -> Relative -> Bool+identifyRelative id relative+	= identifyLayoutItem id (relativeItem relative)++{-	removeRoot id removes that Root from the [Root] that either:+		* can be identified by id, or+		* contains a Relative that can be identified by id+-}+removeRoot :: Id -> [Root] -> (Bool,Root,[Root])+removeRoot id (item:items)+	| identifyRoot id item+		= (True,item,items)+	| any (identifyRelative id) (rootTree item)+		= (True,item,items)+	| otherwise+		= let (found,root,items1) = removeRoot id items+		  in  (found,root,item:items1)+removeRoot _ items+	= (False,undefined,items)+++{-	getLayoutItemPosSize id retrieves the position and size of:+		* the Root argument in case id identifies the root, or+		* the Relative that can be identified by id+-}+getLayoutItemPosSize :: Id -> Root -> (Bool,Vector2,Size)+getLayoutItemPosSize id item+	| identifyRoot id item+		= (True,rootPos item,liItemSize $ rootItem $ item)+	| not found+		= (False,zero,zero)+	| otherwise+		= (True,relativePos relative,liItemSize $ relativeItem $ relative)+	where+		(found,relative) = cselect (identifyRelative id) undefined (rootTree item)+++{-	shiftRelative v shifts the position of the Relative argument by v.+-}+shiftRelative :: Vector2 -> Relative -> Relative+shiftRelative v item+	= item {relativePos=relativePos item+v}++{-	shiftRoot v shifts the position of the Root argument and its Relatives by v.+-}+shiftRoot :: Vector2 -> Root -> Root+shiftRoot offset item+	= item {rootPos=rootPos item+offset,rootTree=map (shiftRelative offset) (rootTree item)}++{-	getRootBoundingBox calculates the smallest enclosing rectangle of the Root+	argument and its Relatives.+-}+getRootBoundingBox :: Root -> Rect+getRootBoundingBox (Root {rootPos=rootPos,rootItem=rootItem,rootTree=rootTree})+	= getRelativeBoundingBox rootTree (posSizeToRect (Point2 {x=vx rootPos,y=vy rootPos}) (liItemSize rootItem))+	where+		getRelativeBoundingBox :: [Relative] -> Rect -> Rect+		getRelativeBoundingBox (item:items) boundBox+			= getRelativeBoundingBox items (mergeBoundingBox boundBox (posSizeToRect (Point2 {x=vx v,y=vy v}) (liItemSize $ relativeItem $ item)))+			where+				v = relativePos item+				+				mergeBoundingBox :: Rect -> Rect -> Rect+				mergeBoundingBox (Rect {rleft=lR,rtop=tR,rright=rR,rbottom=bR}) (Rect {rleft=lB,rtop=tB,rright=rB,rbottom=bB})+					= Rect {rleft=min lR lB,rtop=min tR tB,rright=max rR rB,rbottom=max bR bB}+		getRelativeBoundingBox _ boundBox+			= boundBox++{-	getLayoutItem id roots+		retrieves the position (Vector2) and size (Size) of the item identified by id.+		In case the item is a relative, it is removed from the [Root].+		In case the item is a root, it is removed only if it has an empty layout tree.+		The LayoutInfo classifies the ItemPos of the layout root of the retrieved item.+	getLayoutItem returns a runtime error in case no item could be identified.+-}+getLayoutItem :: Id -> [Root] -> (LayoutInfo,Vector2,Size,[Root])+getLayoutItem id items@(root:roots)+	| identifyRoot id root+		= if   null depends+		  then (layoutInfo,corner,size,roots)+		  else (layoutInfo,corner,size,items)+	| inTree+		= (layoutInfo,rPos,rSize,root {rootTree=depends1}:roots)+	| otherwise+		= let (layoutInfo1,pos,size1,roots1) = getLayoutItem id roots+		  in  (layoutInfo1,pos,size1,root:roots1)+	where+		corner                       = rootPos root+		size                         = liItemSize $ rootItem $ root+		depends                      = rootTree root+		(inTree,rPos,rSize,depends1) = getRelativeItem id depends+		layoutInfo                   = case liItemPos $ rootItem $ root of+		                                    (Fix,_)           -> LayoutFix+		                               --   (_,OffsetFun i f) -> LayoutFun i f+		                                    _                 -> LayoutFrame+		+		getRelativeItem :: Id -> [Relative] -> (Bool,Vector2,Size,[Relative])+		getRelativeItem id (item:items)+			| identifyRelative id item+				= (True,relativePos item,liItemSize $ relativeItem $ item,items)+			| otherwise+				= let (found,pos,size,items1) = getRelativeItem id items+				  in  (found,pos,size,item:items1)+		getRelativeItem _ items+			= (False,zero,zero,items)+getLayoutItem id _+	= layoutFatalError "getLayoutItem" "Unknown Id"+++{-	layoutItems is the actual layout algorithm.+	It calculates the precise position (in pixels) of each LayoutItem.+	The position is calculated from a zero origin.+	Assumptions:+	-	All LayoutItems have a layout element ItemPos.+	-	All relative references to previous elements have been identified (so LeftOfPrev --> LeftOf id and so on).+-}+layoutItems :: (Int,Int) -> (Int,Int) -> (Int,Int) -> Size -> Size -> [(ViewDomain,Point2)] -> [LayoutItem] -> (Size,[Root])+layoutItems hMargins@(lMargin,rMargin) vMargins@(tMargin,bMargin) itemSpaces reqSize minSize orientations layoutItems+	= (finalSize,roots1)+	where+		reqSize1     = if reqSize/=zero then Size {w=w reqSize-lMargin-rMargin,h=h reqSize-tMargin-bMargin} else reqSize+		layoutItems1 = sortLayoutItems layoutItems+		(_,roots)    = foldr (calcRootPosition itemSpaces orientations) (0,[]) layoutItems1+		size         = calcAreaSize orientations roots reqSize1 minSize+		roots1       = foldr (calcFramePosition hMargins vMargins orientations size) [] roots+		finalSize    = Size {w=lMargin+w size+rMargin,h=tMargin+h size+bMargin}+++{-	sortLayoutItems sorts the list of item positions such that relatively laynout items +	are placed immediately(!!) behind their target items. They are not placed in the rootTree+	of the target item. This is done by calcRootPosition. +	sortLayoutItems failures:+	-	a cyclic dependency has been located: the Ids are printed and computation stops+	-	unknown references have been located: the Ids are printed and computation stops+-}+sortLayoutItems :: [LayoutItem] -> [LayoutItem]+sortLayoutItems layoutItems+	= sortLayoutItems' [] (lineItems++relItems)+	where+		(lineItems,relItems) = divide (\item->isLine (liItemPos item)) layoutItems+		+		sortLayoutItems' :: [LayoutItem] -> [LayoutItem] -> [LayoutItem]+		sortLayoutItems' done [] = done+		sortLayoutItems' done (item1:todo)+			| not isrelative+				= sortLayoutItems' (item1:done) todo+			| otherwise+				= let (done1,chain,todo1) = getItemPosChain id2 done [item1] todo+				  in  (sortLayoutItems' (insertItemPosChain chain done1) todo1)+			where+				pos1             = liItemPos item1+				(isrelative,id2) = isRelative pos1+				+				getItemPosChain :: Id -> [LayoutItem] -> [LayoutItem] -> [LayoutItem] -> ([LayoutItem],[LayoutItem],[LayoutItem])+				getItemPosChain nextId done chain todo+					| in_chain+						= layoutFatalError "calculating layout" "cyclic dependency between Ids"+					| in_done+						= (done,chain,todo)+					| not in_todo+						= layoutFatalError "calculating layout" "reference to unknown Id"+					| not isrelative+						= (done,next:chain,todo1)+					| otherwise+						= getItemPosChain id2 done (next:chain) todo1+					where+						in_chain             = any (identifyLayoutItem nextId) chain+						in_done              = any (identifyLayoutItem nextId) done+						(in_todo,next,todo1) = remove (identifyLayoutItem nextId) undefined todo+						nextPos              = liItemPos next+						(isrelative,id2)     = isRelative nextPos+				+				insertItemPosChain :: [LayoutItem] -> [LayoutItem] -> [LayoutItem]+				insertItemPosChain chain@(final:_) done+					| not isrelative+						= chain'++done+					| otherwise+						= insertchain id chain' done+					where+						(isrelative,id) = isRelative (liItemPos final)+						chain'          = reverse chain+						+						insertchain :: Id -> [LayoutItem] -> [LayoutItem] -> [LayoutItem]+						insertchain id chain (item:items)+							| identifyLayoutItem id item+								= chain++(item:items)+							| otherwise+								= item:(insertchain id chain items)+						insertchain _ chain _+							= chain+				insertItemPosChain _ done	-- this alternative will actually never be reached+					= done+++{-	Calculate the positions of line oriented items and the space they occupy. +	Place relatively placed items in the root tree of the item referred to.+	Items that are positioned at a fixed spot (Fix pos) are laid out relative to the given origin.+	Assumptions:+	-	All relative layout positions refer to existing elements which must occur in the done list.+	+	Note:	Renter = Right or Center,+		Corner = LeftTop, RightTop, LeftBottom or RightBottom+-}+calcRootPosition :: (Int,Int) -> [(ViewDomain,Origin)] -> LayoutItem -> (Int,[Root]) -> (Int,[Root])+calcRootPosition itemSpaces orientations item1 sDone@(sizeY,done)+	| isfix+		= let	(_,origin) = head orientations+			itemoffset = itemPosOffset fixpos orientations+			pos        = itemoffset-toVector origin+			item1'     = Root {rootItem=item1,rootPos=pos,rootTree=[]}+		  in	(sizeY, item1':done)+	| isrelative && exists+		= let	(sizeY',item2') = if   isRelativeX pos1+			                  then calcXPosition itemSpaces orientations item1 id2 sizeY item2+			                  else calcYPosition itemSpaces orientations item1 id2 sizeY item2+		  in	(sizeY',item2':done1)+	| isrelative+		= layoutFatalError "calculating layout" "reference to unknown Id (not caught by sortLayoutItems)"+	| isCorner pos1+		= let	item1' = Root {rootItem=item1,rootPos=zero,rootTree=[]}+		  in	(sizeY, item1':done)+	| otherwise+		= let	height       = h $ liItemSize $ item1+			itemoffset   = itemPosOffset (snd pos1) orientations+			yOffset      = vy itemoffset+			yOffset1     = if sizeY==0 then yOffset else snd itemSpaces+yOffset+		  in	(max sizeY (sizeY+yOffset1+height), (Root {rootItem=item1,rootPos=zero {vy=sizeY+yOffset1},rootTree=[]}):done)+	where+		pos1                 = liItemPos item1+		(isfix,fixpos)       = isFix pos1+		(isrelative,id2)     = isRelative pos1+		(exists,item2,done1) = removeRoot id2 done+		+	{-	calcXPosition calculates the position of item1 which is horizontally relative to the item identified by id2.+		This item is either item2 or occurs in the layout tree of item2.+		item1 is placed as a Relative in the layout tree of item2.+	-}+		calcXPosition :: (Int,Int) -> [(ViewDomain,Origin)] -> LayoutItem -> Id -> Int -> Root -> (Int,Root)+		calcXPosition itemSpaces orientations item1 id2 sizeY item2@(Root {rootItem=root2,rootTree=tree2})+			| not ok+				= layoutFatalError "calcXPosition" "dependent item could not be found in rootTree"+			| otherwise+				= ( if isCorner pos2 || isfix2 then sizeY else max (t+h size1) sizeY+				  , item2 {rootTree=depend:tree2}+				  )+			where+				pos1               = liItemPos  item1+				size1              = liItemSize item1+				pos2               = liItemPos  root2+				(isfix2,_)         = isFix pos2+				l                  = if   isLeftOf pos1+				                     then vx corner2-w size1-fst itemSpaces+vx offset+				                     else vx corner2+w size2+fst itemSpaces+vx offset+				t                  = vy corner2+vy offset+				offset             = itemPosOffset (snd pos1) orientations+				(ok,corner2,size2) = getLayoutItemPosSize id2 item2+				depend             = Relative {relativeItem=item1,relativePos=Vector2 {vx=l,vy=t}}+		+	{-	calcYPosition calculates the position of item1 which is vertically relative to the item identified by id2.+		This item is either item2 or occurs in the layout tree of item2.+		item1 is placed as a Relative in the layout tree of item2.+	-}+		calcYPosition :: (Int,Int) -> [(ViewDomain,Origin)] -> LayoutItem -> Id -> Int -> Root -> (Int,Root)+		calcYPosition itemSpaces orientations item1 id2 sizeY item2@(Root {rootItem=root2,rootTree=tree2})+			| not ok+				= layoutFatalError "calcXPosition" "dependent item could not be found in rootTree"+			| otherwise+				= ( if isCorner pos2 || isfix2 then sizeY else max (t+h size1) sizeY+				  , item2 {rootTree=depend:tree2}+				  )+			where+				pos1               = liItemPos  item1+				size1              = liItemSize item1+				pos2               = liItemPos  root2+				(isfix2,_)         = isFix pos2+				l                  = vx corner2+vx offset+				t                  = if   isBelow pos1+				                     then vy corner2+h size2+snd itemSpaces+vy offset+				                     else vy corner2-h size1-snd itemSpaces+vy offset+				offset             = itemPosOffset (snd pos1) orientations+				(ok,corner2,size2) = getLayoutItemPosSize id2 item2+				depend             = Relative {relativeItem=item1,relativePos=Vector2 {vx=l,vy=t}}+++{-	In case no requested size is given (requested size==zero), calculate the actual +	width and height of the overall area. The overall area is the smallest enclosing +	rectangle of the line and fix layout items, provided it fits the corner oriented items.+	In case of a requested size, yield this size.+-}+calcAreaSize :: [(ViewDomain,Origin)] -> [Root] -> Size -> Size -> Size+calcAreaSize orientations roots reqSize minimumSize+	| reqSize/=zero+		= stretchSize minimumSize reqSize+	| otherwise+		= foldr (fitRootInArea origin orientations) minimumSize roots+	where+		origin = snd (head orientations)+		+		stretchSize :: Size -> Size -> Size+		stretchSize size1 size2 = Size {w=max (w size1) (w size2), h=max (h size1) (h size2)}+		+	--	fitRootInArea stretches the Size argument such that the bounding box of the Root argument fits. +		fitRootInArea :: Origin -> [(ViewDomain,Origin)] -> Root -> Size -> Size+		fitRootInArea origin orientations root frameSize+			= stretchSize frameSize (Size {w=reqX,h=reqY})+			where+				corner       = rootPos root+				size         = liItemSize $ rootItem $ root+				(loc,offset) = liItemPos  $ rootItem $ root+				v            = itemPosOffset offset orientations+				itemBoundBox = getRootBoundingBox root+				(reqX,reqY)  = delimit loc itemBoundBox+				+				delimit :: ItemLoc -> Rect -> (Int,Int)+				+				delimit Fix (Rect {rright=rright,rbottom=rbottom})+					| r'<=0 || b'<=0+						= (0,0)+					| otherwise+						= (r',b')+					where+						r' = rright -x origin+						b' = rbottom-y origin+				+				delimit LeftTop (Rect {rright=rright,rbottom=rbottom})+					= (rright-vx lefttop,rbottom-vy lefttop)+					where+						lefttop = corner-v+				+				delimit RightTop (Rect {rleft=rleft,rbottom=rbottom})+					= (vx righttop-rleft,rbottom-vy righttop)+					where+						righttop = corner+zero {vx=w size}-v+				+				delimit LeftBottom (Rect {rtop=rtop,rright=rright})+					= (rright-vx leftbottom,vy leftbottom-rtop)+					where+						leftbottom = corner+zero {vy=h size}-v+				+				delimit RightBottom (Rect {rleft=rleft,rtop=rtop})+					= (vx rightbottom-rleft,vy rightbottom-rtop)+					where+						rightbottom = corner+toVector size-v+				+				delimit Left (Rect {rright=rright,rbottom=rbottom})+					= (rright-left,rbottom)+					where+						left = vx corner-vx v+				+				delimit Center (Rect {rleft=rleft,rright=rright,rbottom=rbottom})+					= (rright-rleft,rbottom)+				+				delimit Right (Rect {rleft=rleft,rbottom=rbottom})+					= (right-rleft,rbottom)+					where+						right = vx corner+w size-vy v+++{-	calcFramePosition calculates the layout of all frame aligned items. In addition it adds the margin offsets+	to each item. +-}+calcFramePosition :: (Int,Int) -> (Int,Int) -> [(ViewDomain,Origin)] -> Size -> Root -> [Root] -> [Root]+calcFramePosition hMargins@(lMargin,_) vMargins@(tMargin,_) orientations sizeArea@(Size {w=width,h=height}) item done+	| isRenter pos || isCorner pos+		= let	sizeItem  = liItemSize $ rootItem $ item+			widthLeft = width-w sizeItem+			v         = if   isCorner pos+			            then cornerShift  orientations pos sizeItem sizeArea+			            else Vector2 {vx=lineShift orientations pos widthLeft,vy=0}+			shift     = Vector2 {vx=vx v+lMargin,vy=vy v+tMargin}+			item'     = shiftRoot shift item+		  in	item':done+	| otherwise+		= (shiftRoot (Vector2 {vx=lMargin,vy=tMargin}) item):done+	where+		pos = liItemPos $ rootItem $ item+		+		lineShift :: [(ViewDomain,Origin)] -> ItemPos -> Int -> Int+		lineShift orientations (Center,offset) space+			= round ((fromIntegral space)/2.0) + vx (itemPosOffset offset orientations)+		lineShift orientations (_,offset) space+			= space + vx (itemPosOffset offset orientations)+		+		cornerShift :: [(ViewDomain,Origin)] -> ItemPos -> Size -> Size -> Vector2+		cornerShift orientations (LeftTop,offset) _ _+			= itemPosOffset offset orientations+		cornerShift orientations (RightTop,offset) (Size {w=wItem}) (Size {w=w})+			= v {vx=w-wItem+vx v}+			where+				v = itemPosOffset offset orientations+		cornerShift orientations (LeftBottom,offset) (Size {h=hItem}) (Size {h=h})+			= v {vy=h-hItem+vy v}+			where+				v = itemPosOffset offset orientations+		cornerShift orientations (RightBottom,offset) (Size {w=wItem,h=hItem}) (Size {w=w,h=h})+			= Vector2 {vx=w-wItem+vx v,vy=h-hItem+vy v}+			where+				v = itemPosOffset offset orientations+++--	itemPosOffset calculates the actual offset vector of the given ItemOffset value.++itemPosOffset :: ItemOffset -> [(ViewDomain,Origin)] -> Vector2+{-+itemPosOffset NoOffset _+	= zero+-}+itemPosOffset {-(OffsetVector v)-}v _+	= v+{-+itemPosOffset (OffsetFun i f) orientations+	| isBetween i 1 (length orientations)+		= f (orientations!!(i-1))+	| otherwise+		= layoutFatalError "calculating OffsetFun" ("illegal ParentIndex value: "++show i)+-}+++--	ItemPos predicates.++isFix :: ItemPos -> (Bool,ItemOffset)+isFix (Fix,offset) = (True, offset)+isFix _            = (False,zero) --NoOffset++isLine :: ItemPos -> Bool+isLine (Left,  _) = True+isLine (Center,_) = True+isLine (Right, _) = True+isLine _          = False++isRelative :: ItemPos -> (Bool,Id)+isRelative (LeftOf  id,_) = (True,id)+isRelative (RightTo id,_) = (True,id)+isRelative (Above   id,_) = (True,id)+isRelative (Below   id,_) = (True,id)+isRelative _              = (False,undefined)++isRelativeX :: ItemPos -> Bool+isRelativeX (LeftOf  _,_) = True+isRelativeX (RightTo _,_) = True+isRelativeX _             = False++isRenter :: ItemPos -> Bool+isRenter (Center,_) = True+isRenter (Right, _) = True+isRenter _          = False++isCorner :: ItemPos -> Bool+isCorner (LeftTop,     _) = True+isCorner (RightTop,    _) = True+isCorner (LeftBottom,  _) = True+isCorner (RightBottom, _) = True+isCorner _                = False++isLeftOf :: ItemPos -> Bool+isLeftOf (LeftOf _,_) = True+isLeftOf _            = False++isBelow  :: ItemPos -> Bool+isBelow  (Below _,_) = True+isBelow  _           = False+++--	Auxiliary functions:++divide :: Cond x -> [x] -> ([x],[x])	-- divide cond xs = (filter cond xs,filter (not o cond) xs)+divide f (x:xs)+	| f x       = (x:yes,no)+	| otherwise = (yes,x:no)+	where+		(yes,no) = divide f xs+divide _ _+	= ([],[])
+ Graphics/UI/ObjectIO/Menu/Access.hs view
@@ -0,0 +1,44 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Validate+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Menu.Access where+++import	Graphics.UI.ObjectIO.Menu.Handle+import  Graphics.UI.ObjectIO.StdIOBasic(Title)+import  Graphics.UI.ObjectIO.StdId(Id)+import	Graphics.UI.ObjectIO.OS.Menu+import	Graphics.UI.ObjectIO.OS.Types(OSMenu)+++menuStateHandleGetHandle :: MenuStateHandle ps -> OSMenu+menuStateHandleGetHandle (MenuStateHandle (MenuLSHandle {mlsHandle=MenuHandle {mHandle=mHandle}})) = mHandle++menuStateHandleGetMenuId :: MenuStateHandle ps -> Id+menuStateHandleGetMenuId (MenuStateHandle (MenuLSHandle {mlsHandle=MenuHandle {mMenuId=mMenuId}})) = mMenuId++menuStateHandleGetTitle :: MenuStateHandle ps -> Title+menuStateHandleGetTitle (MenuStateHandle (MenuLSHandle {mlsHandle=MenuHandle {mTitle=mTitle}})) = mTitle++menuStateHandleGetSelect :: MenuStateHandle ps -> Bool+menuStateHandleGetSelect (MenuStateHandle (MenuLSHandle {mlsHandle=MenuHandle {mSelect=mSelect}})) = mSelect+++menuStateHandleSetHandle :: OSMenu -> MenuStateHandle ps -> MenuStateHandle ps+menuStateHandleSetHandle menu (MenuStateHandle mlsH@(MenuLSHandle {mlsHandle=mH})) = MenuStateHandle mlsH{mlsHandle=mH{mHandle=menu}}++menuStateHandleSetTitle :: Title -> MenuStateHandle ps -> MenuStateHandle ps+menuStateHandleSetTitle title (MenuStateHandle mlsH@(MenuLSHandle {mlsHandle=mH})) = MenuStateHandle mlsH{mlsHandle=mH{mTitle=title}}++menuStateHandleSetSelect :: Bool -> MenuStateHandle ps -> MenuStateHandle ps+menuStateHandleSetSelect select (MenuStateHandle mlsH@(MenuLSHandle {mlsHandle=mH})) = MenuStateHandle mlsH{mlsHandle=mH{mSelect=select}}
+ Graphics/UI/ObjectIO/Menu/Create.hs view
@@ -0,0 +1,356 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Menu.Create+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Menu.Create+		( openMenu', createPopUpMenu, extendMenu+		, disposeMenuItemHandle, disposeMenuIds+		, disposeSubMenuHandles+		, disposeMenuItemHandle, disposeMenuHandles+		, closePopUpMenu+		, systemAble, systemUnable+		) where+++import  Graphics.UI.ObjectIO.Id+import  Graphics.UI.ObjectIO.StdMenuDef+import	Graphics.UI.ObjectIO.StdMenuElementClass+import	Graphics.UI.ObjectIO.StdMenuAttribute(getMenuInitFun, isMenuInit)+import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.Process.IOState+import	Graphics.UI.ObjectIO.Window.SDISize+import	Graphics.UI.ObjectIO.Device.SystemState+import	Graphics.UI.ObjectIO.Menu.Access+import	Graphics.UI.ObjectIO.Menu.DefAccess+import	Graphics.UI.ObjectIO.Menu.Handle+import  Graphics.UI.ObjectIO.Receiver.Handle(ReceiverHandle(..))+import  Graphics.UI.ObjectIO.OS.MenuEvent(menuHandlesGetMenuStateHandles)+import	Graphics.UI.ObjectIO.OS.Menu+import	Graphics.UI.ObjectIO.OS.Types+import  Control.Monad(when, unless)+import  qualified Data.Map as Map+++menuCreateFatalError :: String -> String -> x+menuCreateFatalError rule error+	= dumpFatalError rule "MenuCreate" error+	++{-	Creating menus:+		Because in a SDI process menus might be added to the process window, the ViewFrame of the+		process window can change size.+		In that case, the layout of the controls should be recalculated, and the window updated.+	openMenu' assumes that the Id argument has been verified and that the MenuDevice exists.+-}+openMenu' :: MenuElements m => Id -> ls -> (Menu m ls ps) -> ps -> GUI ps ps+openMenu' menuId ls mDef ps = do+    osdInfo <- accIOEnv (ioStGetOSDInfo)+    let maybeOSMenuBar = getOSDInfoOSMenuBar osdInfo+    when (isNothing maybeOSMenuBar) (menuCreateFatalError "openMenu (Menu)" "could not retrieve OSMenuBar from IOSt") 	-- This condition should never hold+    let osMenuBar = fromJust maybeOSMenuBar+    idtable <- ioStGetIdTable+    (found,mDevice) <- accIOEnv (ioStGetDevice MenuDevice)+    let mHs = menuSystemStateGetMenuHandles mDevice+    when (any (isMenuWithThisId menuId) (mMenus mHs)) (menuCreateFatalError "openMenu (Menu)" "inconsistency detected between IdTable and ReceiverTable")        +    let (menus,mHs1) = menuHandlesGetMenuStateHandles mHs+    let nrmenus = length menus+    let index = maybe nrmenus (\index -> setBetween index 0 nrmenus) (menuDefGetIndex mDef)+    ioid <- accIOEnv ioStGetIOId+    (sdiSize1,sdiPtr) <- getSDIWindowSize+    (ok,mH,mHs2,idtable) <- createMenu index ioid menuId mDef mHs1 idtable osMenuBar+    ioStSetIdTable idtable+    (if not ok then do+	appIOEnv (ioStSetDevice (MenuSystemState mHs2))+	throwGUI ErrorIdsInUse+     else do+	let (before,after)	= splitAt index menus+	let msH = MenuStateHandle (MenuLSHandle {mlsState=ls,mlsHandle=mH})+	let mHs3 = mHs2{mMenus=before++msH:after}+	liftIO (drawMenuBar osMenuBar)+	appIOEnv (ioStSetDevice (MenuSystemState mHs3))+	checkSDISize sdiPtr sdiSize1+	getMenuDefInit mDef ps)+    where	+	checkSDISize :: OSWindowPtr -> Size -> GUI ps ()+	checkSDISize sdiPtr sdiSize1 = do+		(sdiSize2,_) <- getSDIWindowSize+		when (sdiSize1 /= sdiSize2) (resizeSDIWindow sdiPtr sdiSize1 sdiSize2)+	+	getMenuDefInit :: Menu m ls ps -> ps -> GUI ps ps+	getMenuDefInit (Menu _ _ atts) = getMenuInitFun (snd (cselect isMenuInit (MenuInit return) atts))++	createMenu :: MenuElements m => Int -> SystemId -> Id -> Menu m ls ps -> MenuHandles ps -> IdTable -> OSMenuBar -> GUI ps (Bool,MenuHandle ls ps, MenuHandles ps, IdTable)+	createMenu index ioId menuId mDef mHs@(MenuHandles {mKeys=keys}) it osMenuBar = do+		ms <- menuElementToHandles (menuDefGetElements mDef)+		let itemHs = map menuElementStateToMenuElementHandle ms+		(case menuIdsAreConsistent ioId menuId itemHs it of+			Just it -> do+				(menu,mH) <- liftIO (newMenuHandle mDef index menuId osMenuBar)+				(_,itemHs,keys)	<- liftIO (createMenuElements osMenuBar menu 1 itemHs keys)				+				let it1 = Map.insert menuId (IdParent{idpIOId=ioId,idpDevice=MenuDevice,idpId=menuId}) it+				return (True,mH{mItems=itemHs},mHs{mKeys=keys},it1)+			Nothing	     -> return (False,undefined,mHs,it))+		+			++isMenuWithThisId :: Id -> MenuStateHandle ps -> Bool+isMenuWithThisId id msH = id == menuStateHandleGetMenuId msH++{-	creating pop up menus.+	It is assumed that MenuHandles contains no pop up menu in mMenus and that mPopUpId contains an Id.+-}+createPopUpMenu :: PopUpMenuElements m => SystemId -> ls -> PopUpMenu m ls ps -> MenuHandles ps -> IdTable -> OSMenuBar -> GUI ps (Bool,MenuHandles ps,IdTable)+createPopUpMenu ioId ls (PopUpMenu items) mHs@(MenuHandles {mMenus=mMenus, mKeys=keys, mPopUpId=mPopUpId}) it osMenuBar = do+    ms <- popUpMenuElementToHandles items+    let itemHs = map menuElementStateToMenuElementHandle ms+    let menuId = fromJust mPopUpId+    (case menuIdsAreConsistent ioId menuId itemHs it of+       Just it -> do+  	    menu <- liftIO (osCreatePopUpMenu)+	    (_,itemHs,keys) <- liftIO (createMenuElements osMenuBar menu 1 itemHs keys)+	    let mH = MenuHandle+			{ mHandle	= menu+			, mMenuId	= menuId+			, mTitle	= ""+			, mSelect	= True+			, mItems	= map validatePopUpMenuFunction itemHs+			}+	    let msH = MenuStateHandle (MenuLSHandle {mlsState=ls,mlsHandle=mH})+	    let mHs1 = mHs{mMenus=msH:mMenus, mKeys=keys, mPopUpId=Nothing}+	    return (True,mHs1,it)+       Nothing 	-> return (False,mHs,it))+    where+{-	validatePopUpMenuFunction takes care that all Menu(Mods)Function arguments of the elements+	apply closePopUpMenu after their own action.+-}+	validatePopUpMenuFunction :: MenuElementHandle ls ps -> MenuElementHandle ls ps+	validatePopUpMenuFunction itemH@(MenuItemHandle {mItemAtts=mItemAtts}) =+	    itemH{mItemAtts=map validateMenuFunction mItemAtts}+	    where+		validateMenuFunction :: MenuAttribute ls ps -> MenuAttribute ls ps+		validateMenuFunction (MenuFunction f) = MenuFunction (f' f)+		    where+			f' :: GUIFun ls ps -> GUIFun ls ps+			f' f ls_ps = do+				ls_ps1 <- f ls_ps+				closePopUpMenu'+				return ls_ps1+		validateMenuFunction (MenuModsFunction f) = MenuModsFunction (f' f)+		    where+			f' :: ModifiersFunction ls ps -> ModifiersFunction ls ps+			f' f modifiers ls_ps = do+				ls_ps1 <- f modifiers ls_ps+				closePopUpMenu'+				return ls_ps1+		validateMenuFunction att = att+	validatePopUpMenuFunction (MenuReceiverHandle _ _) =+		menuCreateFatalError "validatePopUpMenuFunction" "Receiver(2) should not be an element of PopUpMenus"+	validatePopUpMenuFunction (SubMenuHandle {}) =+		menuCreateFatalError "validatePopUpMenuFunction" "SubMenu should not be an element of PopUpMenus"+	validatePopUpMenuFunction itemH@(RadioMenuHandle {mRadioItems=itemHs}) =+		itemH{mRadioItems=map validatePopUpMenuFunction itemHs}+	validatePopUpMenuFunction itemH@(MenuSeparatorHandle {}) = itemH+	validatePopUpMenuFunction (MenuListLSHandle itemHs) =+		MenuListLSHandle (map validatePopUpMenuFunction itemHs)+	validatePopUpMenuFunction (MenuExtendLSHandle exLS itemHs) =+		MenuExtendLSHandle exLS (map validatePopUpMenuFunction itemHs)+	validatePopUpMenuFunction (MenuChangeLSHandle chLS itemHs) =+		MenuChangeLSHandle chLS (map validatePopUpMenuFunction itemHs)+	+{-	closePopUpMenu' takes care that the internal administration of the menus is restored again to+	no open pop up menu. It is assumed that all resources have been freed.+-}+	closePopUpMenu' :: GUI ps ()+	closePopUpMenu' = do+		(found,mDevice)	<- accIOEnv (ioStGetDevice MenuDevice)+		unless found (menuCreateFatalError "closePopUpMenu" "could not retrieve MenuSystemState")+		let mHs = menuSystemStateGetMenuHandles mDevice+		let mHs1 = closePopUpMenu mHs+		appIOEnv (ioStSetDevice (MenuSystemState mHs1))+++{-	Creating menu elements: retrieving toolbox handles and ids for elements, and building the menu gui. -}++createMenuElements :: OSMenuBar -> OSMenu -> Int -> [MenuElementHandle ls ps] -> [Char] -> IO (Int,[MenuElementHandle ls ps],[Char])+createMenuElements osMenubar menu iNr []             keys = return (iNr,[],keys)+createMenuElements osMenubar menu iNr (itemH:itemHs) keys = do+    (iNr,itemH, keys)	<- createMenuElement  osMenubar menu iNr itemH  keys+    (iNr,itemHs,keys)	<- createMenuElements osMenubar menu iNr itemHs keys+    return (iNr,itemH:itemHs,keys)+    where+	createMenuElement :: OSMenuBar -> OSMenu -> Int -> MenuElementHandle ls ps -> [Char] -> IO (Int, MenuElementHandle ls ps, [Char])+	createMenuElement osMenubar menu iNr itemH@(SubMenuHandle {mSubItems=itemHs}) keys = do+		itemH <- newSubMenuHandle itemH iNr menu		+		(_,itemHs,keys)	<- createMenuElements osMenubar (mSubHandle itemH) 1 itemHs keys+		return (iNr+1,itemH{mSubItems=itemHs},keys)+	createMenuElement osMenubar menu iNr itemH@(RadioMenuHandle {mRadioItems=itemHs}) keys = do+		(iNr,itemHs,keys) <- createMenuElements osMenubar menu iNr itemHs keys+		return (iNr,itemH{mRadioItems=itemHs},keys)+	createMenuElement osMenubar menu iNr itemH@(MenuItemHandle {}) keys = do+		let (itemH1,keys1) = checkShortcutKey itemH keys+		osMenuItem <- insertMenu osMenubar menu iNr itemH1+		return (iNr+1,itemH1{mOSMenuItem=osMenuItem},keys1)+	createMenuElement osMenubar menu iNr itemH@(MenuSeparatorHandle {}) keys = do+		osMenuItem <- osMenuSeparatorInsert menu iNr+		return (iNr+1,itemH{mOSMenuSeparator=osMenuItem},keys)+	createMenuElement _ _ iNr itemH@(MenuReceiverHandle _ _) keys = do+		return (iNr,itemH,keys)+	createMenuElement osMenubar menu iNr (MenuListLSHandle itemHs) keys = do+		(iNr,itemHs,keys) <- createMenuElements osMenubar menu iNr itemHs keys+		return (iNr,MenuListLSHandle itemHs,keys)+	createMenuElement osMenubar menu iNr (MenuExtendLSHandle exLS itemHs) keys = do+		(iNr,itemHs,keys) <- createMenuElements osMenubar menu iNr itemHs keys+		return (iNr,MenuExtendLSHandle exLS itemHs,keys)+	createMenuElement osmenubar menu iNr (MenuChangeLSHandle chLS itemHs) keys = do+		(iNr,itemHs,keys) <- createMenuElements osMenubar menu iNr itemHs keys+		return (iNr,MenuChangeLSHandle chLS itemHs,keys)	+++{-	Extend an existing menu with new menu elements. -}++extendMenu :: OSMenuBar -> OSMenu -> Int -> [MenuElementHandle ls ps] -> [MenuElementHandle ls ps] -> [Char] -> IO ([MenuElementHandle ls ps],[Char])+extendMenu osMenubar menu iNr [] items keys = return (items,keys)+extendMenu osMenubar menu iNr (itemH:itemHs) items keys = do    +    (itemH, keys) <- extendMenu' osMenubar menu iNr itemH        keys+    (itemHs,keys) <- extendMenu  osMenubar menu iNr itemHs items keys+    return (itemH:itemHs,keys)+    where+	extendMenu' :: OSMenuBar -> OSMenu -> Int -> MenuElementHandle ls ps -> [Char] -> IO (MenuElementHandle ls ps, [Char])+	extendMenu' osMenubar menu iNr itemH@(SubMenuHandle {mSubHandle=handle, mSubItems=itemHs}) keys = do+		itemH <- newSubMenuHandle itemH iNr menu+		(_,itemHs,keys)	<- createMenuElements osMenubar handle 1 itemHs keys+		return (itemH{mSubItems=itemHs},keys)+	extendMenu' osMenubar menu iNr itemH@(RadioMenuHandle {mRadioItems=itemHs}) keys = do+		(_,itemHs,keys) <- createMenuElements osMenubar menu iNr itemHs keys+		return (itemH{mRadioItems=itemHs},keys)+	extendMenu' osmenubar menu iNr itemH@(MenuItemHandle {}) keys = do+		let (itemH1,keys1) = checkShortcutKey itemH keys+		osMenuItem <- insertMenu osMenubar menu iNr itemH1+		return (itemH1{mOSMenuItem=osMenuItem},keys1)+	extendMenu' osMenubar menu iNr itemH@(MenuSeparatorHandle {}) keys = do+		osMenuItem <- osMenuSeparatorInsert menu iNr+		return (itemH{mOSMenuSeparator=osMenuItem},keys)+	extendMenu' _ _ _ itemH@(MenuReceiverHandle _ _) keys =+		return (itemH,keys)+	extendMenu' osMenubar menu iNr (MenuListLSHandle itemHs) keys = do+		(itemHs,keys) <- extendMenu osMenubar menu iNr itemHs [] keys+		return (MenuListLSHandle itemHs,keys)+	extendMenu' osMenubar menu iNr (MenuExtendLSHandle exLS itemHs) keys = do+		(itemHs,keys) <- extendMenu osMenubar menu iNr itemHs [] keys+		return (MenuExtendLSHandle exLS itemHs,keys)+	extendMenu' osMenubar menu iNr (MenuChangeLSHandle chLS itemHs) keys = do+		(itemHs,keys) <- extendMenu osMenubar menu iNr itemHs [] keys+		return (MenuChangeLSHandle chLS itemHs,keys)++insertMenu :: OSMenuBar -> OSMenu -> Int -> MenuElementHandle ls ps -> IO OSMenuItem+insertMenu osMenubar menu iNr (MenuItemHandle {mItemKey=mItemKey,mItemTitle=mItemTitle,mItemSelect=mItemSelect,mItemMark=mItemMark,mItemAtts=mItemAtts}) = do+	osMenuItemInsert osMenubar menu iNr mItemTitle mItemSelect mItemMark shortcut+	where+		shortcut = case mItemKey of+			(Just key)	-> key+			_		-> '\0'++checkShortcutKey :: MenuElementHandle ls ps -> [Char] -> (MenuElementHandle ls ps,[Char])+checkShortcutKey mItemH cs = case mItemKey mItemH of+	Just c 	-> if c `elem` cs then (mItemH{mItemKey=Nothing},cs)+		   else (mItemH,c:cs)+	Nothing	-> (mItemH,cs)++--	Creation and manipulation of Menu(Element)Handles:++systemAble	= True+systemUnable	= False++--	Initialisation and Allocation:++newMenuHandle :: Menu m ls ps -> Int -> Id -> OSMenuBar -> IO (OSMenu,MenuHandle ls ps)+newMenuHandle mDef index menuId menuBar =+	let+		select = menuDefGetSelectState mDef+		title  = menuDefGetTitle mDef+	in do+		let able = enabled select+		menu <- osMenuInsert menuBar index title able+		let mH = MenuHandle+			{ mHandle   = menu+			, mMenuId   = menuId+			, mTitle    = title+			, mSelect   = able+			, mItems    = []+			}+		return (menu,mH)+	+newSubMenuHandle :: MenuElementHandle ls ps -> Int -> OSMenu -> IO (MenuElementHandle ls ps)+newSubMenuHandle mH@(SubMenuHandle {mSubTitle=mSubTitle,mSubSelect=able}) index menu = do	+	osH <- osSubMenuInsert menu index mSubTitle able+	return mH{mSubHandle=osH}++closePopUpMenu :: MenuHandles ps -> MenuHandles ps+closePopUpMenu mHs@(MenuHandles {mMenus=mMenus,mPopUpId=mPopUpId})+	| isJust mPopUpId = mHs+	| otherwise =+		let (msH:msHs) = mMenus		    +		in mHs{mMenus=msHs,mPopUpId=Just (menuStateHandleGetMenuId msH)}++disposeMenuItemHandle :: OSMenu -> Int -> MenuElementHandle ls ps ->  ([Char],IdTable) -> IO ([Char],IdTable)+disposeMenuItemHandle menu iNr (MenuItemHandle {mItemKey=mItemKey,mItemId=mItemId,mOSMenuItem=mOSMenuItem}) (keys,it) = do+	osMenuRemoveItem mOSMenuItem menu+	return (keys',it')+	where+		keys'	= case mItemKey of+			Just key -> key:keys+			Nothing  -> keys		+		it'	= case mItemId of+			Just id -> Map.delete (fromJust mItemId) it+			Nothing	-> it+++disposeSubMenuHandles :: OSWindowPtr -> MenuElementHandle ls ps -> [Char] -> IO [Char]+disposeSubMenuHandles framePtr (MenuItemHandle {mItemKey=mItemKey,mOSMenuItem=mOSMenuItem}) keys =+	case mItemKey of+		Just key -> do+			osRemoveMenuShortKey framePtr mOSMenuItem+			return (filter ((==) key) keys)+		Nothing -> return keys+disposeSubMenuHandles framePtr (SubMenuHandle     {mSubItems=items}) keys = foldrM (disposeSubMenuHandles framePtr) keys items+disposeSubMenuHandles framePtr (RadioMenuHandle {mRadioItems=items}) keys = foldrM (disposeSubMenuHandles framePtr) keys items+disposeSubMenuHandles framePtr (MenuListLSHandle	      items) keys = foldrM (disposeSubMenuHandles framePtr) keys items+disposeSubMenuHandles framePtr (MenuExtendLSHandle _          items) keys = foldrM (disposeSubMenuHandles framePtr) keys items+disposeSubMenuHandles framePtr (MenuChangeLSHandle _          items) keys = foldrM (disposeSubMenuHandles framePtr) keys items+disposeSubMenuHandles _        _                                     keys = return keys++disposeMenuIds :: SystemId -> MenuElementHandle ls ps -> IdTable -> IdTable+disposeMenuIds pid (MenuItemHandle {mItemId=mItemId}) it+	| isNothing mItemId	= it+	| otherwise		= Map.delete (fromJust mItemId) it+disposeMenuIds pid (MenuReceiverHandle (ReceiverHandle {rId=rId}) _) it =+	Map.delete rId it+disposeMenuIds pid (SubMenuHandle {mSubItems=mSubItems}) it =+	foldr (disposeMenuIds pid) it mSubItems+disposeMenuIds pid (RadioMenuHandle {mRadioId=mRadioId,mRadioItems=mRadioItems}) it =+	let it1 = foldr (disposeMenuIds pid) it mRadioItems+	in maybe it1 (flip Map.delete it1) mRadioId+disposeMenuIds pid (MenuSeparatorHandle {mSepId=mSepId}) it =+	maybe it (flip Map.delete it) mSepId+disposeMenuIds pid (MenuListLSHandle mListItems) ts =+	foldr (disposeMenuIds pid) ts mListItems+disposeMenuIds pid (MenuExtendLSHandle _ mExtendItems) ts =+	foldr (disposeMenuIds pid) ts mExtendItems+disposeMenuIds pid (MenuChangeLSHandle _ mChangeItems) ts =+	foldr (disposeMenuIds pid) ts mChangeItems++disposeMenuHandles :: MenuHandles ps -> OSMenuBar -> IO ()+disposeMenuHandles menus@(MenuHandles {mMenus=mMenus}) osMenuBar =+	mapM_ dispose mMenus+	where+		dispose :: MenuStateHandle ps -> IO ()+		dispose mH = osMenuRemove (menuStateHandleGetHandle mH) osMenuBar
+ Graphics/UI/ObjectIO/Menu/DefAccess.hs view
@@ -0,0 +1,53 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Menu.DefAccess+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Menu.DefAccess where+++import Graphics.UI.ObjectIO.StdMenuAttribute+import Graphics.UI.ObjectIO.CommonDef+import Data.List(find)+++menuDefGetMenuId :: Menu m ls ps -> Maybe Id+menuDefGetMenuId menu@(Menu _ _ atts) =+	fmap getMenuIdAtt (find isMenuId atts)	++menuDefGetSelectState :: Menu m ls ps -> SelectState+menuDefGetSelectState menu@(Menu _ _ atts)+	= getMenuSelectStateAtt (snd (cselect isMenuSelectState (MenuSelectState Able) atts))++menuDefSetAbility :: Menu m ls ps -> SelectState -> Menu m ls ps+menuDefSetAbility (Menu name items atts) able =+	Menu name items (setSelectState able atts)+	where+	    setSelectState :: SelectState -> [MenuAttribute ls ps] -> [MenuAttribute ls ps]+	    setSelectState select atts+		    | found		= atts1+		    | otherwise		= att : atts1+	    	    where+			  att		= MenuSelectState select+			  (found,atts1)	= creplace isMenuSelectState att atts++menuDefGetTitle :: Menu m ls ps -> Title+menuDefGetTitle (Menu name _ _) = name++menuDefGetElements :: Menu m ls ps -> m ls ps+menuDefGetElements (Menu _ items _) = items++menuDefSetElements :: Menu m ls ps -> m ls ps -> Menu m ls ps+menuDefSetElements (Menu name _ atts) items = Menu name items atts++menuDefGetIndex :: Menu m ls ps -> Maybe Index+menuDefGetIndex menu@(Menu _ _ atts) =+	fmap getMenuIndexAtt (find isMenuIndex atts)
+ Graphics/UI/ObjectIO/Menu/Device.hs view
@@ -0,0 +1,372 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Menu.Device+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Menu.Device(menuFunctions) where+++import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.StdId+import	Graphics.UI.ObjectIO.StdGUI+import	Graphics.UI.ObjectIO.Process.IOState+import	Graphics.UI.ObjectIO.Menu.Create+import	Graphics.UI.ObjectIO.Menu.Handle+import	Graphics.UI.ObjectIO.Menu.DefAccess+import	Graphics.UI.ObjectIO.Menu.Access(menuStateHandleGetMenuId)+import	Graphics.UI.ObjectIO.StdMenuAttribute(isMenuFunction, getMenuFun, isMenuModsFunction, getMenuModsFun)+import  Graphics.UI.ObjectIO.Receiver.Handle+import	Graphics.UI.ObjectIO.StdProcessAttribute(getProcessToolbarAtt, isProcessToolbar)+import	Graphics.UI.ObjectIO.OS.Menu+import	Graphics.UI.ObjectIO.OS.Types(osNoWindowPtr, OSMenu)+import	Graphics.UI.ObjectIO.OS.MenuEvent+import	Graphics.UI.ObjectIO.Id(IdParent(..))+import	Control.Monad(when, unless)+import  System.IO(fixIO)+import  Data.IORef(readIORef)+import  qualified Data.Map as Map (lookup)+++menuDeviceFatalError :: String -> String -> x+menuDeviceFatalError rule error = dumpFatalError rule "MenuDevice" error++menuFunctions :: DeviceFunctions ps+menuFunctions = DeviceFunctions+	  {	dDevice	= MenuDevice+	  ,	dShow	= menuShow+	  ,	dHide	= menuHide+	  ,	dEvent	= menuEvent+	  ,	dDoIO	= menuIO+	  ,	dOpen	= menuOpen+	  ,	dClose	= menuClose+	  }++menuShow :: ps -> GUI ps ps+menuShow ps = do	+	osdinfo <- accIOEnv ioStGetOSDInfo+	(let +		maybeMenuBar = getOSDInfoOSMenuBar osdinfo+		osMenuBar				= fromJust maybeMenuBar+	 in +		if isNothing maybeMenuBar+	 	then menuDeviceFatalError "menuFunctions.dShow" "OSMenuBar could not be retrieved from OSDInfo"+	 	else do	+			liftIO (osMenuBarSet osMenuBar)		  	+		  	appIOEnv (ioStSetOSDInfo (setOSDInfoOSMenuBar osMenuBar osdinfo)))+	return ps++menuClose :: ps -> GUI ps ps+menuClose ps = do+	osdinfo <- accIOEnv ioStGetOSDInfo+	(case getOSDInfoOSMenuBar osdinfo of+		Nothing -> menuDeviceFatalError "MenuFunctions.dClose" "OSMenuBar could not be retrieved from OSDInfo"+		Just osMenuBar -> do+			(found,menus) <- accIOEnv (ioStGetDevice MenuDevice)+			unless found (menuDeviceFatalError "MenuFunctions.dClose" "could not retrieve MenuSystemState from IOSt")				+			let mHs	= menuSystemStateGetMenuHandles menus+			liftIO (disposeMenuHandles mHs osMenuBar)+			ioid <- accIOEnv ioStGetIOId			+			it <- ioStGetIdTable+			let it1 = foldr (disposeIds ioid) it (mMenus mHs)+			ioStSetIdTable it1+			appIOEnv (ioStRemoveDevice MenuDevice)+			appIOEnv (ioStRemoveDeviceFunctions MenuDevice)+			return ps)+	where+		disposeIds :: SystemId -> MenuStateHandle ps -> IdTable -> IdTable+		disposeIds ioid (MenuStateHandle (MenuLSHandle {mlsHandle=mH})) is =+			foldr (disposeMenuIds ioid) is (mItems mH)+			+menuHide :: ps -> GUI ps ps+menuHide ps = do	+	(found,menus) <- accIOEnv (ioStGetDevice MenuDevice)	+	when found (liftIO (osMenuBarClear) >> appIOEnv (ioStSetDevice menus))+	return ps+++{-	Opening menus:+	Note:	all interactive processes have atleast the AppleMenu to identify the +			process, and is used for checking whether the process is active+			(see IOStIsActive further down this module).+			If the process is a subprocess, then the ioguishare of its IOSt+			contains the list to the Mac toolbox menu system.+-}+menuOpen :: ps -> GUI ps ps+menuOpen ps = do+	hasMenu <- accIOEnv (ioStHasDevice MenuDevice)+	(if hasMenu then return ps+	 else do+		di <- accIOEnv ioStGetDocumentInterface+		popUpId <- getPopUpId di+		let bound = case di of+			NDI -> Finite 0+			SDI -> Infinite+			MDI -> Infinite+		let mHs	= MenuHandles+			{ mMenus	= []+			, mKeys		= []			+			, mEnabled	= systemAble+			, mNrMenuBound	= bound+			, mPopUpId	= popUpId					+			}+		appIOEnv (ioStSetDevice (MenuSystemState mHs))+		appIOEnv (ioStSetDeviceFunctions menuFunctions)+		return ps)+	where+		getPopUpId :: DocumentInterface -> GUI ps (Maybe Id)+		getPopUpId NDI = return Nothing+		getPopUpId _ = fmap Just openId+++menuIO :: DeviceEvent -> ps -> GUI ps ps+menuIO deviceEvent ps = do+	ok <- accIOEnv (ioStHasDevice MenuDevice)+	unless ok (menuDeviceFatalError "menuFunctions.dDoIO" "could not retrieve MenuSystemState from IOSt")+	toGUI (menuIO deviceEvent ps)+	where+		menuIO :: DeviceEvent -> ps -> IOSt ps -> IO (ps,IOSt ps)+		menuIO (ReceiverEvent rId) ps ioState =+			let+				(_,mDevice) = ioStGetDevice MenuDevice ioState+				menus   = menuSystemStateGetMenuHandles mDevice+			in+				menuMsgIO rId menus ps ioState+			where		+				menuMsgIO :: Id -> MenuHandles ps -> ps -> IOSt ps -> IO (ps, IOSt ps)+				menuMsgIO rId menus@(MenuHandles {mMenus=mHs}) ps ioState = do+					iocontext <- readIORef (ioStGetContext ioState)+					let Just idParent = Map.lookup rId (ioContextGetIdTable iocontext)+					menusMsgIO (\mHs ioState -> (ioStSetDevice (MenuSystemState menus{mMenus=mHs})) ioState) (idpId idParent) rId mHs ps ioState+					where+						menusMsgIO :: ([MenuStateHandle ps] -> IOSt ps -> IOSt ps) ->+							      Id -> Id -> [MenuStateHandle ps] -> ps -> IOSt ps -> IO (ps, IOSt ps)+						menusMsgIO build menuId rId [] ps ioState =+							menuDeviceFatalError "menuIO (ReceiverEvent _) _" "menu could not be found"+						menusMsgIO build menuId rId (msH:msHs) ps ioState =+							if menuStateHandleGetMenuId msH == menuId+							then menuStateMsgIO (\msH ioState -> build (msH:msHs) ioState) rId msH ps ioState+							else menusMsgIO (\msHs ioState -> build (msH:msHs) ioState) menuId rId msHs ps ioState+								++		menuIO (MenuTraceEvent info) ps ioState =+			let+				(_,mDevice) = ioStGetDevice MenuDevice ioState+				menus = menuSystemStateGetMenuHandles mDevice+			in+				menuTraceIO info menus ps ioState+			where+				menuTraceIO :: MenuTraceInfo -> MenuHandles ps -> ps -> IOSt ps -> IO (ps, IOSt ps)+				menuTraceIO info@(MenuTraceInfo {mtId=mtId}) menus@(MenuHandles {mMenus=mHs}) ps ioState = do+					menusTraceIO (\mHs ioState -> (ioStSetDevice (MenuSystemState menus{mMenus=mHs})) ioState) mtId info mHs ps ioState+					where+						menusTraceIO :: ([MenuStateHandle ps] -> IOSt ps -> IOSt ps) ->+								Id -> MenuTraceInfo -> [MenuStateHandle ps] -> ps -> IOSt ps -> IO (ps, IOSt ps)+						menusTraceIO build menuId info [] ps ioState =+							menuDeviceFatalError "menuIO (MenuTraceEvent _) _" "menu could not be found"+						menusTraceIO build menuId info (msH:msHs) ps ioState =+							if menuStateHandleGetMenuId msH == menuId+							then menuStateTraceIO (\msH ioState -> build (msH:msHs) ioState) info msH ps ioState+							else menusTraceIO (\msHs ioState -> build (msH:msHs) ioState) menuId info msHs ps ioState+								++		menuIO (ToolbarSelection tbsItemNr) ps ioState =+			let +				atts     	    = ioStGetProcessAttributes ioState+				(hasToolbarAtt,att) = cselect isProcessToolbar undefined atts+				toolbarItems	    = getProcessToolbarAtt att+			in+				if not hasToolbarAtt+				then return (ps,ioState)+				else fromGUI (getToolbarFunction tbsItemNr toolbarItems ps) ioState					+			where+				getToolbarFunction :: Int -> [ToolbarItem ps] -> ps -> GUI ps ps+				getToolbarFunction _ [] =+					menuDeviceFatalError "menuIO (ToolbarSelection _)" "toolbar index out of range"+				getToolbarFunction i (ToolbarSeparator:items) = getToolbarFunction i items+				getToolbarFunction i ((ToolbarItem _ _ f):items)+					| i==1 	= f+					| otherwise		= getToolbarFunction (i-1) items+		menuIO _ _ _+			= menuDeviceFatalError "menuIO" "unexpected DeviceEvent"++++{-	Apply the Menu(Mods)Function of a selected menu item. -}++menuStateTraceIO :: (MenuStateHandle ps -> IOSt ps -> IOSt ps) -> +		    MenuTraceInfo -> MenuStateHandle ps -> ps -> IOSt ps -> IO (ps, IOSt ps)+menuStateTraceIO build info@(MenuTraceInfo {mtParents=mtParents}) (MenuStateHandle (MenuLSHandle {mlsState=ls,mlsHandle=mH})) ps ioState = do+	r <- subMenusTraceIO (\itemHs st ioState -> build (MenuStateHandle (MenuLSHandle {mlsState=fst st,mlsHandle=mH{mItems=itemHs}})) ioState) (mHandle mH) mtParents (mItems mH) (ls,ps) ioState+	let ((_,ps1),ioState) = r+	return (ps1,ioState)+	where+		--	subMenusTraceIO finds the final submenu that contains the selected menu item and then applies its Menu(Mods)Function.+		subMenusTraceIO :: ([MenuElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IOSt ps) -> +				   OSMenu -> [Int] -> [MenuElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IO ((ls,ps), IOSt ps)+		subMenusTraceIO build mHandle [] itemHs ls_ps ioState = do+			r <- menuElementsTraceIO build (mtItemNr info) mHandle 0 itemHs ls_ps ioState+			let (_,ls_ps1,ioState) = r+			return (ls_ps1,ioState)+		subMenusTraceIO build mHandle (subIndex:subIndices) itemHs ls_ps ioState = do+			r <- subMenuTraceIO build subIndex mHandle subIndices 0 itemHs ls_ps ioState+			let (_,ls_ps1,ioState) = r+			return (ls_ps1,ioState)+			where+				subMenuTraceIO :: ([MenuElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IOSt ps) ->+						  Int -> OSMenu -> [Int] -> Int -> [MenuElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IO (Int,(ls,ps),IOSt ps)+				subMenuTraceIO build parentIndex mHandle parentsIndex zIndex (itemH:itemHs) ls_ps ioState = do+					r <- subMenuTraceIO' (\itemH st ioState -> build (itemH:itemHs) st ioState) parentIndex mHandle parentsIndex zIndex itemH ls_ps ioState+					let (zIndex1,ls_ps1,ioState) = r+					(if parentIndex<zIndex1 then return r+					 else subMenuTraceIO (\itemHs st ioState -> build (itemH:itemHs) st ioState) parentIndex mHandle parentsIndex zIndex1 itemHs ls_ps1 ioState)+					where+						subMenuTraceIO' :: (MenuElementHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+								   Int -> OSMenu -> [Int] -> Int -> MenuElementHandle ls ps -> (ls,ps) -> IOSt ps -> IO (Int,(ls,ps),IOSt ps)+						subMenuTraceIO' build parentIndex mHandle parentsIndex zIndex subH@(SubMenuHandle {mSubHandle=mSubHandle, mSubItems=itemHs}) ls_ps ioState+							| parentIndex /= zIndex = return (zIndex+1,ls_ps,ioState)+							| otherwise = do+								r <- subMenusTraceIO (\itemHs st ioState -> build subH{mSubItems=itemHs} st ioState) mSubHandle parentsIndex itemHs ls_ps ioState+								let (ls_ps1,ioState) = r+								return (zIndex+1,ls_ps1,ioState)+						subMenuTraceIO' build parentIndex mHandle parentsIndex zIndex radioH@(RadioMenuHandle {mRadioItems=itemHs}) ls_ps ioState =+							return (zIndex+length itemHs,ls_ps,ioState)+						subMenuTraceIO' build parentIndex mHandle parentsIndex zIndex itemH@(MenuItemHandle {}) ls_ps ioState =+							return (zIndex+1,ls_ps,ioState)+						subMenuTraceIO' build parentIndex mHandle parentsIndex zIndex (MenuListLSHandle itemHs) ls_ps ioState =+							subMenuTraceIO (\itemHs st ioState -> build (MenuListLSHandle itemHs) st ioState) parentIndex mHandle parentsIndex zIndex itemHs ls_ps ioState+						subMenuTraceIO' build parentIndex mHandle parentsIndex zIndex (MenuExtendLSHandle exLS itemHs) (ls,ps) ioState = do+							r <- subMenuTraceIO (\itemHs st ioState -> build (MenuExtendLSHandle (fst (fst st)) itemHs) (snd (fst st),snd st) ioState) parentIndex mHandle parentsIndex zIndex itemHs ((exLS,ls),ps) ioState+							let (zIndex1,((_,ls1),ps1),ioState) = r+							return (zIndex,(ls1,ps1),ioState)+						subMenuTraceIO' build parentIndex mHandle parentsIndex zIndex (MenuChangeLSHandle chLS itemHs) (ls,ps) ioState = do+							r <- subMenuTraceIO (\itemHs st ioState -> build (MenuChangeLSHandle (fst st) itemHs) (ls,snd st) ioState) parentIndex mHandle parentsIndex zIndex itemHs (chLS,ps) ioState+							let (zIndex1,(_,ps1),ioState) = r+							return (zIndex,(ls,ps1),ioState)+						subMenuTraceIO' _ _ _ _ zIndex itemH ls_ps ioState =+							return (zIndex,ls_ps,ioState)+				subMenuTraceIO _ _ _ _ zIndex itemHs ls_ps ioState =+					return (zIndex,ls_ps,ioState)+		+		--	menuElementsTraceIO applies the Menu(Mods)Function of the menu item at index itemIndex to the context state.+		menuElementsTraceIO :: ([MenuElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IOSt ps) ->+				       Int -> OSMenu -> Int -> [MenuElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IO (Int,(ls,ps),IOSt ps)+		menuElementsTraceIO build itemIndex mHandle zIndex (itemH:itemHs) ls_ps ioState = do+			r <- menuElementTraceIO (\itemH st ioState -> build (itemH:itemHs) st ioState) itemIndex mHandle zIndex itemH ls_ps ioState+			let (zIndex1,ls_ps1,ioState) = r+			(if itemIndex<zIndex1 then return r+			 else menuElementsTraceIO (\itemHs st ioState -> build (itemH:itemHs) st ioState) itemIndex mHandle zIndex1 itemHs ls_ps1 ioState)+			where+				menuElementTraceIO :: (MenuElementHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+						      Int -> OSMenu -> Int -> MenuElementHandle ls ps -> (ls,ps) -> IOSt ps -> IO (Int, (ls,ps), IOSt ps)+				menuElementTraceIO build itemIndex mHandle zIndex itemH@(MenuItemHandle {mItemAtts=mItemAtts}) (ls,ps) ioState+					| itemIndex /= zIndex || not hasFun	= +						return (zIndex+1,(ls,ps),ioState)+					| otherwise = do+						r <- fixIO (\st -> fromGUI (f (ls,ps)) (build itemH (fst st) ioState))+						let ((ls1,ps1), ioState) = r+						return (zIndex+1,(ls1,ps1),ioState)+					where+						(hasFun,fAtt) = cselect isEitherFun undefined mItemAtts+						f	= if isMenuFunction fAtt+							  then getMenuFun fAtt+							  else getMenuModsFun fAtt (mtModifiers info)+						isEitherFun f = isMenuFunction f || isMenuModsFunction f+				menuElementTraceIO build itemIndex mHandle zIndex radioH@(RadioMenuHandle {mRadioItems=itemHs}) ls_ps ioState =+					let nrRadios = length itemHs+					in+						if itemIndex>=zIndex+nrRadios then+							-- Selected item is not one of these radio items+							return (zIndex+nrRadios,ls_ps,ioState)+						else+						    let +							curIndex	= mRadioIndex radioH+							newIndex	= mtItemNr info - zIndex + 1+							curH 		= mOSMenuItem (itemHs!!(curIndex-1))+							newH 		= mOSMenuItem (itemHs!!(newIndex-1))+						    in do+							  osMenuItemCheck False mHandle curH+							  osMenuItemCheck True  mHandle newH+							  r <- menuElementsTraceIO (\itemHs st ioState -> build radioH{mRadioItems=itemHs, mRadioIndex=newIndex} st ioState) itemIndex mHandle zIndex itemHs ls_ps ioState+							  let (_,ls_ps,ioState) = r+							  return (zIndex+length itemHs,ls_ps,ioState)+								+				menuElementTraceIO build itemIndex mHandle zIndex itemH@(SubMenuHandle {}) ls_ps ioState =+					return (zIndex+1,ls_ps,ioState)+					+				menuElementTraceIO build itemIndex mHandle zIndex (MenuListLSHandle itemHs) ls_ps ioState =+					menuElementsTraceIO (\itemHs st ioState -> build (MenuListLSHandle itemHs) st ioState) itemIndex mHandle zIndex itemHs ls_ps ioState+					+				menuElementTraceIO build itemIndex mHandle zIndex (MenuExtendLSHandle exLS itemHs) (ls,ps) ioState = do+					r <- menuElementsTraceIO (\itemHs st ioState -> build (MenuExtendLSHandle (fst (fst st)) itemHs) (snd (fst st),snd st) ioState) itemIndex mHandle zIndex itemHs ((exLS,ls),ps) ioState+					let (zIndex,((_,ls),ps),ioState) = r+					return (zIndex,(ls,ps),ioState)+				menuElementTraceIO build itemIndex mHandle zIndex (MenuChangeLSHandle chLS itemHs) (ls,ps) ioState = do+					r <- menuElementsTraceIO (\itemHs st ioState -> build (MenuChangeLSHandle (fst st) itemHs) (ls,snd st) ioState) itemIndex mHandle zIndex itemHs (chLS,ps) ioState+					let (zIndex,(_,ps),ioState) = r+					return (zIndex,(ls,ps),ioState)+				menuElementTraceIO _ _ _ zIndex itemH ls_ps ioState =+					return (zIndex,ls_ps,ioState)+		menuElementsTraceIO _ _ _ zIndex [] ls_ps ioState = +			return (zIndex,ls_ps,ioState)+++{-	menuStateMsgIO handles all message events. -}++menuStateMsgIO :: (MenuStateHandle ps -> IOSt ps -> IOSt ps) ->+		  Id -> MenuStateHandle ps -> ps -> IOSt ps -> IO (ps,IOSt ps)+menuStateMsgIO build rId msH@(MenuStateHandle mlsH@(MenuLSHandle {mlsState=ls,mlsHandle=mH})) ps ioState = do+    r <- menuMsgIO (\mH st ioState -> build (MenuStateHandle mlsH{mlsState=fst st,mlsHandle=mH}) ioState) rId mH (ls,ps) ioState+    let ((_,ps1),ioState) = r+    return (ps1,ioState)+    where+	-- menuMsgIO handles the first asynchronous message in the message queue of the indicated receiver menu element.+	menuMsgIO :: (MenuHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+		       Id -> MenuHandle ls ps -> (ls,ps) -> IOSt ps -> IO ((ls,ps), IOSt ps)+	menuMsgIO build rId mH@(MenuHandle {mItems=itemHs}) ls_ps ioState = do+	    r <- elementsMsgIO (\itemHs st ioState -> build mH{mItems=itemHs} st ioState) rId itemHs ls_ps ioState+	    let (_,ls_ps,ioState) = r+	    return (ls_ps,ioState)+	    where+		elementsMsgIO :: ([MenuElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IOSt ps) ->+				   Id -> [MenuElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IO (Bool,(ls,ps),IOSt ps)+		elementsMsgIO build rId (itemH:itemHs) ls_ps ioState = do+			r <- elementMsgIO (\itemH st ioState -> build (itemH:itemHs) st ioState) rId itemH ls_ps ioState+			let (done,ls_ps,ioState) = r+			(if done then return r+			 else elementsMsgIO (\itemHs st ioState -> build (itemH:itemHs) st ioState) rId itemHs ls_ps ioState)+			where+				elementMsgIO :: (MenuElementHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+						  Id -> MenuElementHandle ls ps -> (ls,ps) -> IOSt ps -> IO (Bool,(ls,ps),IOSt ps)+				elementMsgIO build id mrH@(MenuReceiverHandle rH@(ReceiverHandle {rFun=rFun,rId=rId}) atts) ls_ps ioState+					| id /= rId = return (False,ls_ps,ioState)+					| otherwise = do+						r <- fixIO (\st -> fromGUI (rFun ls_ps) (build mrH (fst st) ioState))+						let (ls_ps, ioState) = r+						return (True,ls_ps,ioState)++				elementMsgIO build rId subH@(SubMenuHandle {mSubItems=itemHs}) ls_ps ioState = do+					elementsMsgIO (\itemHs st ioState -> build subH{mSubItems=itemHs} st ioState) rId itemHs ls_ps ioState+					+				elementMsgIO build rId (MenuListLSHandle itemHs) ls_ps ioState = do+					elementsMsgIO (\itemHs st ioState -> build (MenuListLSHandle itemHs) st ioState) rId itemHs ls_ps ioState++				elementMsgIO build rId (MenuExtendLSHandle exLS itemHs) (ls,ps) ioState = do+					r <- elementsMsgIO (\itemHs st ioState -> build (MenuExtendLSHandle (fst (fst st)) itemHs) (snd (fst st),snd st) ioState) rId itemHs ((exLS,ls),ps) ioState+					let (done,((_,ls),ps),ioState) = r+					return (done,(ls,ps),ioState)+				elementMsgIO build rId (MenuChangeLSHandle chLS itemHs) (ls,ps) ioState = do+					r <- elementsMsgIO (\itemHs st ioState -> build (MenuChangeLSHandle (fst st) itemHs) (ls,snd st) ioState) rId itemHs (chLS,ps) ioState+					let (done,(_,ps),ioState) = r+					return (done,(ls,ps),ioState)+				elementMsgIO build _ itemH ls_ps ioState =+					return (False,ls_ps,ioState)+		elementsMsgIO _ _ [] ls_ps ioState =+			return (False,ls_ps,ioState)
+ Graphics/UI/ObjectIO/Menu/Handle.hs view
@@ -0,0 +1,156 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Menu.Handle+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Clean to Haskell Standard Object I\/O library, version 1.2+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Menu.Handle where++import	Graphics.UI.ObjectIO.StdMenuDef+import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.Receiver.Handle+import  Graphics.UI.ObjectIO.SystemId(SystemId)+import  Graphics.UI.ObjectIO.Id(IdParent(..), IdTable, okMembersIdTable)+import  Graphics.UI.ObjectIO.Device.Types(Device(..))+import	Graphics.UI.ObjectIO.OS.Menu+import	Graphics.UI.ObjectIO.OS.Types(OSMenu,OSMenuItem,osNoMenuItem)+import  qualified Data.Map as Map++type MenuElementState ls ps = MenuElementHandle ls ps		-- The internal implementation of a menu element is a MenuElementHandle++data MenuHandles ps+   = MenuHandles+   	{ mMenus	:: ![MenuStateHandle ps]		-- The menus and their elements of a process+	, mKeys		:: ![Char]				-- All shortcut keys of the menus+	, mEnabled	:: !Bool				-- Flag: the whole menusystem is enabled+	, mNrMenuBound	:: !Bound				-- The maximum number of menus that are allowed to be opened+	, mPopUpId	:: !(Maybe Id)				-- The Id of the PopUpMenu (Nothing if open; (Just id) if available)+	}+data MenuStateHandle ps+   = forall ls . MenuStateHandle (MenuLSHandle ls ps)++data MenuLSHandle ls ps+   = MenuLSHandle						-- A menu with local state+      	{ mlsState	:: ls					-- The local state of this menu+   	, mlsHandle	:: MenuHandle ls ps			-- The menu implementation+	}+data MenuHandle ls ps+   = MenuHandle+   	{ mHandle	:: !OSMenu				-- The handle to the menu as created by the OS+	, mMenuId	:: !Id					-- The menu id+	, mTitle	:: !String				-- The title of the menu+	, mSelect	:: !Bool				-- The MenuSelect==Able (by default True)+	, mItems	:: ![MenuElementHandle ls ps]		-- The menu elements of this menu+	}+data MenuElementHandle ls ps +        = MenuItemHandle+	    { mItemId		:: !(Maybe Id)+	    , mItemKey		:: !(Maybe Char)+	    , mItemTitle	:: !Title+	    , mItemSelect	:: !Bool+	    , mItemMark		:: !Bool+	    , mItemAtts		:: ![MenuAttribute ls ps]+	    , mOSMenuItem	:: !OSMenuItem+	    }	+	| MenuReceiverHandle+	    { mReceiverHandle	:: !(ReceiverHandle ls ps)+	    , mReceiverAtts	:: ![MenuAttribute ls ps]+	    }+	| SubMenuHandle+	    { mSubHandle	:: !OSMenu+	    , mSubMenuId	:: !(Maybe Id)+	    , mSubItems		:: ![MenuElementHandle ls ps]+	    , mSubTitle		:: !Title+	    , mSubSelect	:: !Bool+	    , mSubAtts		:: ![MenuAttribute ls ps]+	    }+	| RadioMenuHandle+	    { mRadioId		:: !(Maybe Id)+	    , mRadioIndex	:: !Int+	    , mRadioItems	:: ![MenuElementHandle ls ps]+	    , mRadioSelect	:: !Bool+	    , mRadioAtts	:: ![MenuAttribute ls ps]+	    }+	| MenuSeparatorHandle+	    { mSepId		:: !(Maybe Id)+	    , mOSMenuSeparator  :: !OSMenuItem+	    }+	| MenuListLSHandle	![MenuElementHandle ls ps]+	| forall ls1 . +	  MenuExtendLSHandle ls1 ![MenuElementHandle (ls1,ls) ps]+	| forall ls1 .+	  MenuChangeLSHandle ls1 ![MenuElementHandle ls1 ps]++menuHandleFatalError :: String -> String -> x+menuHandleFatalError function error+	= dumpFatalError function "menuhandle" error+++--	Conversion functions from MenuElementState to MenuElementHandle, and vice versa:+menuElementHandleToMenuElementState :: MenuElementHandle ls ps -> MenuElementState ls ps+menuElementHandleToMenuElementState mH = mH++menuElementStateToMenuElementHandle :: MenuElementState ls ps  -> MenuElementHandle ls ps+menuElementStateToMenuElementHandle mH = mH++{-	menuIdsAreConsistent checks whether the MenuElementHandles contain (R(2))Ids that have already been+	associated with open receivers and if there are no duplicate Ids. +	Neither the ReceiverTable nor the IdTable are changed if there are duplicate (R(2))Ids; +	otherwise all (R(2))Ids have been bound.+-}+menuIdsAreConsistent :: SystemId -> Id -> [MenuElementHandle ls ps] -> IdTable -> Maybe IdTable+menuIdsAreConsistent ioId menuId itemHs it =+    let ids	= foldr getMenuElementMenuId [] itemHs+    in if not (okMembersIdTable ids it) then Nothing+       else Just (foldr insMap it ids)+    where+        insMap id tbl = Map.insert id IdParent {idpIOId=ioId, idpDevice=MenuDevice, idpId=menuId} tbl+	getMenuElementMenuId :: MenuElementHandle ls ps -> [Id] -> [Id]+	getMenuElementMenuId itemH@(MenuItemHandle {mItemId=mItemId}) ids =+	    case mItemId of+		Nothing -> ids+		Just id -> id : ids+	getMenuElementMenuId itemH@(MenuReceiverHandle rH _) ids = rId rH : ids+	getMenuElementMenuId itemH@(SubMenuHandle {mSubMenuId=mSubMenuId,mSubItems=itemHs}) ids =+	    let ids1 = foldr getMenuElementMenuId ids itemHs+	    in case mSubMenuId of+		   Nothing -> ids1+		   Just id -> id : ids1+	getMenuElementMenuId itemH@(RadioMenuHandle {mRadioId=mRadioId,mRadioItems=itemHs}) ids =+	    let ids1 = foldr getMenuElementMenuId ids itemHs+	    in case mRadioId of+		   Nothing -> ids1+		   Just id -> id : ids1+	getMenuElementMenuId itemH@(MenuSeparatorHandle {mSepId=mSepId}) ids =+	    case mSepId of+	    	Nothing -> ids+		Just id -> id : ids+	getMenuElementMenuId (MenuListLSHandle   itemHs) ids =+	    foldr getMenuElementMenuId ids itemHs+	getMenuElementMenuId (MenuExtendLSHandle _ itemHs) ids =+	    foldr getMenuElementMenuId ids itemHs+	getMenuElementMenuId (MenuChangeLSHandle _ itemHs) ids =+	    foldr getMenuElementMenuId ids itemHs+	++--	Convert a RadioMenuItem to the MenuItemHandle alternative of MenuElementHandle:+radioMenuItemToMenuElementHandle :: MenuRadioItem (ls,ps) ps -> MenuElementHandle ls ps+radioMenuItemToMenuElementHandle (title,optId,optShortKey,f)+	= MenuItemHandle+		{ mItemId	= optId+		, mItemKey	= optShortKey+		, mItemTitle	= title+		, mItemSelect	= True+		, mItemMark	= False+		, mItemAtts	= [MenuFunction f]+		, mOSMenuItem	= osNoMenuItem+		}
+ Graphics/UI/ObjectIO/Menu/Internal.hs view
@@ -0,0 +1,210 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Menu.Internal+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- The actual implementation of most of the StdMenu functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Menu.Internal+		( enableMenus, disableMenus, setSelectMenus+		, closeMenuElements, closeMenuIndexElements, closeMenu+		, changeMenuSystemState, accessMenuSystemState+		, setMenuTitle+		) where+++import	Graphics.UI.ObjectIO.Device.SystemState(menuSystemStateGetMenuHandles)+import	Graphics.UI.ObjectIO.Process.IOState+import	Graphics.UI.ObjectIO.Menu.Access+import	Graphics.UI.ObjectIO.Menu.Handle+import	Graphics.UI.ObjectIO.Menu.Items+import	Graphics.UI.ObjectIO.Window.SDISize+import  Graphics.UI.ObjectIO.CommonDef(dumpFatalError, foldrM, removeCheck, remove)+import  Graphics.UI.ObjectIO.Menu.Create(disposeMenuIds, disposeSubMenuHandles)+import  Graphics.UI.ObjectIO.Id(Id(..))+import  Graphics.UI.ObjectIO.StdIOCommon+import	Graphics.UI.ObjectIO.OS.Menu+import	Graphics.UI.ObjectIO.OS.MenuEvent(menuHandlesGetMenuStateHandles)+import	Graphics.UI.ObjectIO.OS.Types(osNoWindowPtr)+import  Control.Monad(when)+import  qualified Data.Map as Map++type DeltaMenuSystem    ps = OSMenuBar -> MenuHandles ps -> IO (MenuHandles ps)+type AccessMenuSystem x ps = OSMenuBar -> MenuHandles ps -> IO (x, MenuHandles ps)++menuInternalFatalError :: String -> String -> x+menuInternalFatalError function error+	= dumpFatalError function "menuinternal" error+++--	General rules to access MenuHandles:++changeMenuSystemState :: Bool -> DeltaMenuSystem ps -> GUI ps ()+changeMenuSystemState redrawMenus f = do+	(found,mDevice) <- accIOEnv (ioStGetDevice MenuDevice)+	(if not found then return ()+	 else do+	        osdinfo <- accIOEnv ioStGetOSDInfo+	        (case getOSDInfoOSMenuBar osdinfo of+	        	Nothing -> menuInternalFatalError "changeMenuSystemState" "could not retrieve OSMenuBar from OSDInfo"+			Just osMenuBar -> do+				newMenus <- liftIO (f osMenuBar (menuSystemStateGetMenuHandles mDevice))+				liftIO (when redrawMenus (drawMenuBar osMenuBar))+				appIOEnv (ioStSetDevice (MenuSystemState newMenus))))+	++accessMenuSystemState :: Bool -> AccessMenuSystem x ps -> GUI ps (Maybe x)+accessMenuSystemState redrawMenus f = do+	(found,mDevice)	<- accIOEnv (ioStGetDevice MenuDevice)+	(if not found then return Nothing+	 else do+			osdinfo <- accIOEnv ioStGetOSDInfo+			(case getOSDInfoOSMenuBar osdinfo of+				Nothing -> menuInternalFatalError "accessMenuSystemState" "could not retrieve OSMenuBar from OSDInfo"+				Just osMenuBar -> do+					(x,newMenus) <- liftIO (f osMenuBar (menuSystemStateGetMenuHandles mDevice))+					liftIO (when redrawMenus (drawMenuBar osMenuBar))+					appIOEnv (ioStSetDevice (MenuSystemState newMenus))+					return (Just x)))+++{-	Closing a menu.+	Because in a SDI process menus might reside in the process window, the ViewFrame of the+	process window can change size.+	In that case, the layout of the controls should be recalculated, and the window updated.+-}++closeMenu :: Id -> GUI ps ()+closeMenu id = do+	osdInfo <- accIOEnv ioStGetOSDInfo+	(if getOSDInfoDocumentInterface osdInfo==NDI+	 then return ()+	 else+			case getOSDInfoOSMenuBar osdInfo of+				Nothing -> menuInternalFatalError "closeMenu" "could not retrieve OSMenuBar from OSDInfo"+				Just osMenuBar  -> do+						(found,mDevice)	<- accIOEnv (ioStGetDevice MenuDevice)+						(if not found then return ()+						 else+							let+								mHs	= menuSystemStateGetMenuHandles mDevice+								(menus,mHs1) = menuHandlesGetMenuStateHandles mHs+								(found,mH,menus1)	= remove (isMenuWithThisId id) undefined menus+							in +								if not found then do+									appIOEnv (ioStSetDevice (MenuSystemState mHs{mMenus=menus1}))+								else do+										(sdiSize1,sdiPtr) <- getSDIWindowSize+										keys <- liftIO (closeSubMenus osdInfo mH (mKeys mHs))+										it <- ioStGetIdTable+										ioid <- accIOEnv ioStGetIOId+										ioStSetIdTable (closeMenuIds ioid mH (Map.delete id it))+										liftIO (osMenuRemove (menuStateHandleGetHandle mH) osMenuBar >>+											drawMenuBar osMenuBar)+										let mHs1 = mHs{mMenus=menus1,mKeys=keys}+										appIOEnv (ioStSetDevice (MenuSystemState mHs1))+										(sdiSize2,_) <- getSDIWindowSize+										when (sdiSize1/=sdiSize2) (resizeSDIWindow sdiPtr sdiSize1 sdiSize2)))+	where+		isMenuWithThisId :: Id -> MenuStateHandle ps -> Bool+		isMenuWithThisId id msH = (id == menuStateHandleGetMenuId msH)+			++closeSubMenus :: OSDInfo -> MenuStateHandle ps -> [Char] -> IO [Char]+closeSubMenus osdInfo (MenuStateHandle (MenuLSHandle {mlsHandle=mH})) keys =+	foldrM (disposeSubMenuHandles framePtr) keys (mItems mH)+	where+		framePtr	= case (getOSDInfoOSInfo osdInfo) of+			Just info -> osFrame info+			_         -> osNoWindowPtr++closeMenuIds :: SystemId -> MenuStateHandle ps -> IdTable -> IdTable+closeMenuIds pid (MenuStateHandle (MenuLSHandle {mlsHandle=mH})) it =+	foldr (disposeMenuIds pid) it (mItems mH)+++--	Enabling and Disabling of Menus:++enableMenus  :: [Id] -> GUI ps ()+enableMenus  ids = changeMenuSystemState True (setSelectMenus ids Able)++disableMenus :: [Id] -> GUI ps ()+disableMenus ids = changeMenuSystemState True (setSelectMenus ids Unable)++setSelectMenus :: [Id] -> SelectState -> OSMenuBar -> MenuHandles ps -> IO (MenuHandles ps)+setSelectMenus ids select osMenuBar menus@(MenuHandles {mEnabled=mEnabled,mMenus=mMenus}) = do+	(_,msHs) <- setSelectMenuHandles select osMenuBar mEnabled ids mMenus+	return (menus{mMenus=msHs})+	where	+		setSelectMenuHandles :: SelectState -> OSMenuBar -> Bool -> [Id] -> [MenuStateHandle ps] -> IO ([Id],[MenuStateHandle ps])+		setSelectMenuHandles select osMenuBar systemAble ids [] =+			return (ids,[])+		setSelectMenuHandles select osMenuBar systemAble ids (msH:msHs)+			| null ids = return (ids,msHs)+			| otherwise = do				+				(ids,msH)  <- setSelectMenuHandle  select osMenuBar systemAble ids msH+				(ids,msHs) <- setSelectMenuHandles select osMenuBar systemAble ids msHs+				return (ids,msH:msHs)+			where+				setSelectMenuHandle :: SelectState -> OSMenuBar -> Bool -> [Id] -> MenuStateHandle ps -> IO ([Id], MenuStateHandle ps)+				setSelectMenuHandle select osMenuBar systemAble ids msH@(MenuStateHandle mlsH@(MenuLSHandle {mlsHandle=mH@(MenuHandle {mMenuId=mMenuId,mHandle=mHandle})})) =+					let +						(containsId,ids1) = removeCheck mMenuId ids+						msH1 = MenuStateHandle mlsH{mlsHandle=mH{mSelect=enabled select}}+					in+						if not containsId then return (ids1,msH)+						else+							if not systemAble then return (ids1,msH1)+							else do								+								(if enabled select then osEnableMenu else osDisableMenu) mHandle osMenuBar+								return (ids1,msH1)++--	Removing menu elements from (sub/radio)menus:++closeMenuElements :: Id -> [Id] -> GUI ps ()+closeMenuElements mId ids = do+	pid <- accIOEnv ioStGetIOId+	it <- ioStGetIdTable+	osdInfo <- accIOEnv ioStGetOSDInfo+	result <- accessMenuSystemState True (removeMenusItems osdInfo mId ids pid it)+	maybe (return ()) ioStSetIdTable result+++--	Removing menu elements from (sub/radio)menus by index (counting from 1):++closeMenuIndexElements :: Bool -> SystemId -> (Id,Maybe Id) -> [Index] -> GUI ps ()+closeMenuIndexElements fromRadioMenu pid loc indices = do+	it <- ioStGetIdTable+	osdInfo <- accIOEnv ioStGetOSDInfo+	result <- accessMenuSystemState True (removeMenusIndexItems osdInfo fromRadioMenu loc indices pid it)+	maybe (return ()) ioStSetIdTable result+++--	Set & Get the title of a menu.++setMenuTitle :: Id -> Title -> GUI ps ()+setMenuTitle id title = +	changeMenuSystemState True (setOSMenuTitle id title)+	where+		setOSMenuTitle :: Id -> Title -> OSMenuBar -> MenuHandles ps -> IO (MenuHandles ps)+		setOSMenuTitle id title osMenuBar menus@(MenuHandles {mMenus=msHs}) = do+			msHs <- setOSMenusTitle id title osMenuBar msHs+			return (menus{mMenus=msHs})+			where+				setOSMenusTitle :: Id -> Title -> OSMenuBar -> [MenuStateHandle ps] -> IO [MenuStateHandle ps]+				setOSMenusTitle id title osMenuBar (msH:msHs)+					| id == menuStateHandleGetMenuId msH = do					+						osChangeMenuTitle osMenuBar (menuStateHandleGetHandle msH) title+						return (menuStateHandleSetTitle title msH:msHs)+					| otherwise = do+						msHs <- setOSMenusTitle id title osMenuBar msHs+						return (msH:msHs)+				setOSMenusTitle _ _ _ msHs = return msHs
+ Graphics/UI/ObjectIO/Menu/Items.hs view
@@ -0,0 +1,526 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Menu.Items+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Menu.Items+		( addMenusItems, addMenuRadioItems+		, removeMenusItems, removeMenusIndexItems+		) where++++import  Graphics.UI.ObjectIO.Id+import	Graphics.UI.ObjectIO.CommonDef+import  Graphics.UI.ObjectIO.Process.IOState+import  Graphics.UI.ObjectIO.StdMenuElementClass+import  Graphics.UI.ObjectIO.StdMenuDef(MenuRadioItem)+import	Graphics.UI.ObjectIO.Menu.Create+import	Graphics.UI.ObjectIO.Menu.Handle+import	Graphics.UI.ObjectIO.Receiver.Handle+import	Graphics.UI.ObjectIO.OS.DocumentInterface+import	Graphics.UI.ObjectIO.OS.Menu+import	Graphics.UI.ObjectIO.OS.Types(osNoWindowPtr, OSWindowPtr, OSMenu)+import  qualified Data.Map as Map+++{-	Adding menu elements to (Sub)Menus:+		Items in a (sub)menu are positioned starting from 1 and increasing by 1.+		Open with a position less than 1 adds the new elements in front.+		Open with a position higher than the number of items adds the new elements to the end.+		Open an item on a position adds the item AFTER the item on that position.+	The (Id,Maybe Id) argument indicates where the elements should be added. +		In case the Maybe Id argument is Nothing, then the elements should be added to the Menu indicated by the Id component. +		In case the Maybe Id argument is Just id, then the elements should be added to the SubMenu indicated by id.+-}+addMenusItems :: MenuElements m => (Id,Maybe Id) -> Int -> ls -> (m ls ps) -> SystemId -> IdTable -> MenuHandles ps -> OSMenuBar -> GUI ps (IdTable,MenuHandles ps)+addMenusItems loc pos ls new pid it menus@(MenuHandles {mMenus=mMenus,mKeys=mKeys}) osMenuBar = do+    newItemHs <- menuElementToHandles new+    (let newItemHs1 = map menuElementStateToMenuElementHandle newItemHs+     in case menuIdsAreConsistent pid (fst loc) newItemHs1 it of+     		Just it -> do+     			(_,it,mHs,keys) <- liftIO (addMenusItems' loc pos ls newItemHs1 pid it mMenus mKeys)+			return (it,menus{mMenus=mHs,mKeys=keys})+     		Nothing -> throwGUI ErrorIdsInUse)+    where+	addMenusItems' :: (Id,Maybe Id) -> Int -> ls' -> [MenuElementHandle ls' ps] -> SystemId -> IdTable -> [MenuStateHandle ps] -> [Char] -> IO (ls',IdTable,[MenuStateHandle ps],[Char])+	addMenusItems' _ _ ls _ _ it [] keys = throwGUI ErrorUnknownObject+	addMenusItems' loc pos ls new pid it ((MenuStateHandle mlsH@(MenuLSHandle {mlsHandle=mH})):msHs) keys = do+	    (opened,ls,it,mH,keys)	<- addMenuItems loc pos ls new pid it mH keys+	    let msH = MenuStateHandle mlsH{mlsHandle=mH}+	    (if opened then return (ls,it,msH:msHs,keys)+	     else do+		(ls,it,    msHs, keys) <- addMenusItems' loc pos ls new pid it msHs keys+		return (ls,it,msH:msHs,keys))+	    where+		addMenuItems :: (Id,Maybe Id) -> Int -> ls' -> [MenuElementHandle ls' ps] -> SystemId -> IdTable -> MenuHandle ls ps -> [Char] -> IO (Bool,ls',IdTable,MenuHandle ls ps,[Char])+		addMenuItems (mId,itemId) pos ls new pid it mH@(MenuHandle {mHandle=mHandle,mMenuId=mMenuId,mItems=mItems}) keys+		    | mId /= mMenuId = return (False,ls,it,mH,keys)+		    | isJust itemId = do+			(_,   ls,it,items,keys,_) <- addSubMenuItems' mId (fromJust itemId) pos mHandle ls new pid it mItems keys 1+			return (True,ls,it,mH{mItems=items},keys)+		    | otherwise = do+			(_,   ls,it,itemHs,keys,_,_) <- extendMenu' mId mHandle ls new pid it mItems keys pos 1+			return (True,ls,it,mH{mItems=itemHs},keys)+		    where+			addSubMenuItems' :: Id -> Id -> Int -> OSMenu -> ls' -> [MenuElementHandle ls' ps] -> SystemId -> IdTable -> [MenuElementHandle ls ps] -> [Char] -> Int -> IO (Bool,ls',IdTable,[MenuElementHandle ls ps],[Char],Int)+			addSubMenuItems' menuId itemId pos menu ls new pid it (item:items) keys iNr = do+				(opened,ls,it,item,keys,iNr) <- addSubMenuItems menuId itemId pos menu ls new pid it item keys iNr+				(if opened+				 then return (opened,ls,it,item:items,keys,iNr)+				 else do+					(opened,ls,it,items,keys,iNr) <- addSubMenuItems' menuId itemId pos menu ls new pid it items keys iNr+					return (opened,ls,it,item:items,keys,iNr))+			addSubMenuItems' _ _ _ _ ls _ _ it _ keys iNr =+				return (False,ls,it,[],keys,iNr)+			+			addSubMenuItems :: Id -> Id -> Int -> OSMenu -> ls' -> [MenuElementHandle ls' ps] -> SystemId -> IdTable -> MenuElementHandle ls ps -> [Char] -> Int -> IO (Bool,ls',IdTable,MenuElementHandle ls ps,[Char],Int)+			addSubMenuItems menuId itemId pos menu ls new pid it itemH@(SubMenuHandle {mSubHandle=mSubHandle,mSubMenuId=mSubMenuId,mSubItems=mSubItems}) keys iNr =+				case mSubMenuId of+					Just id | itemId==id -> do+						(_,ls,it,itemHs,keys,_,_) <- extendMenu' menuId mSubHandle ls new pid it mSubItems keys pos 1+						return (True,ls,it,itemH{mSubItems=itemHs},keys,iNr+1)+					Nothing -> do+						(opened,ls,it,items,keys,_) <- addSubMenuItems' menuId itemId pos mSubHandle ls new pid it mSubItems keys 1+						return (opened,ls,it,itemH{mSubItems=items},keys,iNr+1)+			addSubMenuItems _ _ _ _ ls _ _ it itemH@(RadioMenuHandle {mRadioItems=mRadioItems}) keys iNr = do+				return (False,ls,it,itemH,keys,iNr+length mRadioItems)+			addSubMenuItems menuId itemId pos menu ls new pid it (MenuListLSHandle itemHs) keys iNr = do+				(opened,ls,it,itemHs,keys,iNr) <- addSubMenuItems' menuId itemId pos menu ls new pid it itemHs keys iNr+				return (opened,ls,it,MenuListLSHandle itemHs,keys,iNr)+			addSubMenuItems menuId itemId pos menu ls new pid it (MenuExtendLSHandle exLS itemHs) keys iNr = do+				(opened,ls,it,itemHs,keys,iNr) <- addSubMenuItems' menuId itemId pos menu ls new pid it itemHs keys iNr+				return (opened,ls,it,MenuExtendLSHandle exLS itemHs,keys,iNr)+			addSubMenuItems menuId itemId pos menu ls new pid it (MenuChangeLSHandle chLS itemHs) keys iNr = do+				(opened,ls,it,itemHs,keys,iNr)	<- addSubMenuItems' menuId itemId pos menu ls new pid it itemHs keys iNr+				return (opened,ls,it,MenuChangeLSHandle chLS itemHs,keys,iNr)+			addSubMenuItems _ _ _ _ ls _ _ it itemH keys iNr = do+				return (False,ls,it,itemH,keys,iNr+1)+			+			extendMenu' :: Id -> OSMenu -> ls' -> [MenuElementHandle ls' ps] -> SystemId -> IdTable -> [MenuElementHandle ls ps] -> [Char] -> Int -> Int -> IO (Bool,ls',IdTable,[MenuElementHandle ls ps],[Char],Int,Int)+			extendMenu' menuId menu ls new pid it itemHs keys 0 iNr = do+				let newItemHs = MenuChangeLSHandle ls new+				(itemHs,keys) <- extendMenu osMenuBar menu (iNr-1) [newItemHs] itemHs keys+				return (True,undefined,it,itemHs,keys,pos,iNr)+			extendMenu' _ _ ls _ _ it [] keys pos iNr =+				return (False,ls,it,[],keys,pos,iNr)+			extendMenu' menuId menu ls new pid it (itemH@(MenuItemHandle {}):itemHs) keys pos iNr = do+				(opened,ls,it,itemHs,keys,pos,iNr) <- extendMenu' menuId menu ls new pid it itemHs keys (pos-1) (iNr+1)+				return (opened,ls,it,itemH:itemHs,keys,pos,iNr)+			extendMenu' menuId menu ls new pid it (itemH@(MenuReceiverHandle _ _):itemHs) keys pos iNr = do+				(opened,ls,it,itemHs,keys,pos,iNr) <- extendMenu' menuId menu ls new pid it itemHs keys pos iNr+				return (opened,ls,it,itemH:itemHs,keys,pos,iNr)+			extendMenu' menuId menu ls new pid it (itemH@(SubMenuHandle {}):itemHs) keys pos iNr = do+				(opened,ls,it,itemHs,keys,pos,iNr) <- extendMenu' menuId menu ls new pid it itemHs keys (pos-1) (iNr+1)+				return (opened,ls,it,itemH:itemHs,keys,pos,iNr)+			extendMenu' menuId menu ls new pid it (itemH@(RadioMenuHandle {mRadioItems=mRadioItems}):itemHs) keys pos iNr = do+				(opened,ls,it,itemHs,keys,pos,iNr) <- extendMenu' menuId menu ls new pid it itemHs keys (pos-1) (iNr+length mRadioItems)+				return (opened,ls,it,itemH:itemHs,keys,pos,iNr)+			extendMenu' menuId menu ls new pid it (itemH@(MenuSeparatorHandle {}):itemHs) keys pos iNr = do+				(opened,ls,it,itemHs,keys,pos,iNr) <- extendMenu' menuId menu ls new pid it itemHs keys (pos-1) (iNr+1)+				return (opened,ls,it,itemH:itemHs,keys,pos,iNr)+			extendMenu' menuId menu ls new pid it ((MenuListLSHandle itemHs'):itemHs) keys pos iNr = do+				(opened,ls,it,itemHs',keys,pos,iNr) <- extendMenu' menuId menu ls new pid it itemHs' keys pos iNr+				let itemH = MenuListLSHandle itemHs'+				(if opened then return (opened,ls,it,itemH:itemHs,keys,pos,iNr)+				 else do+					(opened,ls,it,itemHs,keys,pos,iNr) <- extendMenu' menuId menu ls new pid it itemHs  keys pos iNr+					return (opened,ls,it,itemH:itemHs,keys,pos,iNr))+			extendMenu' menuId menu ls new pid it ((MenuExtendLSHandle exLS itemHs'):itemHs) keys pos iNr = do+				(opened,ls,it,itemHs',keys,pos,iNr) <- extendMenu' menuId menu ls new pid it itemHs' keys pos iNr+				let itemH = MenuExtendLSHandle exLS itemHs'+				(if opened then return (opened,ls,it,itemH:itemHs,keys,pos,iNr)+				 else do+					(opened,ls,it,itemHs,keys,pos,iNr) <- extendMenu' menuId menu ls new pid it itemHs keys pos iNr+					return (opened,ls,it,itemH:itemHs,keys,pos,iNr))+			extendMenu' menuId menu ls new pid it ((MenuChangeLSHandle chLS itemHs'):itemHs) keys pos iNr = do+				(opened,ls,it,itemHs',keys,pos,iNr) <- extendMenu' menuId menu ls new pid it itemHs' keys pos iNr+				let itemH = MenuChangeLSHandle chLS itemHs'+				(if opened then return (opened,ls,it,itemH:itemHs,keys,pos,iNr)+				 else do+					(opened,ls,it,itemHs,keys,pos,iNr) <- extendMenu' menuId menu ls new pid it itemHs  keys pos iNr+					return (opened,ls,it,itemH:itemHs,keys,pos,iNr))+++{-	Adding radio menu items to RadioMenus:+		Items in a RadioMenu are positioned starting from 1 and increasing by 1.+		Open with a position less than 1 adds the new elements in front.+		Open with a position higher than the number of items adds the new elements to the end.+		Open an item on a position adds the item AFTER the item on that position.+	The (Id,Id) argument indicates where the elements should be added. +		The first Id indicates the Menu, the second Id indicates the RadioMenu.+-}+addMenuRadioItems :: (Id,Id) -> Int -> [MenuRadioItem ps ps] -> OSMenuBar -> MenuHandles ps -> IO (MenuHandles ps)+addMenuRadioItems loc pos new osMenuBar menus@(MenuHandles {mMenus=msHs,mKeys=mKeys}) = do+    (msHs,keys) <- addMenusItems' loc pos new msHs mKeys+    return (menus{mMenus=msHs,mKeys=keys})+    where+	addMenusItems' :: (Id,Id) -> Int -> [MenuRadioItem ps ps] -> [MenuStateHandle ps] -> [Char] -> IO ([MenuStateHandle ps],[Char])+	addMenusItems' _ _ _ [] keys = throwGUI ErrorUnknownObject+	addMenusItems' loc pos new (MenuStateHandle mlsH@(MenuLSHandle {mlsHandle=mH}):msHs) keys = do+	    (opened,mH,keys) <- addMenuItems loc pos new mH keys+	    let msH = MenuStateHandle mlsH{mlsHandle=mH}+	    (if opened+	     then return (msH:msHs,keys)+	     else do+		(msHs,keys) <- addMenusItems' loc pos new msHs keys+		return (msH:msHs,keys))+	    where+		addMenuItems :: (Id,Id) -> Int -> [MenuRadioItem ps ps] -> (MenuHandle ls ps) -> [Char] -> IO (Bool,MenuHandle ls ps,[Char])+		addMenuItems (mId,itemId) pos new mH@(MenuHandle {mHandle=mHandle,mMenuId=mMenuId,mItems=mItems}) keys+		    | mId /= mMenuId = return (False,mH,keys)+		    | otherwise = do+			   (_,itemHs,keys,_)	<- addSubMenuItems' itemId pos mHandle new mItems keys 1			   +			   return (True,mH{mItems=itemHs},keys)+		    where+			addSubMenuItems' :: Id -> Int -> OSMenu -> [MenuRadioItem ps ps] -> [MenuElementHandle ls ps] -> [Char] -> Int -> IO (Bool,[MenuElementHandle ls ps],[Char],Int)+			addSubMenuItems' itemId pos menu new (itemH:itemHs) keys iNr = do+				(opened,itemH,sIds,iNr) <- addSubMenuItems itemId pos menu new itemH keys iNr+				(if opened then return (opened,itemH:itemHs,keys,iNr)+				 else do+					(opened,itemHs,keys,iNr) <- addSubMenuItems' itemId pos menu new itemHs sIds iNr+					return (opened,itemH:itemHs,keys,iNr))+			addSubMenuItems' _ _ _ _ _ keys iNr =+				throwGUI ErrorUnknownObject+			+			addSubMenuItems :: Id -> Int -> OSMenu -> [MenuRadioItem ps ps] -> MenuElementHandle ls ps -> [Char] -> Int -> IO (Bool,MenuElementHandle ls ps,[Char],Int)+			addSubMenuItems itemId pos menu new itemH@(SubMenuHandle {mSubHandle=handle,mSubItems=itemHs}) keys iNr = do+				(opened,itemHs,keys,_) <- addSubMenuItems' itemId pos handle new itemHs keys 1+				return (opened,itemH{mSubItems=itemHs},keys,iNr+1)+			addSubMenuItems itemId pos menu new itemH@(RadioMenuHandle {mRadioId=mRadioId,mRadioIndex=mRadioIndex,mRadioItems=itemHs}) keys iNr =+				let nrItems = length itemHs+				in if isNothing mRadioId || itemId /= fromJust mRadioId+				   then return (False,itemH,keys,iNr+nrItems)+				   else let newItemHs 	= map (\(a,b,c,f)->radioMenuItemToMenuElementHandle (a,b,c,noLS f)) new+				  	    nrNewItems	= length newItemHs+				  	    pos		= setBetween pos 0 nrItems+				  	    index	= if pos<mRadioIndex then mRadioIndex+nrNewItems else max 1 mRadioIndex+				        in do+				     		(itemHs,keys) <- extendMenu' iNr pos menu newItemHs itemHs keys+						(if nrItems /= 0+						 then return (True,itemH{mRadioIndex=index,mRadioItems=itemHs},keys,iNr+nrItems+nrNewItems)+						 else do+						 	  osMenuItemCheck True menu (mOSMenuItem (itemHs!!(index-1)))+							  return (True,itemH{mRadioIndex=1, mRadioItems=itemHs},keys,iNr+nrItems+nrNewItems))+			addSubMenuItems itemId pos menu new (MenuListLSHandle itemHs) keys iNr = do+				(opened,itemHs,keys,iNr) <- addSubMenuItems' itemId pos menu new itemHs keys iNr+				return (opened,MenuListLSHandle itemHs,keys,iNr)+			addSubMenuItems itemId pos menu new (MenuExtendLSHandle exLS itemHs) keys iNr = do+				(opened,itemHs,keys,iNr) <- addSubMenuItems' itemId pos menu new itemHs keys iNr+				return (opened,MenuExtendLSHandle exLS itemHs,keys,iNr)+			addSubMenuItems itemId pos menu new (MenuChangeLSHandle chLS itemHs) keys iNr = do+				(opened,itemHs,keys,iNr) <- addSubMenuItems' itemId pos menu new itemHs keys iNr+				return (opened,MenuChangeLSHandle chLS itemHs,keys,iNr)+			addSubMenuItems _ _ _ _ itemH@(MenuReceiverHandle {}) keys iNr =+				return (False,itemH,keys,iNr)+			addSubMenuItems _ _ _ _ itemH keys iNr = +				return (False,itemH,keys,iNr+1)+			+			extendMenu' :: Int -> Int -> OSMenu -> [MenuElementHandle ls ps] -> [MenuElementHandle ls ps] -> [Char] -> IO ([MenuElementHandle ls ps],[Char])+			extendMenu' iNr 0 menu new itemHs keys =+				extendMenu osMenuBar menu (iNr-1) new itemHs keys+			extendMenu' iNr position menu new (itemH:itemHs) keys = do+				(itemHs,keys) <- extendMenu' (iNr+1) (position-1) menu new itemHs keys+				return (itemH:itemHs,keys)+			extendMenu' iNr position menu new items keys =+				extendMenu osMenuBar menu (iNr-1) new items keys	+++--	Removing menu elements from (sub/radio)menus:++removeMenusItems :: OSDInfo -> Id -> [Id] -> SystemId -> IdTable -> OSMenuBar -> MenuHandles ps -> IO (IdTable,MenuHandles ps)+removeMenusItems osdInfo mId ids pid it _ menus@(MenuHandles {mMenus=mMenus,mKeys=mKeys}) = do+	(it,mHs,keys) <- removeMenusItems' framePtr mId ids pid it mMenus mKeys+	return (it,menus{mMenus=mHs,mKeys=keys})+    where+		framePtr = case getOSDInfoOSInfo osdInfo of+			Just info -> osFrame info+			_         -> osNoWindowPtr+		+		removeMenusItems' :: OSWindowPtr -> Id -> [Id] -> SystemId -> IdTable -> [MenuStateHandle ps] -> [Char] -> IO (IdTable,[MenuStateHandle ps],[Char])+		removeMenusItems' _ _ [] _ it mHs keys = return (it,mHs,keys)+		removeMenusItems' framePtr mId ids pid it (MenuStateHandle mlsH@(MenuLSHandle {mlsHandle=mH@(MenuHandle {mMenuId=mMenuId})}):mHs) keys+			| mId /= mMenuId = do+				(it,mHs,keys) <- removeMenusItems' framePtr mId ids pid it mHs keys+				return (it,MenuStateHandle mlsH:mHs,keys)+			| otherwise = do+				(it,_,mH,keys) <- removeMenuItems framePtr pid it ids mH keys+				return (it,MenuStateHandle (mlsH{mlsHandle=mH}):mHs,keys)+			where+				removeMenuItems :: OSWindowPtr -> SystemId -> IdTable -> [Id] -> MenuHandle ls ps -> [Char] -> IO (IdTable,[Id],MenuHandle ls ps,[Char])+				removeMenuItems framePtr pid it ids mH@(MenuHandle {mHandle=mHandle,mItems=mItems}) keys = do+					(_,it,ids,mItems,keys) <- removeFromMenu' framePtr mHandle pid 1 it ids mItems keys+					return (it,ids,mH{mItems=mItems},keys)+					where+						removeFromMenu' :: OSWindowPtr -> OSMenu -> SystemId -> Int -> IdTable -> [Id] -> [MenuElementHandle ls ps] -> [Char] -> IO (Int,IdTable,[Id],[MenuElementHandle ls ps],[Char])+						removeFromMenu' framePtr menu pid iNr it ids [] keys = return (iNr,it,ids,[],keys)+						removeFromMenu' framePtr menu pid iNr it ids (item:items) keys+							| null ids  = return (iNr,it,ids,items,keys)+							| otherwise = do					+									(removed,iNr,it,ids,item, keys)	<- removeFromMenu  framePtr menu pid iNr it ids item  keys+									(        iNr,it,ids,items,keys)	<- removeFromMenu' framePtr menu pid iNr it ids items keys+									return (iNr,it,ids,if removed then items else (item:items), keys)+						+						removeFromMenu :: OSWindowPtr -> OSMenu -> SystemId -> Int -> IdTable -> [Id] -> MenuElementHandle ls ps -> [Char] -> IO (Bool,Int,IdTable,[Id],MenuElementHandle ls ps,[Char])+						removeFromMenu framePtr menu pid iNr it ids itemH@(MenuItemHandle {mItemId=mItemId,mItemKey=mItemKey,mOSMenuItem=mOSMenuItem}) keys =+							let (containsItem,ids1) = case mItemId of+									Nothing -> (False,ids)+									Just id -> removeCheck id ids+							in+								if not containsItem then return (containsItem,iNr+1,it,ids1,itemH,keys)+								else do+										(keys,it) <- disposeMenuItemHandle menu iNr itemH (keys, it)+										return (containsItem,iNr,it,ids1,itemH,keys)+						removeFromMenu framePtr menu pid iNr it ids itemH@(SubMenuHandle {mSubHandle=mSubHandle,mSubMenuId=mSubMenuId,mSubItems=mSubItems}) keys =+							let (containsItem,ids1) = case mSubMenuId of+									Nothing -> (False,ids)+									Just id -> removeCheck id ids+							in do+									(_,it,ids2,itemHs,keys) <- removeFromMenu' framePtr mSubHandle pid 1 it ids1 mSubItems keys+									let itemH1 = itemH{mSubItems=itemHs}+									(if not containsItem then return (containsItem,iNr+1,it,ids2,itemH1,keys)+									 else do+											let it1 = foldr (disposeMenuIds pid) it itemHs+											keys <- foldrM (disposeSubMenuHandles framePtr) keys itemHs+											osSubMenuRemove mSubHandle menu+											return (containsItem,iNr,it,ids2,itemH1,keys))+						removeFromMenu framePtr menu pid iNr it ids itemH@(RadioMenuHandle {mRadioId=mRadioId,mRadioIndex=mRadioIndex,mRadioItems=mRadioItems}) keys =+							let +								(containsItem,ids1) = case mRadioId of+									Nothing -> (False,ids)+									Just id -> removeCheck id ids+								items	= confirmRadioMenuIndex mRadioIndex mRadioItems+							in do+									(_,it,ids2,items,keys) <- removeFromMenu' framePtr menu pid iNr it ids1 items keys+									(if containsItem then do+										(keys,it) <- foldrM (disposeMenuItemHandle menu iNr) (keys,it) items+										let itemH1 = itemH{mRadioItems=[]}+										return (containsItem,iNr,it,ids2,itemH1,keys)+									 else do+										(index,items) <- checkNewRadioMenuIndex menu iNr items+										let nrNewItems = length items+										let itemH1 = itemH{mRadioItems=items,mRadioIndex=index}+										return (containsItem,iNr+nrNewItems,it,ids2,itemH1,keys))+						removeFromMenu framePtr menu pid iNr it ids itemH@(MenuSeparatorHandle {mSepId=mSepId,mOSMenuSeparator=mOSMenuSeparator}) keys =+							let (containsItem,ids1) = case mSepId of+									Nothing -> (False,ids)+									Just id -> removeCheck id ids+							in +								if not containsItem then return (containsItem,iNr+1,it,ids1,itemH,keys)+								else do+									osMenuRemoveItem mOSMenuSeparator menu+									let it1 = Map.delete (fromJust mSepId) it+									return (containsItem,iNr,it1,ids1,itemH,keys)+						removeFromMenu framePtr menu pid iNr it ids itemH@(MenuReceiverHandle rH@(ReceiverHandle {rId=rId}) _) keys =+							let (containsItem,ids1) = removeCheck rId ids+							in+								if not containsItem+								then return (containsItem,iNr,it,ids,itemH,keys)+								else return (containsItem,iNr,Map.delete rId it,ids,itemH,keys)+						removeFromMenu framePtr menu pid iNr it ids (MenuListLSHandle items) keys = do+							(iNr,it,ids,items,keys) <- removeFromMenu' framePtr menu pid iNr it ids items keys+							return (False,iNr,it,ids,MenuListLSHandle items,keys)+						removeFromMenu framePtr menu pid iNr it ids (MenuExtendLSHandle exLS items) keys = do+							(iNr,it,ids,items,keys) <- removeFromMenu' framePtr menu pid iNr it ids items keys+							return (False,iNr,it,ids,MenuExtendLSHandle exLS items,keys)+						removeFromMenu framePtr menu pid iNr it ids (MenuChangeLSHandle chLS items) keys = do+							(iNr,it,ids,items,keys) <- removeFromMenu' framePtr menu pid iNr it ids items keys+							return (False,iNr,it,ids,MenuChangeLSHandle chLS items,keys)+		removeMenusItems' _ _ _ _ it [] keys = return (it,[],keys)+++{-	Removing menu elements from (sub/radio)menus by index (counting from 1):+	The second Boolean argument indicates whether the elements to be removed should be removed+		from RadioMenus (True) or (Sub)Menus (False).  +	The (Id,Maybe Id) argument indicates where the elements should be removed. +		In case the Maybe Id argument is Nothing, then the elements should be removed from +		the Menu indicated by the Id component. +		In case the Maybe Id argument is Just id, then the elements should be removed from+		either a SubMenu or a RadioMenu identified by the Id component.+-}+++removeMenusIndexItems :: OSDInfo -> Bool -> (Id,Maybe Id) -> [Int] -> SystemId -> IdTable -> OSMenuBar -> MenuHandles ps -> IO (IdTable, MenuHandles ps)+removeMenusIndexItems osdInfo fromRadioMenu loc indices pid it _ menus@(MenuHandles {mMenus=mMenus,mKeys=mKeys}) = do+	(it,mHs,keys) <- removeMenusIndexItems' framePtr fromRadioMenu loc indices pid it mMenus mKeys+	return (it,menus{mMenus=mHs,mKeys=keys})+	where+		framePtr = case getOSDInfoOSInfo osdInfo of+				Just info -> osFrame info+				_         -> osNoWindowPtr++		dec x = x - 1+		+		removeMenusIndexItems' :: OSWindowPtr -> Bool -> (Id,Maybe Id) -> [Int] -> SystemId -> IdTable -> [MenuStateHandle ps] -> [Char] -> IO (IdTable,[MenuStateHandle ps],[Char])+		removeMenusIndexItems' framePtr fromRadioMenu loc@(mId,itemId) indices pid it ((MenuStateHandle mlsH@(MenuLSHandle {mlsHandle=mH@(MenuHandle {mMenuId=mMenuId})})):mHs) keys+			| mId /= mMenuId = do+				(it,mHs,keys) <- removeMenusIndexItems' framePtr fromRadioMenu loc indices pid it mHs keys+				return (it,(MenuStateHandle mlsH):mHs,keys)+			| otherwise = do+				(_,it,mH,keys) <- removeMenuIndexItems framePtr fromRadioMenu itemId indices pid it mH keys+				return (it,(MenuStateHandle mlsH{mlsHandle=mH}):mHs,keys)+		removeMenusIndexItems' _ _ _ _ _ it [] keys = return (it,[],keys)+		+		removeMenuIndexItems :: OSWindowPtr -> Bool -> Maybe Id -> [Int] -> SystemId -> IdTable -> MenuHandle ls ps -> [Char] -> IO (Bool,IdTable,MenuHandle ls ps,[Char])+		removeMenuIndexItems framePtr fromRadioMenu itemId indices pid it mH@(MenuHandle {mHandle=mHandle,mItems=mItems}) keys =+			case itemId of+				Nothing -> do+						(_,_,it,mItems,keys)	<- removeItems' framePtr mHandle pid 1 indices it mItems keys+						return (True,it,mH{mItems=mItems},keys)+				Just id -> do+						(done,_,it,mItems,keys) <- removeIndexsFromMenu' framePtr fromRadioMenu pid id indices mHandle 1 it mItems keys+						return (done,it,mH{mItems=mItems},keys)+			where+				removeIndexsFromMenu' :: OSWindowPtr -> Bool -> SystemId -> Id -> [Int] -> OSMenu -> Int -> IdTable -> [MenuElementHandle ls ps] -> [Char] -> IO (Bool,Int,IdTable,[MenuElementHandle ls ps],[Char])+				removeIndexsFromMenu' framePtr fromRadioMenu pid itemId indices menu iNr it [] keys =+					return (False,iNr,it,[],keys)+				removeIndexsFromMenu' framePtr fromRadioMenu pid itemId indices menu iNr it (item:items) keys = do+					(done,iNr,it,item,keys) <- removeIndexsFromMenu framePtr fromRadioMenu pid itemId indices menu iNr it item keys+					(if done then return (done,iNr,it,item:items,keys)+					 else do+						(done,iNr,it,items,keys) <- removeIndexsFromMenu' framePtr fromRadioMenu pid itemId indices menu iNr it items keys+						return (done,iNr,it,item:items,keys))+				+				removeIndexsFromMenu :: OSWindowPtr -> Bool -> SystemId -> Id -> [Int] -> OSMenu -> Int -> IdTable -> MenuElementHandle ls ps -> [Char] -> IO (Bool,Int,IdTable,MenuElementHandle ls ps,[Char])+				removeIndexsFromMenu framePtr fromRadioMenu pid itemId indices menu iNr it subH@(SubMenuHandle {mSubHandle=mSubHandle,mSubMenuId=mSubMenuId,mSubItems=mSubItems}) keys+					| isJust mSubMenuId && itemId==fromJust mSubMenuId && not fromRadioMenu = do+						(_,_,it,items,keys) <- removeItems' framePtr mSubHandle pid 1 indices it mSubItems keys+						return (True,iNr+1,it,subH{mSubItems=items},keys)+					| otherwise = do+						(done,_,it,items,keys) <- removeIndexsFromMenu' framePtr fromRadioMenu pid itemId indices mSubHandle 1 it mSubItems keys+						return (done,iNr+1,it,subH{mSubItems=items},keys)+				removeIndexsFromMenu framePtr fromRadioMenu pid itemId indices menu iNr it radioH@(RadioMenuHandle {mRadioId=mRadioId,mRadioIndex=mRadioIndex,mRadioItems=mRadioItems}) keys+					| isNothing mRadioId || itemId/=fromJust mRadioId || not fromRadioMenu =+						return (False,iNr,it,radioH,keys)+					| otherwise =+						let+							iNrIndices = map (\index->index+iNr-1) indices+							items	   = confirmRadioMenuIndex mRadioIndex mRadioItems+						in do+							(_,_,it,items,keys) <- removeItems' framePtr menu pid iNr iNrIndices it items keys+							(index,items) <- checkNewRadioMenuIndex menu iNr items+							return (True,iNr,it,radioH{mRadioItems=items,mRadioIndex=index},keys)+				removeIndexsFromMenu framePtr fromRadioMenu pid itemId indices menu iNr it (MenuListLSHandle mListItems) keys = do+					(removed,iNr,it,mListItems,keys)	<- removeIndexsFromMenu' framePtr fromRadioMenu pid itemId indices menu iNr it mListItems keys+					return (removed,iNr,it,MenuListLSHandle mListItems,keys)+				removeIndexsFromMenu framePtr fromRadioMenu pid itemId indices menu iNr it (MenuExtendLSHandle exLS mExtendItems) keys = do+					(removed,iNr,it,mExtendItems,keys) <- removeIndexsFromMenu' framePtr fromRadioMenu pid itemId indices menu iNr it mExtendItems keys+					return (removed,iNr,it,MenuExtendLSHandle exLS mExtendItems,keys)+				removeIndexsFromMenu framePtr fromRadioMenu pid itemId indices menu iNr it (MenuChangeLSHandle chLS mChangeItems) keys = do+					(removed,iNr,it,mChangeItems,keys) <- removeIndexsFromMenu' framePtr fromRadioMenu pid itemId indices menu iNr it mChangeItems keys+					return (removed,iNr,it,MenuChangeLSHandle chLS mChangeItems,keys)+				removeIndexsFromMenu _ _ _ _ _ _ iNr it h sIds =+					return (False,iNr+1,it,h,sIds)+				+				removeItems' :: OSWindowPtr -> OSMenu -> SystemId -> Int -> [Int] -> IdTable -> [MenuElementHandle ls ps] -> [Char] -> IO (Int,[Int],IdTable,[MenuElementHandle ls ps],[Char])+				removeItems' framePtr menu pid iNr indices it [] keys = +					return (iNr,indices,it,[],keys)+				removeItems' framePtr menu pid iNr indices it (item:items) keys+					| null indices = return (iNr,indices,it,items,keys)+					| otherwise = do+							(removed,iNr,indices,it,item, keys) <- removeItems  framePtr menu pid iNr indices it item  keys+							(        iNr,indices,it,items,keys) <- removeItems' framePtr menu pid iNr indices it items keys+							return (iNr,indices,it, if removed then items else item:items, keys)+				+				removeItems :: OSWindowPtr -> OSMenu -> SystemId -> Int -> [Int] -> IdTable -> MenuElementHandle ls ps -> [Char] -> IO (Bool,Int,[Int],IdTable,MenuElementHandle ls ps,[Char])+				removeItems framePtr menu pid iNr indices it subH@(SubMenuHandle {mSubHandle=mSubHandle,mSubMenuId=mSubMenuId,mSubItems=mSubItems}) keys =+					let (containsItem,indices1) = removeCheck iNr indices+					in+						if not containsItem+						then return (False,iNr+1,indices1,it,subH,keys)+						else do+								let it1	= foldr (disposeMenuIds pid) it mSubItems+								keys1 <- foldrM (disposeSubMenuHandles framePtr) keys mSubItems+								osSubMenuRemove mSubHandle menu+								let indices2 = map dec indices1+								return (containsItem,iNr,indices2,it1,subH,keys1)+				removeItems framePtr menu pid iNr indices it itemH@(MenuItemHandle {mItemId=mItemId,mItemKey=mItemKey,mOSMenuItem=mOSMenuItem}) keys =+					let (containsItem,indices1) = removeCheck iNr indices+					in+						if not containsItem+						then return (False,iNr+1,indices1,it,itemH,keys)+						else do+								(keys1,it1) <- disposeMenuItemHandle menu iNr itemH (keys,it)+								let indices2 = map dec indices1+								return (containsItem,iNr,indices2,it1,itemH,keys1)						+				removeItems framePtr menu pid iNr indices it radioH@(RadioMenuHandle {mRadioId=mRadioId,mRadioItems=mRadioItems}) keys =+					let (containsItem,indices1) = removeCheck iNr indices+					in+						if not containsItem+						then let +									nrItems	= length mRadioItems									+									indices2 = map ((+) (nrItems-1)) indices1+							 in +									return (False,iNr+nrItems,indices2,it,radioH,keys)+						else do+								(keys1,it1) <- foldrM (disposeMenuItemHandle menu iNr) (keys,it) mRadioItems+								let radioH1	  = radioH{mRadioItems=[]}+								let indices2  = map dec indices1+								return (containsItem,iNr,indices2,it1,radioH1,keys1)					+				removeItems framePtr menu pid iNr indices it sepH@(MenuSeparatorHandle {mSepId=mSepId,mOSMenuSeparator=mOSMenuSeparator}) keys =+					let (containsItem,indices1) = removeCheck iNr indices+					in+						if not containsItem+						then return (False,iNr+1,indices1,it,sepH,keys)+						else do+								osMenuRemoveItem mOSMenuSeparator menu+								let it1 = Map.delete (fromJust mSepId) it+								let indices2 = map dec indices1+								return (containsItem,iNr,indices2,it1,sepH,keys)					+				removeItems framePtr menu pid iNr indices it recH@(MenuReceiverHandle (ReceiverHandle{rId=rId}) _) keys =+					let (containsItem,indices1) = removeCheck iNr indices+					in+						if not containsItem+						then return (False,iNr,indices,it,recH,keys)+						else return (containsItem,iNr,indices,Map.delete rId it,recH,keys)+				removeItems framePtr menu pid iNr indices it (MenuListLSHandle mListItems) keys = do+					(iNr,indices,it,mListItems,keys) <- removeItems' framePtr menu pid iNr indices it mListItems keys+					return (False,iNr,indices,it,MenuListLSHandle mListItems,keys)+				removeItems framePtr menu pid iNr indices it (MenuExtendLSHandle exLS mExtendItems) keys = do+					(iNr,indices,it,items,keys) <- removeItems' framePtr menu pid iNr indices it mExtendItems keys+					return (False,iNr,indices,it,MenuExtendLSHandle exLS items,keys)+				removeItems framePtr menu pid iNr indices it (MenuChangeLSHandle chLS mChangeItems) keys = do+					(iNr,indices,it,items,keys)	<- removeItems' framePtr menu pid iNr indices it mChangeItems keys+					return (False,iNr,indices,it,MenuChangeLSHandle chLS items,keys)+++{-	confirmRadioMenuIndex ensures that only the menu item at the index position in the list has a True mItemMark field (counted from 1). -}++confirmRadioMenuIndex :: Int -> [MenuElementHandle ls ps] -> [MenuElementHandle ls ps]+confirmRadioMenuIndex i (itemH@(MenuItemHandle {}):itemHs) =+	(itemH{mItemMark=i==1}:confirmRadioMenuIndex (i-1) itemHs)+confirmRadioMenuIndex _ [] = []++{-	checkNewRadioMenuIndex yields the Index of the first checked menu item in the list.+	If the list is empty, then 0 is returned and no menu item is checked.+	If there is no checked menu item then 1 is returned, and the first menu item (if+	present) in the list is checked.+-}+checkNewRadioMenuIndex :: OSMenu -> Int -> [MenuElementHandle ls ps] -> IO (Int,[MenuElementHandle ls ps])+checkNewRadioMenuIndex menu iNr [] 	= return (0,[])+checkNewRadioMenuIndex menu iNr itemHs@(_:_) =+    let (found,index) = getNewRadioMenuIndex 1 itemHs+    in if found then return (index,itemHs)+       else do+		itemHs <- checkFirstRadioItem menu iNr itemHs+		return (1,itemHs)+    where+	getNewRadioMenuIndex :: Int -> [MenuElementHandle ls ps] -> (Bool,Int)+	getNewRadioMenuIndex index (itemH@(MenuItemHandle {mItemMark=mItemMark}):itemHs)+		| mItemMark   = (mItemMark,index)+		| otherwise   = getNewRadioMenuIndex (index+1) itemHs				+	getNewRadioMenuIndex index [] = (False,index)+	+	checkFirstRadioItem :: OSMenu -> Int -> [MenuElementHandle ls ps] -> IO [MenuElementHandle ls ps]+	checkFirstRadioItem menu iNr (itemH@(MenuItemHandle {mOSMenuItem=mOSMenuItem}):itemHs) = do+		osMenuItemCheck True menu mOSMenuItem+		return (itemH{mItemMark=True}:itemHs)+	checkFirstRadioItem _ _ [] = return []
+ Graphics/UI/ObjectIO/OS/Bitmap.hs view
@@ -0,0 +1,72 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.Bitmap+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------+++module Graphics.UI.ObjectIO.OS.Bitmap where+++import	Graphics.UI.ObjectIO.OS.Picture+import	Graphics.UI.ObjectIO.OS.Types+import  Graphics.UI.ObjectIO.OS.Cutil_12+++data OSBitmap+   = OSBitmap+   	{ originalSize	:: !(Int,Int)		-- The size of the bitmap+	, reSize	:: !(Int,Int)		-- to store values passed to resizeBitmap+	, bitmapHandle	:: !OSBmpHandle		-- The handle to the screen bitmap (for screen)+	}++osReadBitmap :: FilePath -> IO (Maybe OSBitmap)+osReadBitmap name = do+	ptr <- newCString name+	pWidth <- malloc+	pHeight <- malloc+	hbmp <- winCreateBitmap ptr pWidth pHeight+	w <- fpeek pWidth+	h <- fpeek pHeight	+	free ptr+	(if hbmp == nullPtr then return Nothing+	 else return (Just (OSBitmap {originalSize=(w,h),reSize=(w,h),bitmapHandle=hbmp})))+foreign import ccall "cpicture_121.h WinCreateBitmap" winCreateBitmap :: CString -> Ptr Int -> Ptr Int -> IO OSBmpHandle++osDisposeBitmap :: OSBitmap -> IO ()+osDisposeBitmap (OSBitmap {bitmapHandle=handle}) = winDisposeBitmap handle+foreign import ccall "cpicture_121.h WinDisposeBitmap" winDisposeBitmap :: OSBmpHandle -> IO ()++-- osGetBitmapSize returns the size of the bitmap.+osGetBitmapSize :: OSBitmap -> (Int,Int)+osGetBitmapSize = reSize++{-	osResizeBitmap (w,h) bitmap+		resizes the argument bitmap to the given size.+	It is assumed that w and h are not negative.+-}+osResizeBitmap :: (Int,Int) -> OSBitmap -> OSBitmap+osResizeBitmap size bitmap = bitmap{reSize=size}++{-	osDrawBitmap bitmap pos origin pictContext+		draws the argument bitmap with the left top corner at pos, given the current origin and drawing context.+-}+osDrawBitmap :: OSBitmap -> (Int,Int) -> (Int,Int) -> Draw ()+osDrawBitmap (OSBitmap {originalSize=originalSize,reSize=reSize,bitmapHandle=bitmapHandle}) pos@(px,py) origin@(ox,oy) =+	Draw (\picture@(Picture {pictToScreen=isScreenOutput,pictContext=context}) ->+		(if originalSize==reSize then+		      winDrawBitmap  (fst originalSize) (snd originalSize) (px-ox) (py-oy) bitmapHandle context+		 else+		      winDrawResizedBitmap  (fst originalSize) (snd originalSize) (px-ox) (py-oy) (fst reSize) (snd reSize) bitmapHandle context) >>+		return ((), picture))+	where+		destination	= (px-ox,py-oy)+foreign import ccall "cpicture_121.h WinDrawBitmap" winDrawBitmap :: Int -> Int -> Int -> Int -> OSBmpHandle -> OSPictContext -> IO ()+foreign import ccall "cpicture_121.h WinDrawResizedBitmap" winDrawResizedBitmap :: Int -> Int -> Int -> Int -> Int -> Int -> OSBmpHandle -> OSPictContext -> IO ()
+ Graphics/UI/ObjectIO/OS/ClCCall_12.hs view
@@ -0,0 +1,206 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.ClCCall_12+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- ClCCall_12 collects all the C call routines related to windows.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.ClCCall_12+		( ACCLPTR+		, winHelpKey, winEscapeKey, winReturnKey, winTabKey, winDelKey, winBackSpKey+		, winEndKey, winBeginKey, winPgDownKey, winPgUpKey, winRightKey, winLeftKey, winDownKey, winUpKey+		, winF1Key, winF2Key, winF3Key, winF4Key, winF5Key, winF6Key+		, winF7Key, winF8Key, winF9Key, winF10Key, winF11Key, winF12Key+		, ctrlBIT, altBIT, shiftBIT+		, keyREPEAT, keyUP, keyDOWN+		, buttonUP, buttonSTILLDOWN, buttonTRIPLEDOWN, buttonDOUBLEDOWN, buttonDOWN, buttonSTILLUP                  +		, winBeep+		, winMaxFixedWindowSize, winMaxScrollWindowSize+		, winScreenYSize, winScreenXSize+		, winMinimumWinSize+		, winScrollbarSize+		, winMDIClientToOuterSizeDims, winSDIClientToOuterSizeDims+		, winPlaySound+		) where+++import Graphics.UI.ObjectIO.OS.Cutil_12+import System.IO.Unsafe+++type	ACCLPTR		= Int++winHelpKey, winEscapeKey, winReturnKey, winTabKey, winDelKey, winBackSpKey, winEndKey, winBeginKey+	  , winPgDownKey, winPgUpKey, winRightKey, winLeftKey, winDownKey, winUpKey+	  , winF1Key, winF2Key, winF3Key, winF4Key, winF5Key, winF6Key, winF7Key+	  , winF8Key, winF9Key, winF10Key, winF11Key, winF12Key :: Int++winEscapeKey		= 27+winReturnKey		= 13+winTabKey		= 9+winBackSpKey		= 8+winF1Key		= 1001+winF2Key		= 1002+winF3Key		= 1003+winF4Key		= 1004+winF5Key		= 1005+winF6Key		= 1006+winF7Key		= 1007+winF8Key		= 1008+winF9Key		= 1009+winF10Key		= 1010+winF11Key		= 1011+winF12Key		= 1012+winHelpKey		= 1013+winDelKey		= 1014+winEndKey		= 1015+winBeginKey		= 1016+winPgDownKey		= 1017+winPgUpKey		= 1018+winRightKey		= 1019+winLeftKey		= 1020+winDownKey		= 1021+winUpKey		= 1022++ctrlBIT, altBIT, shiftBIT :: Int+ctrlBIT			= 4+altBIT			= 2+shiftBIT		= 1++keyREPEAT, keyUP, keyDOWN :: Int+keyREPEAT		= 4+keyUP			= 2+keyDOWN			= 1++buttonUP, buttonSTILLDOWN, buttonTRIPLEDOWN, buttonDOUBLEDOWN, buttonDOWN, buttonSTILLUP :: Int+buttonUP		= 50+buttonSTILLDOWN		= 40+buttonTRIPLEDOWN	= 3+buttonDOUBLEDOWN	= 2+buttonDOWN		= 1+buttonSTILLUP		= 0		{- constant for passing mouse move events. -}++foreign import ccall "cCCallSystem_121.h WinBeep" winBeep :: IO ()++winMaxFixedWindowSize :: (Int,Int)+winMaxFixedWindowSize+	= unsafePerformIO winMaxFixedWindowSize'+	where+		winMaxFixedWindowSize' :: IO (Int,Int)+		winMaxFixedWindowSize'+			= do {+				-- Marshal arguments:+				o1 <- malloc;+				o2 <- malloc;+				-- Call C:+				cWinMaxFixedWindowSize o1 o2;+				-- Read/free:+				r1 <- fpeek o1;+				r2 <- fpeek o2;+				return (r1,r2)+			  }+foreign import ccall "cCCallWindows_121.h WinMaxFixedWindowSize" cWinMaxFixedWindowSize :: Ptr Int -> Ptr Int -> IO ()++winMaxScrollWindowSize :: (Int,Int)+winMaxScrollWindowSize+	= unsafePerformIO winMaxScrollWindowSize'+	where+		winMaxScrollWindowSize' :: IO (Int,Int)+		winMaxScrollWindowSize'+			= do {+				-- Marshal arguments:+				o1 <- malloc;+				o2 <- malloc;+				-- Call C:+				cWinMaxScrollWindowSize o1 o2;+				-- Read/free:+				r1 <- fpeek o1;+				r2 <- fpeek o2;+				return (r1,r2)+			  }+foreign import ccall "cCCallWindows_121.h WinMaxScrollWindowSize" cWinMaxScrollWindowSize :: Ptr Int -> Ptr Int -> IO ()++foreign import ccall "cCCallWindows_121.h WinScreenYSize" winScreenYSize :: IO Int++foreign import ccall "cCCallWindows_121.h WinScreenXSize" winScreenXSize :: IO Int++winMinimumWinSize :: (Int,Int)+winMinimumWinSize+	= unsafePerformIO winMinimumWinSize'+	where+		winMinimumWinSize' :: IO (Int,Int)+		winMinimumWinSize'+			= do {+				-- Marshal arguments:+				o1 <- malloc;+				o2 <- malloc;+				-- Call C:+				cWinMinimumWinSize o1 o2;+				-- Read/free:+				r1 <- fpeek o1;+				r2 <- fpeek o2;+				return (r1, r2)+			  }+foreign import ccall "cCCallWindows_121.h WinMinimumWinSize" cWinMinimumWinSize :: Ptr Int -> Ptr Int -> IO ()++winScrollbarSize :: IO (Int,Int)+winScrollbarSize+	= do {+		-- Marshal arguments:+		o1 <- malloc;+		o2 <- malloc;+		-- Call C:+		cWinScrollbarSize o1 o2;+		-- Read/free:+		r1 <- fpeek o1;+		r2 <- fpeek o2;+		return (r1, r2)+	  }+foreign import ccall "cCCallWindows_121.h WinScrollbarSize" cWinScrollbarSize :: Ptr Int -> Ptr Int -> IO ()++{-	The routines (win(M/S)DIClientToOuterSizeDims convert between the+		client and outer size of (M/S)DI windows. The Int argument contains the style flags +		of the window.+-}+winMDIClientToOuterSizeDims :: Int -> IO (Int,Int)+winMDIClientToOuterSizeDims a1+	= do {+		-- Marshal arguments:+		o1 <- malloc;+		o2 <- malloc;+		-- Call C:+		cWinMDIClientToOuterSizeDims a1 o1 o2;+		-- Read/free:+		r1 <- fpeek o1;+		r2 <- fpeek o2;+		return (r1, r2)+	  }+foreign import ccall "cCCallWindows_121.h WinMDIClientToOuterSizeDims" cWinMDIClientToOuterSizeDims :: Int -> Ptr Int -> Ptr Int -> IO ()++winSDIClientToOuterSizeDims :: Int -> IO (Int,Int)+winSDIClientToOuterSizeDims a1+	= do {+		-- Marshal arguments:+		o1 <- malloc;+		o2 <- malloc;+		-- Call C:+		cWinSDIClientToOuterSizeDims a1 o1 o2;+		-- Read/free:+		r1 <- fpeek o1;+		r2 <- fpeek o2;+		return (r1, r2)+	  }+foreign import ccall "cCCallWindows_121.h WinSDIClientToOuterSizeDims" cWinSDIClientToOuterSizeDims :: Int -> Ptr Int -> Ptr Int -> IO ()++winPlaySound :: String -> IO Bool+winPlaySound a1 = withCString a1 cWinPlaySound++foreign import ccall "cCCallSystem_121.h WinPlaySound" cWinPlaySound :: CString -> IO Bool
+ Graphics/UI/ObjectIO/OS/ClCrossCall_12.hs view
@@ -0,0 +1,589 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.ClCrossCall_12+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- ClCrossCall_12 contains the operations to communicate between+-- Haskell and OS thread.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.ClCrossCall_12 ( module Graphics.UI.ObjectIO.OS.ClCrossCall_12 ) where++++import Graphics.UI.ObjectIO.OS.Types+import Graphics.UI.ObjectIO.OS.Cutil_12+import System.IO.Unsafe+import Data.IORef+++--	********************************************************************************+--	Crosscall infrastructure+--	********************************************************************************++--	CrossCallInfo is the basic record that is passed between the Clean thread and the OS thread:+data	CrossCallInfo+	= CrossCallInfo+		{ ccMsg :: !Int		-- The message nr: Clean->OS use ccRq...; OS->Clean use ccWm...+		, p1    :: !Int+		, p2    :: !Int+		, p3    :: !Int+		, p4    :: !Int+		, p5    :: !Int+		, p6    :: !Int+		}+++--	2 versions of IssueCleanRequest: first with state parameter, second without.++issueCleanRequest :: (CrossCallInfo -> s -> IO (CrossCallInfo,s))+                   -> CrossCallInfo -> s -> IO (CrossCallInfo,s)+issueCleanRequest callback cci s+	= do {+		reply <- winKickOsThread cci;+		handleCallBacks callback reply s+	  }+	where+		handleCallBacks :: (CrossCallInfo -> s -> IO (CrossCallInfo,s))+		                 -> CrossCallInfo -> s -> IO (CrossCallInfo,s)+		handleCallBacks callback cci s+			| ccMsg cci>2000+				= error ("handleCallBacks " ++ show (ccMsg cci))+			| isReturnOrQuitCci (ccMsg cci)+				= return (cci,s)+			| otherwise+				= do {+					(returnCci,s1) <- callback cci s;+					replyCci       <- winKickOsThread returnCci;+					handleCallBacks callback replyCci s1+				  }++issueCleanRequest2 :: (CrossCallInfo -> IO CrossCallInfo)+                    -> CrossCallInfo -> IO CrossCallInfo+issueCleanRequest2 callback cci+	= do {+		reply <- winKickOsThread cci;+		handleCallBacks callback reply;+	  }+	where+		handleCallBacks :: (CrossCallInfo -> IO CrossCallInfo)+		                 -> CrossCallInfo -> IO CrossCallInfo+		handleCallBacks callback cci+			| ccMsg cci>2000+				= error ("handleCallBacks " ++ show (ccMsg cci))+			| isReturnOrQuitCci (ccMsg cci)+				= return cci+			| otherwise+				= do {+					returnCci <- callback cci;+					replyCci  <- winKickOsThread returnCci;+					handleCallBacks callback replyCci;+				  }++--	Functions for returning proper number of arguments within a CrossCallInfo.+rq0Cci msg = CrossCallInfo {ccMsg=msg,p1=0,p2=0,p3=0,p4=0,p5=0,p6=0}+rq1Cci msg v1 = CrossCallInfo {ccMsg=msg,p1=v1,p2=0,p3=0,p4=0,p5=0,p6=0}+rq2Cci msg v1 v2 = CrossCallInfo {ccMsg=msg,p1=v1,p2=v2,p3=0,p4=0,p5=0,p6=0}+rq3Cci msg v1 v2 v3 = CrossCallInfo {ccMsg=msg,p1=v1,p2=v2,p3=v3,p4=0,p5=0,p6=0}+rq4Cci msg v1 v2 v3 v4 = CrossCallInfo {ccMsg=msg,p1=v1,p2=v2,p3=v3,p4=v4,p5=0,p6=0}+rq5Cci msg v1 v2 v3 v4 v5 = CrossCallInfo {ccMsg=msg,p1=v1,p2=v2,p3=v3,p4=v4,p5=v5,p6=0}+rq6Cci msg v1 v2 v3 v4 v5 v6 = CrossCallInfo {ccMsg=msg,p1=v1,p2=v2,p3=v3,p4=v4,p5=v5,p6=v6}++return0Cci :: CrossCallInfo+return0Cci = rq0Cci ccRETURN0++return1Cci :: Int -> CrossCallInfo+return1Cci v = rq1Cci ccRETURN1 v++return2Cci :: Int -> Int -> CrossCallInfo+return2Cci v1 v2 = rq2Cci ccRETURN2 v1 v2++return3Cci :: Int -> Int -> Int -> CrossCallInfo+return3Cci v1 v2 v3 = rq3Cci ccRETURN3 v1 v2 v3++return4Cci :: Int -> Int -> Int -> Int -> CrossCallInfo+return4Cci v1 v2 v3 v4 = rq4Cci ccRETURN4 v1 v2 v3 v4++return5Cci :: Int -> Int -> Int -> Int -> Int -> CrossCallInfo+return5Cci v1 v2 v3 v4 v5 = rq5Cci ccRETURN5 v1 v2 v3 v4 v5++return6Cci :: Int -> Int -> Int -> Int -> Int -> Int -> CrossCallInfo+return6Cci v1 v2 v3 v4 v5 v6 = rq6Cci ccRETURN6 v1 v2 v3 v4 v5 v6++isReturnOrQuitCci :: Int -> Bool+isReturnOrQuitCci mess+	= mess==ccWASQUIT || (mess<=ccRETURNmax && mess>=ccRETURNmin)+++{-	Two error callback routines that do not nothing. They can be used+	conveniently as argument of issueCleanRequest(2).+-}+errorCallback :: String -> CrossCallInfo -> s -> IO (CrossCallInfo,s)+errorCallback source cci s = return (return0Cci,s)++errorCallback2 :: String -> CrossCallInfo -> IO CrossCallInfo+errorCallback2 source cci = return return0Cci+++--	********************************************************************************+--	Synchronisation operations between the Clean thread and OS thread.+--	********************************************************************************++{-# NOINLINE gEventsInited #-}+gEventsInited = unsafePerformIO (newIORef False) :: IORef Bool++osInitToolbox :: IO Bool+osInitToolbox = do+	eventsInited <- readIORef gEventsInited+	if not eventsInited+	  then do+		winStartOsThread+		osInstallFont+		osInitialiseFileSelectors+		osInstallMenus+		osInstallClipboard+		osInstallPrinter+		osInstallWindows+		osInstallDI+		writeIORef gEventsInited True+		return True+	  else return False+	  +osCloseToolbox = do+	eventsInited <- readIORef gEventsInited+	if eventsInited+	  then do+	  	winKillOsThread+		writeIORef gEventsInited False+		return True+	  else return False++foreign import ccall "cCrossCallFont_121.h InstallCrossCallFont" 		osInstallFont :: IO ()+foreign import ccall "cCrossCallFileSelectors_121.h InstallCrossCallFileSelectors" 	osInitialiseFileSelectors :: IO ()+foreign import ccall "cCrossCallMenus_121.h InstallCrossCallMenus" 		osInstallMenus :: IO ()+foreign import ccall "cCrossCallClipboard_121.h InstallCrossCallClipboard" 	osInstallClipboard :: IO ()+foreign import ccall "cCrossCallPrinter_121.h InstallCrossCallPrinter" 	osInstallPrinter :: IO ()+foreign import ccall "cCrossCallWindows_121.h InstallCrossCallWindows" 	osInstallWindows :: IO ()+foreign import ccall "cCrossCallxDI_121.h InstallCrossCallxDI" 		osInstallDI :: IO ()++winKickOsThread :: CrossCallInfo -> IO CrossCallInfo+winKickOsThread cci@(CrossCallInfo {ccMsg=ccMsg,p1=p1,p2=p2,p3=p3,p4=p4,p5=p5,p6=p6})+	= do {+		-- Marshal out parameters:+		omess <- malloc;+		op1 <- malloc;+		op2 <- malloc;+		op3 <- malloc;+		op4 <- malloc;+		op5 <- malloc;+		op6 <- malloc;+		-- Call C routine:+		cWinKickOsThread ccMsg p1 p2 p3 p4 p5 p6 omess op1 op2 op3 op4 op5 op6;+		-- Read/free:+		omess' <- fpeek omess;+		op1' <- fpeek op1;+		op2' <- fpeek op2;+		op3' <- fpeek op3;+		op4' <- fpeek op4;+		op5' <- fpeek op5;+		op6' <- fpeek op6;+		return (CrossCallInfo omess' op1' op2' op3' op4' op5' op6')+	  }+foreign import ccall "WinKickOsThread" cWinKickOsThread :: Int -> Int -> Int -> Int -> Int -> Int -> Int+                                   -> Ptr Int -> Ptr Int -> Ptr Int -> Ptr Int -> Ptr Int -> Ptr Int -> Ptr Int -> IO ()++foreign import ccall "WinKillOsThread" winKillOsThread :: IO ()+foreign import ccall "WinStartOsThread" winStartOsThread :: IO ()+++--	********************************************************************************+--	The message numbers for communication from Clean/Haskell to OS (ccMsg field)+--	********************************************************************************++{- Game cross call codes -}+ccRqUSERGAMEEVENT		= 1905+ccRqCREATEGAMEOBJECT		= 1904+ccRqPLAYSOUNDSAMPLE		= 1903++ccRqRUNGAME			= 1901+ccRqCREATEGAMEWINDOW		= 1900++{- Print cross call codes -}+ccRqDO_PRINT_SETUP		= 1828+ccRqDO_HTML_HELP		= 1827++ccRqGET_PRINTER_DC		= 1824+ccRqDISPATCH_MESSAGES_WHILE_PRINTING+				= 1823+ccRqENDDOC			= 1822+ccRqSTARTDOC			= 1821++{- TCP cross call codes -}+ccRqCREATETCPWINDOW		= 1820		{- Create TCP window -}++{- GUI cross call codes -}+ccRqDESTROYMDIDOCWINDOW 	= 1817		{- Destroy MDI document window -}+ccRqCREATESDIDOCWINDOW		= 1816		{- Create SDI document window  -}+ccRqCREATEMDIDOCWINDOW		= 1815		{- Create MDI document window  -}+ccRqCREATEMDIFRAMEWINDOW	= 1814		{- Create MDI frame window     -}+ccRqCREATESDIFRAMEWINDOW	= 1813		{- Create SDI frame window     -}+ccRqCLIPBOARDHASTEXT		= 1812+ccRqGETCLIPBOARDTEXT		= 1811+ccRqSETCLIPBOARDTEXT		= 1810++ccRqDIRECTORYDIALOG		= 1802		{- Create directory selector dialog. -}+ccRqFILESAVEDIALOG		= 1801+ccRqFILEOPENDIALOG		= 1800++ccRqUPDATEDESKTOP		= 1790		{- Force refresh of desktop. -}++ccRqSHOWCONTROL			= 1755+ccRqSELECTPOPUPITEM		= 1754+ccRqADDTOPOPUP			= 1752+ccRqSETITEMCHECK		= 1751+ccRqENABLECONTROL		= 1750++ccRqCREATECOMPOUND		= 1729+ccRqCREATESCROLLBAR		= 1728+ccRqCREATECUSTOM		= 1727+ccRqCREATEICONBUT		= 1726+ccRqCREATEPOPUP			= 1725+ccRqCREATECHECKBOX		= 1724+ccRqCREATERADIOBUT		= 1723+ccRqCREATEEDITTXT		= 1722+ccRqCREATESTATICTXT		= 1721+ccRqCREATEBUTTON		= 1720++ccRqCREATEMODALDIALOG		= 1701		{- Create modal dialog. -}+ccRqCREATEDIALOG		= 1700++ccRqCREATETOOLBARSEPARATOR	= 1603		{- Create a toolbar separator item.    -}+ccRqCREATETOOLBARITEM		= 1602		{- Create a toolbar bitmap item.       -}+ccRqCREATEMDITOOLBAR		= 1601		{- Create a toolbar for a MDI process. -}+ccRqCREATESDITOOLBAR		= 1600		{- Create a toolbar.                   -}++ccCbFONTSIZE			= 1530++ccCbFONTNAME			= 1520++ccRqGETFONTSIZES		= 1510++ccRqGETFONTNAMES		= 1500++ccRqSETCLIENTSIZE		= 1438		{- Set client size.                    -}+ccRqDELCONTROLTIP		= 1437		{- Remove controls from tooltip areas. -}+ccRqADDCONTROLTIP		= 1436		{- Add controls to tooltip areas.      -}+ccRqGETWINDOWSIZE		= 1435		{- Retrieve bounding size of windows.  -}+ccRqRESTACKWINDOW		= 1434		{- Restack windows.                    -}+ccRqSHOWWINDOW			= 1433		{- (hide/show) windows.                -}+ccRqSETWINDOWSIZE		= 1432		{- Resize windows/controls.            -}+ccRqSETSELECTWINDOW		= 1431		{- (en/dis)able windows.               -}+ccRqSETWINDOWPOS		= 1430		{- Move windows/controls.              -}++ccRqSETEDITSELECTION		= 1428		{- Handling edit control selections. -}+ccRqSETSCROLLSIZE		= 1427		{- Setting thumb size of scrollbar.  -}+ccRqSETSCROLLPOS		= 1426		{- Setting thumb of scrollbar.       -}+ccRqSETSCROLLRANGE		= 1425		{- Setting range of scrollbar.       -}+ccRqOBSCURECURSOR		= 1422+ccRqCHANGEWINDOWCURSOR		= 1421+ccRqACTIVATEWINDOW		= 1420		{- Activating window.   -}+ccRqACTIVATECONTROL		= 1419		{- Activating controls. -}++ccRqCREATECARET			= 1610+ccRqSETCARETPOS			= 1611+ccRqDESTROYCARET		= 1612++ccRqGETWINDOWPOS		= 1416+ccRqGETCLIENTSIZE		= 1415++ccRqUPDATEWINDOWRECT		= 1412		{- Updating rect part of a window/control. -}+ccRqGETWINDOWTEXT		= 1411+ccRqSETWINDOWTITLE		= 1410++ccRqFAKEPAINT			= 1405		{- Combination of BeginPaint; EndPaint; InvalidateRect; -}+ccRqENDPAINT			= 1404+ccRqBEGINPAINT			= 1403+ccRqDESTROYWINDOW		= 1402+ccRqDESTROYMODALDIALOG		= 1401		{- Destroy modal dialog. -}++ccRqDRAWMBAR			= 1265++ccRqTRACKPOPMENU		= 1256		{- Handling pop up menu. -}+ccRqCREATEPOPMENU		= 1255++ccRqINSERTSEPARATOR		= 1245++ccRqMENUENABLE			= 1235++ccRqMODIFYMENU			= 1230++ccRqINSERTMENU			= 1226		{- Inserting a new menu into the menu bar -}++ccRqITEMENABLE			= 1220++ccRqREMOVEMENUSHORTKEY		= 1217		{- Removing a shortkey of a menu item -}+ccRqMODIFYMENUITEM		= 1215+ccRqDELETEMENU			= 1213		{- Deleting a menu logically      -}+ccRqREMOVEMENUITEM		= 1212++ccRqCHECKMENUITEM		= 1210++ccRqINSERTMENUITEM		= 1205++ccRqCREATELISTBOX 		= 1206+ccRqADDTOLISTBOX 		= 1207+ccRqSELECTLISTBOXITEM		= 1208+ccRqMARKLISTBOXITEM		= 1209++ccRqDOMESSAGE			= 1100++----------------------------------------------------------------------------+--  The message numbers for communication from OS to Clean (ccMsg field)  --+----------------------------------------------------------------------------+ccWINMESSmax			= 999++{- Game cross calls: 500-599 -}+ccWmCHECKQUIT			= 513		{- Mike: check user's quit function   -}+ccWmUSEREVENT			= 512		{- Mike: user defined event           -}+ccWmSTATISTICS			= 511		{- Mike: request for statistics       -}+ccWmOBJECTKEYUP			= 510		{- Mike: key released                 -}+ccWmOBJECTKEYDOWN		= 509		{- Mike: key pressed for object       -}+ccWmOBJECTTIMER			= 508		{- Mike: framecounter reached 0       -}+ccWmANIMATION			= 507		{- Mike: animation sequence ended     -}+ccWmCOLLISION			= 506		{- Mike: collision of two objects     -}+ccWmTOUCHBOUND			= 505		{- Mike: object touches bound or code -}+ccWmOBJECTDONE			= 504		{- Mike: object is destroyed          -}+ccWmMOVEOBJECT			= 503		{- Mike: move object                  -}+ccWmINITOBJECT			= 502		{- Mike: initialize new object        -}+ccWmSCROLL			= 501		{- Mike: calculate layer position     -}+ccWmGAMEKEYBOARD		= 500		{- Mike: keyboard input for game      -}++{- TCP cross calls -}+ccWmINETEVENT			= 140++{- GUI cross calls -}+ccWmZEROTIMER			= 136		{- Sequence of zero timer events (generated only by Clean). -}+ccWmLOSTKEY			= 135		{- Loosing keyboard input (generated only by Clean). -}+ccWmLOSTMOUSE			= 134		{- Loosing mouse input    (generated only by Clean). -}+ccWmSPECIALBUTTON		= 133		{- Info about OK/CANCEL button selected. -}+ccWmPROCESSDROPFILES		= 132		{- Requesting opening of files. -}+ccWmGETTOOLBARTIPTEXT		= 131		{- Getting tooltip text. -}+ccWmSETFOCUS			= 130		{- Notifying obtaining keyboard input focus. -}+ccWmKILLFOCUS			= 129		{- Notifying loss of keyboard input focus. -}++ccWmPROCESSCLOSE		= 127		{- Requesting closing of process. -}+ccWmDRAWCLIPBOARD		= 126		{- Clipboard handling. Copied from Ronny. -}+ccWmGETSCROLLBARINFO		= 125		{- Info about scrollbars. -}+ccWmSCROLLBARACTION		= 124		{- Scrollbar handling. -}+ccWmDDEEXECUTE			= 123++ccWmIDLEDIALOG			= 121		{- Initialising modal dialogues. -}+ccWmDRAWCONTROL			= 120+ccWmITEMSELECT			= 119+ccWmBUTTONCLICKED		= 118+ccWmINITDIALOG			= 117+ccWmIDLETIMER			= 116+ccWmTIMER			= 115+ccWmNEWVTHUMB			= 114+ccWmNEWHTHUMB			= 113+ccWmGETVSCROLLVAL		= 112+ccWmGETHSCROLLVAL		= 111+ccWmSIZE			= 110		{- Passing resize information. -}+ccWmMOUSE			= 109+ccWmKEYBOARD			= 108+ccWmDEACTIVATE			= 107+ccWmACTIVATE			= 106+ccWmCLOSE			= 105+ccWmCOMMAND			= 103+ccWmCHAR			= 102+ccWmCREATE			= 101+ccWmPAINT			= 100++ccWINMESSmin			= 100++ccWmNOTIFY			= 78++ccRETURNmax			= 19++ccRETURN6			= 16+ccRETURN5			= 15+ccRETURN4			= 14+ccRETURN3			= 13+ccRETURN2			= 12+ccRETURN1			= 11+ccRETURN0			= 10++ccRETURNmin			= 10++ccWASQUIT			= 1++{-	All of the above ccXXX values are supposed to be Int.+-}+ccRqUSERGAMEEVENT,+	ccRqCREATEGAMEOBJECT,+	ccRqPLAYSOUNDSAMPLE,+	ccRqRUNGAME,+	ccRqCREATEGAMEWINDOW,+	ccRqDO_PRINT_SETUP,+	ccRqDO_HTML_HELP,+	ccRqGET_PRINTER_DC,+	ccRqDISPATCH_MESSAGES_WHILE_PRINTING,+	ccRqENDDOC,+	ccRqSTARTDOC,+	ccRqCREATETCPWINDOW,+	ccRqDESTROYMDIDOCWINDOW,+	ccRqCREATESDIDOCWINDOW,+	ccRqCREATEMDIDOCWINDOW,+	ccRqCREATEMDIFRAMEWINDOW,+	ccRqCREATESDIFRAMEWINDOW,+	ccRqCLIPBOARDHASTEXT,+	ccRqGETCLIPBOARDTEXT,+	ccRqSETCLIPBOARDTEXT,+	ccRqDIRECTORYDIALOG,+	ccRqFILESAVEDIALOG,+	ccRqFILEOPENDIALOG,+	ccRqUPDATEDESKTOP,+	ccRqSHOWCONTROL,+	ccRqSELECTPOPUPITEM,+	ccRqADDTOPOPUP,+	ccRqSETITEMCHECK,+	ccRqENABLECONTROL,+	ccRqCREATECOMPOUND,+	ccRqCREATESCROLLBAR,+	ccRqCREATECUSTOM,+	ccRqCREATEICONBUT,+	ccRqCREATEPOPUP,+	ccRqCREATECHECKBOX,+	ccRqCREATERADIOBUT,+	ccRqCREATEEDITTXT,+	ccRqCREATESTATICTXT,+	ccRqCREATEBUTTON,+	ccRqCREATEMODALDIALOG,+	ccRqCREATEDIALOG,+	ccRqCREATETOOLBARSEPARATOR,+	ccRqCREATETOOLBARITEM,+	ccRqCREATEMDITOOLBAR,+	ccRqCREATESDITOOLBAR,+	ccCbFONTSIZE,+	ccCbFONTNAME,+	ccRqGETFONTSIZES,+	ccRqGETFONTNAMES,+	ccRqSETCLIENTSIZE,+	ccRqDELCONTROLTIP,+	ccRqADDCONTROLTIP,+	ccRqGETWINDOWSIZE,+	ccRqRESTACKWINDOW,+	ccRqSHOWWINDOW,+	ccRqSETWINDOWSIZE,+	ccRqSETSELECTWINDOW,+	ccRqSETWINDOWPOS,+	ccRqSETEDITSELECTION,+	ccRqSETSCROLLSIZE,+	ccRqSETSCROLLPOS,+	ccRqSETSCROLLRANGE,+	ccRqOBSCURECURSOR,+	ccRqCHANGEWINDOWCURSOR,+	ccRqACTIVATEWINDOW,+	ccRqACTIVATECONTROL,+	ccRqCREATECARET,+	ccRqSETCARETPOS,+	ccRqDESTROYCARET,+	ccRqGETWINDOWPOS,+	ccRqGETCLIENTSIZE,+	ccRqUPDATEWINDOWRECT,+	ccRqGETWINDOWTEXT,+	ccRqSETWINDOWTITLE,+	ccRqFAKEPAINT,+	ccRqENDPAINT,+	ccRqBEGINPAINT,+	ccRqDESTROYWINDOW,+	ccRqDESTROYMODALDIALOG,+	ccRqDRAWMBAR,+	ccRqTRACKPOPMENU,+	ccRqCREATEPOPMENU,+	ccRqINSERTSEPARATOR,+	ccRqMENUENABLE,+	ccRqMODIFYMENU,	+	ccRqINSERTMENU,+	ccRqITEMENABLE,+	ccRqREMOVEMENUSHORTKEY,+	ccRqMODIFYMENUITEM,+	ccRqDELETEMENU,+	ccRqREMOVEMENUITEM,+	ccRqCHECKMENUITEM,+	ccRqINSERTMENUITEM,+	ccRqCREATELISTBOX,+	ccRqADDTOLISTBOX,+	ccRqSELECTLISTBOXITEM,+	ccRqMARKLISTBOXITEM,+	ccRqDOMESSAGE,+	ccWINMESSmax,+	ccWmCHECKQUIT,+	ccWmUSEREVENT,+	ccWmSTATISTICS,+	ccWmOBJECTKEYUP,+	ccWmOBJECTKEYDOWN,+	ccWmOBJECTTIMER,+	ccWmANIMATION,+	ccWmCOLLISION,+	ccWmTOUCHBOUND,+	ccWmOBJECTDONE,+	ccWmMOVEOBJECT,+	ccWmINITOBJECT,+	ccWmSCROLL,+	ccWmGAMEKEYBOARD,+	ccWmINETEVENT,+	ccWmZEROTIMER,+	ccWmLOSTKEY,+	ccWmLOSTMOUSE,+	ccWmSPECIALBUTTON,+	ccWmPROCESSDROPFILES,+	ccWmGETTOOLBARTIPTEXT,+	ccWmSETFOCUS,+	ccWmKILLFOCUS,+	ccWmPROCESSCLOSE,+	ccWmDRAWCLIPBOARD,+	ccWmGETSCROLLBARINFO,+	ccWmSCROLLBARACTION,+	ccWmDDEEXECUTE,+	ccWmIDLEDIALOG,+	ccWmDRAWCONTROL,+	ccWmITEMSELECT,+	ccWmBUTTONCLICKED,+	ccWmINITDIALOG,+	ccWmIDLETIMER,+	ccWmTIMER,+	ccWmNEWVTHUMB,+	ccWmNEWHTHUMB,+	ccWmGETVSCROLLVAL,+	ccWmGETHSCROLLVAL,+	ccWmSIZE,+	ccWmMOUSE,+	ccWmKEYBOARD,+	ccWmDEACTIVATE,+	ccWmACTIVATE,+	ccWmCLOSE,+	ccWmCOMMAND,+	ccWmCHAR,+	ccWmCREATE,+	ccWmPAINT,+	ccWINMESSmin,+	ccWmNOTIFY,+	ccRETURNmax,+	ccRETURN6,+	ccRETURN5,+	ccRETURN4,+	ccRETURN3,+	ccRETURN2,+	ccRETURN1,+	ccRETURN0,+	ccRETURNmin,+	ccWASQUIT+	:: Int
+ Graphics/UI/ObjectIO/OS/Clipboard.hs view
@@ -0,0 +1,60 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.Clipboard+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- ClCrossCall_12 contains the operations to communicate between+-- Clipboard operations.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.Clipboard where+++import	Graphics.UI.ObjectIO.OS.ClCrossCall_12+import	Graphics.UI.ObjectIO.OS.ClCCall_12+import	Graphics.UI.ObjectIO.OS.Cutil_12(int2addr, addr2int)+import  Foreign.Marshal.Utils+import  Foreign.Marshal.Alloc(free)+import  Foreign.C.String++type OSClipboardItemType = Int++osClipboardText = 1++osHasClipboardText :: IO Bool+osHasClipboardText = do+	rcci <- issueCleanRequest2 (errorCallback2 "osHasClipboardText") (rq0Cci ccRqCLIPBOARDHASTEXT)+	let ok =+		if      ccMsg rcci == ccRETURN1 then toBool (p1 rcci)+	  	else if ccMsg rcci == ccWASQUIT	then False+	  	else 				error "[winHasClipboardText] expected ccRETURN1 value."+	return ok++osSetClipboardText :: String -> IO ()+osSetClipboardText text = do+	textptr <- newCString text+	issueCleanRequest2 (errorCallback2 "osSetClipboardText") (rq1Cci ccRqSETCLIPBOARDTEXT (addr2int textptr))+	free textptr++osGetClipboardText :: IO String+osGetClipboardText = do+	rcci <- issueCleanRequest2 (errorCallback2 "osGetClipboardText") (rq0Cci ccRqGETCLIPBOARDTEXT)	+	(if ccMsg rcci == ccRETURN1 then do+		let ptr = (int2addr (p1 rcci))+		s <- peekCString ptr+		free ptr+		return s+	 else if ccMsg rcci == ccWASQUIT	then return ""+	 else error "[winGetClipboardText] expected ccRETURN1 value.\n")++osGetClipboardContent :: IO [OSClipboardItemType]+osGetClipboardContent = do+	hasText <- osHasClipboardText+	return (if hasText then [osClipboardText] else [])
+ Graphics/UI/ObjectIO/OS/Cutil_12.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_GHC -cpp #-}++-- #hide+-----------------------------------------------------------------------------+-- Module      :  OS.Cutil_12+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- This module contains some additional routines required for marshalling +-- Haskell arguments to OS C calling routines.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.Cutil_12+		( addr2int, int2addr, fpeek, Storable(..), free, malloc+		, module Data.Int+		, module Data.Bits+		, module Foreign.Ptr+		, module Foreign.C.String+		) where+++import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc+import Foreign.C.String+import Data.Int+import Data.Bits+import System.IO.Unsafe++import GHC.Ptr		( Ptr(..) )+import GHC.Base++--	Conversion operations:++addr2int :: Ptr a -> Int+addr2int (Ptr x) = I# (addr2Int# x)++int2addr :: Int -> Ptr a+int2addr (I# x) = Ptr (int2Addr# x)+++--	fpeek addr first peeks addr, then frees addr:+fpeek :: (Storable a) => Ptr a -> IO a+fpeek addr+	= do {+		x <- peek addr;+		free addr;+		return x+	  }
+ Graphics/UI/ObjectIO/OS/DocumentInterface.hs view
@@ -0,0 +1,199 @@+{-# OPTIONS_GHC -#include "cCrossCallxDI_121.h" #-}++-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.DocumentInterface+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- OS.DocumentInterface creates the infrastructure for (N/S/M)DI frame windows.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.DocumentInterface+		( OSDInfo(..), OSInfo(..), OSMenuBar(..)+		, emptyOSDInfo+		, getOSDInfoDocumentInterface+		, getOSDInfoOSMenuBar, setOSDInfoOSMenuBar+		, getOSDInfoOSInfo, setOSDInfoOSInfo+		, osOpenMDI, osOpenSDI, osCloseOSDInfo+		, getOSDInfoOSToolbar+		) where+++import Graphics.UI.ObjectIO.CommonDef (dumpFatalError)+import Graphics.UI.ObjectIO.StdIOCommon (DocumentInterface(MDI, SDI, NDI))+import Graphics.UI.ObjectIO.OS.ToolBar+import Graphics.UI.ObjectIO.OS.Types (OSWindowPtr, osNoWindowPtr, OSMenu, osNoMenu)+import Graphics.UI.ObjectIO.OS.ClCrossCall_12+import Graphics.UI.ObjectIO.OS.WindowCrossCall_12 (winFakePaint)+import Data.Maybe+import Foreign.Marshal.Utils(fromBool)+++data	OSDInfo+	= OSMDInfo+		{ osmdOSInfo     :: !OSInfo		-- The general document interface infrastructure+		, osmdWindowMenu :: !OSMenu		-- The Window menu in the MDI menu bar+		}+	| OSSDInfo+		{ ossdOSInfo     :: !OSInfo		-- The general document interface infrastructure+		}+	| OSNoInfo+data	OSInfo+	= OSInfo+		{ osFrame        :: !OSWindowPtr	-- The frame window of the (M/S)DI frame window+		, osToolbar      :: !(Maybe OSToolbar)	-- The toolbar of the (M/S)DI frame window (Nothing if no toolbar)+		, osClient       :: !OSWindowPtr	-- The client window of the (M/S)DI frame window+		, osMenuBar      :: !OSMenu		-- The menu bar of the (M/S)DI frame window+		}+data	OSMenuBar+	= OSMenuBar+		{ menuBar        :: !OSMenu+		, menuWindow     :: !OSWindowPtr+		, menuClient     :: !OSWindowPtr+		}+++osdocumentinterfaceFatalError :: String -> String -> x+osdocumentinterfaceFatalError function error+	= dumpFatalError function "OS.DocumentInterface" error+++{-	emptyOSDInfo creates a OSDInfo with dummy values for the argument document interface.+-}+emptyOSDInfo :: DocumentInterface -> OSDInfo+emptyOSDInfo di+	= case di of+		MDI -> OSMDInfo {osmdOSInfo=emptyOSInfo,osmdWindowMenu=osNoMenu}+		SDI -> OSSDInfo {ossdOSInfo=emptyOSInfo}+		NDI -> OSNoInfo+	where+		emptyOSInfo = OSInfo {osFrame=osNoWindowPtr,osToolbar=Nothing,osClient=osNoWindowPtr,osMenuBar=osNoMenu}+++{-	getOSDInfoDocumentInterface returns the DocumentInterface of the argument OSDInfo.+-}+getOSDInfoDocumentInterface :: OSDInfo -> DocumentInterface+getOSDInfoDocumentInterface (OSMDInfo _ _) = MDI+getOSDInfoDocumentInterface (OSSDInfo _)   = SDI+getOSDInfoDocumentInterface OSNoInfo       = NDI+++{-	getOSDInfoOSMenuBar returns the OSMenuBar info from the argument OSDInfo.+	setOSDInfoOSMenuBar sets the OSMenuBar info in the OSDInfo.+-}+getOSDInfoOSMenuBar :: OSDInfo -> Maybe OSMenuBar+getOSDInfoOSMenuBar osdInfo+	= case osdInfo of+		OSMDInfo {osmdOSInfo=info} -> get info+		OSSDInfo {ossdOSInfo=info} -> get info+		osnoinfo                   -> Nothing+	where+		get (OSInfo {osFrame=osFrame,osClient=osClient,osMenuBar=osMenuBar})+			= Just (OSMenuBar {menuBar=osMenuBar,menuWindow=osFrame,menuClient=osClient})++setOSDInfoOSMenuBar :: OSMenuBar -> OSDInfo -> OSDInfo+setOSDInfoOSMenuBar (OSMenuBar {menuBar=menuBar,menuWindow=menuWindow,menuClient=menuClient}) osdInfo+	= case osdInfo of+		mdi@(OSMDInfo {osmdOSInfo=info}) -> mdi {osmdOSInfo=set info}+		sdi@(OSSDInfo {ossdOSInfo=info}) -> sdi {ossdOSInfo=set info}+		osnoinfo                         -> osnoinfo+	where+		set info = info {osMenuBar=menuBar,osFrame=menuWindow,osClient=menuClient}+++{-	getOSDInfoOSInfo returns the OSInfo from the argument OSDInfo if present.+	setOSDInfoOSInfo sets the OSInfo in the OSDInfo.+-}+getOSDInfoOSInfo :: OSDInfo -> Maybe OSInfo+getOSDInfoOSInfo (OSMDInfo {osmdOSInfo=osmdOSInfo}) = Just osmdOSInfo+getOSDInfoOSInfo (OSSDInfo {ossdOSInfo=ossdOSInfo}) = Just ossdOSInfo+getOSDInfoOSInfo osnoinfo                           = Nothing++setOSDInfoOSInfo :: OSInfo -> OSDInfo -> OSDInfo+setOSDInfoOSInfo osinfo osm@(OSMDInfo _ _) = osm {osmdOSInfo=osinfo}+setOSDInfoOSInfo osinfo oss@(OSSDInfo _)   = oss {ossdOSInfo=osinfo}+setOSDInfoOSInfo _      osnoinfo           = osnoinfo+++{-	osOpenMDI creates the infrastructure of an MDI process.+		If the first Bool argument is True, then the frame window is shown, otherwise it is hidden.+		The second Bool indicates whether the process accepts file open events.+-}+osOpenMDI :: Bool -> Bool -> IO OSDInfo+osOpenMDI shown acceptFileOpen+	= do {+		returncci <- issueCleanRequest2 osCreateMDIWindowCallback (rq2Cci ccRqCREATEMDIFRAMEWINDOW (fromBool shown) (fromBool acceptFileOpen));+		let	msg     = ccMsg returncci+			(framePtr,clientPtr,menuBar,windowMenu)+				= if      msg==ccRETURN4 then (p1 returncci,p2 returncci,p3 returncci,p4 returncci)+				  else if msg==ccWASQUIT then (osNoWindowPtr,osNoWindowPtr,osNoWindowPtr,osNoWindowPtr)+				  else    osdocumentinterfaceFatalError "osOpenMDI" ("ccRETURN4 expected instead of "++show msg)+			osmdinfo = OSMDInfo+			             { osmdOSInfo     = OSInfo+			                                   { osFrame   = framePtr+			                                   , osToolbar = Nothing+			                                   , osClient  = clientPtr+			                                   , osMenuBar = menuBar+			                                   }+			             , osmdWindowMenu = windowMenu+			             }+		in+		return osmdinfo+	     }+	where+		osCreateMDIWindowCallback :: CrossCallInfo -> IO CrossCallInfo+		osCreateMDIWindowCallback (CrossCallInfo {ccMsg=msg})+			| msg==ccWmDEACTIVATE || msg==ccWmACTIVATE || msg==ccWmKILLFOCUS+				= return return0Cci+			| otherwise+				= osdocumentinterfaceFatalError "osCreateMDIWindowCallback" ("received message nr:"++show msg)++osOpenSDI :: Bool -> IO OSDInfo+osOpenSDI acceptFileOpen+	= do {+		returncci <- issueCleanRequest2 osCreateSDIWindowCallback (rq1Cci ccRqCREATESDIFRAMEWINDOW (fromBool acceptFileOpen));+		let	msg      = ccMsg returncci+			(framePtr,menuBar)+			         = if      msg==ccRETURN2 then (p1 returncci,p2 returncci)+			           else if msg==ccWASQUIT then (osNoWindowPtr,osNoWindowPtr)+			           else    osdocumentinterfaceFatalError "osOpenSDI" ("ccRETURN2 expected instead of "++show msg)+			ossdinfo = OSSDInfo+			             { ossdOSInfo = OSInfo {osFrame=framePtr,osToolbar=Nothing,osClient=osNoWindowPtr,osMenuBar=menuBar} }+		in return ossdinfo+	     }+	where+		osCreateSDIWindowCallback :: CrossCallInfo -> IO CrossCallInfo+		osCreateSDIWindowCallback (CrossCallInfo {ccMsg=msg})+			= if   msg==ccWmDEACTIVATE || msg==ccWmACTIVATE || msg==ccWmKILLFOCUS+			  then return return0Cci+			  else osdocumentinterfaceFatalError "osCreateSDIWindowCallback" ("received message nr:"++show msg)++osCloseOSDInfo :: OSDInfo -> IO ()+osCloseOSDInfo (OSMDInfo {osmdOSInfo=OSInfo {osFrame=osFrame}})+	= issueCleanRequest2 (osDestroyProcessWindowCallback "osCloseMDI") (rq1Cci ccRqDESTROYWINDOW osFrame) >> return ()+osCloseOSDInfo (OSSDInfo {ossdOSInfo=OSInfo {osFrame=osFrame}})+	= issueCleanRequest2 (osDestroyProcessWindowCallback "osCloseSDI") (rq1Cci ccRqDESTROYWINDOW osFrame) >> return ()+osCloseOSDInfo _+	= return ()++osDestroyProcessWindowCallback :: String -> CrossCallInfo -> IO CrossCallInfo+osDestroyProcessWindowCallback function cci@(CrossCallInfo {ccMsg=msg})+	| msg==ccWmDEACTIVATE || msg==ccWmACTIVATE || msg==ccWmKEYBOARD+		= return return0Cci+	| msg==ccWmPAINT+		= winFakePaint (p1 cci) >> return return0Cci+	| otherwise+		= osdocumentinterfaceFatalError function ("received message nr:"++show msg)++--	getOSDInfoOSToolbar retrieves the OSToolbar, if any.+getOSDInfoOSToolbar :: OSDInfo -> Maybe OSToolbar+getOSDInfoOSToolbar info@(OSMDInfo _ _) = osToolbar $ osmdOSInfo info+getOSDInfoOSToolbar info@(OSSDInfo _)   = osToolbar $ ossdOSInfo info+getOSDInfoOSToolbar _                   = Nothing
+ Graphics/UI/ObjectIO/OS/Event.hs view
@@ -0,0 +1,125 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.Event+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- OS.Event contains all type definitions for OS dependent events.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.Event+		( OSEvent, Graphics.UI.ObjectIO.OS.ClCrossCall_12.CrossCallInfo(..)+		, SchedulerEvent(..)+		, osNullEvent+		, osLongSleep, osNoSleep+		, osHandleEvents+		, setReplyInOSEvent+		, osEventIsUrgent+		, createOSActivateWindowEvent, createOSDeactivateWindowEvent+		, createOSActivateControlEvent, createOSDeactivateControlEvent+		, createOSLooseMouseEvent, createOSLooseKeyEvent+		) where ++++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.OS.ClCrossCall_12+import Graphics.UI.ObjectIO.OS.Types+import Foreign.Marshal.Utils(fromBool)++oseventFatalError :: String -> String -> x+oseventFatalError function error+	= dumpFatalError function "OSEvent" error+++--	SchedulerEvent and MsgEvent moved from DeviceEvents+data	SchedulerEvent				-- A scheduler event is either:+ =	ScheduleOSEvent  	!OSEvent ![Int]	-- a genuine OS event+ |	ScheduleMsgEvent 	!Id		-- a msg passing event+++instance Show SchedulerEvent where+	show (ScheduleOSEvent  e    _)  = "(ScheduleOSEvent " ++ show (ccMsg e) ++ ")"+	show (ScheduleMsgEvent recLoc)  = "ScheduleMsgEvent"+++type	OSEvent+	= CrossCallInfo+type	OSSleepTime	-- The max time the process allows multi-tasking+	= Int++osNullEvent :: OSEvent+osNullEvent = rq0Cci 0+++osLongSleep :: OSSleepTime+osLongSleep = 2^15-1+osNoSleep :: OSSleepTime+osNoSleep = 0++osHandleEvents :: IO Bool+               -> IO (Maybe SchedulerEvent)+               -> IO Int+               -> (SchedulerEvent -> IO [Int])+               -> IO ()+osHandleEvents isFinalState getOSEvent getSleepTime handleOSEvent = do+	terminate <- isFinalState+	(if terminate then return ()+	 else do+		osEvent <- getOSEvent+		(case osEvent of+			Nothing -> do+				sleep <- getSleepTime+				let getEventCci = rq2Cci ccRqDOMESSAGE (fromBool (sleep/=osLongSleep)) sleep+				issueCleanRequest2 (rccitoevent handleOSEvent) getEventCci+				osHandleEvents isFinalState getOSEvent getSleepTime handleOSEvent+			Just event -> do+				handleOSEvent event+				osHandleEvents isFinalState getOSEvent getSleepTime handleOSEvent))+	where+		rccitoevent :: (SchedulerEvent -> IO [Int]) -> OSEvent -> IO OSEvent+		rccitoevent handleOSEvent osEvent = do+			reply <- handleOSEvent (ScheduleOSEvent osEvent []);+			return (setReplyInOSEvent reply)+++setReplyInOSEvent :: [Int] -> CrossCallInfo+setReplyInOSEvent [] = return0Cci+setReplyInOSEvent [e1] = return1Cci e1+setReplyInOSEvent [e1,e2] = return2Cci e1 e2+setReplyInOSEvent [e1,e2,e3] = return3Cci e1 e2 e3+setReplyInOSEvent [e1,e2,e3,e4] = return4Cci e1 e2 e3 e4+setReplyInOSEvent [e1,e2,e3,e4,e5] = return5Cci e1 e2 e3 e4 e5+setReplyInOSEvent [e1,e2,e3,e4,e5,e6] = return6Cci e1 e2 e3 e4 e5 e6+setReplyInOSEvent otherwise             = oseventFatalError "setReplyInOSEvent" "number of reply codes > 6"++osEventIsUrgent :: SchedulerEvent -> Bool+osEventIsUrgent _ = True+++{- createOS(Dea/A)ctivateWindowEvent creates the event the platform would generate for a genuine (de)activate event. -}+createOSActivateWindowEvent :: OSWindowPtr -> SchedulerEvent+createOSActivateWindowEvent wPtr = ScheduleOSEvent (rq1Cci ccWmACTIVATE wPtr) []++createOSDeactivateWindowEvent :: OSWindowPtr -> SchedulerEvent+createOSDeactivateWindowEvent wPtr = ScheduleOSEvent (rq1Cci ccWmDEACTIVATE wPtr) []++{- createOS(Dea/A)ctivateControlEvent creates the event the platform would generate for a genuine (de)activate event. -}+createOSActivateControlEvent :: OSWindowPtr -> OSWindowPtr -> SchedulerEvent+createOSActivateControlEvent wPtr cPtr = ScheduleOSEvent (rq2Cci ccWmSETFOCUS wPtr cPtr) []++createOSDeactivateControlEvent :: OSWindowPtr -> OSWindowPtr -> SchedulerEvent+createOSDeactivateControlEvent wPtr cPtr = ScheduleOSEvent (rq2Cci ccWmKILLFOCUS wPtr cPtr) []++{- createOSLoose(Mouse/Key)Event creates the event for reporting loss of mouse/keyboard input (virtual event). -}+createOSLooseMouseEvent :: OSWindowPtr -> OSWindowPtr -> SchedulerEvent+createOSLooseMouseEvent wPtr cPtr = ScheduleOSEvent (rq2Cci ccWmLOSTMOUSE wPtr cPtr) []++createOSLooseKeyEvent :: OSWindowPtr -> OSWindowPtr -> SchedulerEvent+createOSLooseKeyEvent wPtr cPtr = ScheduleOSEvent (rq2Cci ccWmLOSTKEY wPtr cPtr) []
+ Graphics/UI/ObjectIO/OS/FileSelect.hs view
@@ -0,0 +1,93 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.FileSelect+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.FileSelect(osSelectInputFile, osSelectOutputFile, osSelectDirectory) where+++import	Graphics.UI.ObjectIO.CommonDef (dumpFatalError)+import	Graphics.UI.ObjectIO.OS.ClCrossCall_12+import	Graphics.UI.ObjectIO.OS.Event+import	Graphics.UI.ObjectIO.OS.Cutil_12(int2addr, addr2int, free)+import  Foreign.C.String(newCString, peekCString)+++osFileSelectFatalError :: String -> String -> x+osFileSelectFatalError function error+	= dumpFatalError function "OSFileSelect" error++osSelectInputFile :: (OSEvent->IO ()) -> IO (Maybe String)+osSelectInputFile handleOSEvent =+	issueCleanRequest2 (callback handleOSEvent) (rq0Cci ccRqFILEOPENDIALOG) >>= getInputFileName+	where+		getInputFileName :: CrossCallInfo -> IO (Maybe String)+		getInputFileName cci+			| ccMsg cci == ccRETURN2 =+				if p1 cci == 0+				then return Nothing+				else do+					let pathnamePtr = (int2addr (p2 cci))+					pathname <- peekCString pathnamePtr+					free pathnamePtr+					return (Just pathname)+			| ccMsg cci == ccWASQUIT =+				return Nothing+			| otherwise =+				osFileSelectFatalError "osSelectInputFile" ("unexpected ccMsg field of return CrossCallInfo ("++show (ccMsg cci)++")")++osSelectOutputFile :: (OSEvent->IO ()) -> String -> String -> IO (Maybe String)+osSelectOutputFile handleOSEvent prompt filename = do+	promptPtr <- newCString prompt+	filenamePtr <- newCString filename+	rcci <- issueCleanRequest2 (callback handleOSEvent) (rq2Cci ccRqFILESAVEDIALOG (addr2int promptPtr) (addr2int filenamePtr))+	free promptPtr+	free filenamePtr+	getOutputFileName rcci+	where+		getOutputFileName :: CrossCallInfo -> IO (Maybe String)+		getOutputFileName cci+			| ccMsg cci == ccRETURN2 =+				if p1 cci == 0+				then return Nothing+				else do+					let pathPtr = (int2addr (p2 cci))+					path <- peekCString pathPtr+					free pathPtr+					return (Just path)+			| ccMsg cci == ccWASQUIT =+				return Nothing+			| otherwise =+				osFileSelectFatalError "osSelectOutputFile" ("unexpected ccMsg field of return CrossCallInfo ("++show (ccMsg cci)++")")++osSelectDirectory :: (OSEvent->IO ()) -> IO (Maybe String)+osSelectDirectory handleOSEvent =+	issueCleanRequest2 (callback handleOSEvent) (rq0Cci ccRqDIRECTORYDIALOG) >>= getInputFileName+	where+		getInputFileName :: CrossCallInfo -> IO (Maybe String)+		getInputFileName cci+			| ccMsg cci == ccRETURN2 =+				if p1 cci == 0+				then return Nothing+				else do+					let pathnamePtr = (int2addr (p2 cci))+					pathname <- peekCString pathnamePtr+					free pathnamePtr+					return (Just pathname)+			| ccMsg cci == ccWASQUIT =+				return Nothing+			| otherwise =+				osFileSelectFatalError "osSelectDirectory" ("unexpected ccMsg field of return CrossCallInfo ("++show (ccMsg cci)++")")++--	callback lifts a function::(OSEvent -> IO ()) to+--        a crosscallfunction::(CrossCallInfo -> IO CrossCallInfo)+callback :: (OSEvent->IO ()) -> CrossCallInfo -> IO CrossCallInfo+callback handleOSEvent cci = handleOSEvent cci >> return return0Cci
+ Graphics/UI/ObjectIO/OS/Font.hs view
@@ -0,0 +1,280 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.Font+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- OS.Font defines all font related functions and data types.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.Font+		( Font(..)+		, osFontGetImp, osCreateFont		+		, osFontNames, osFontSizes+		, osGetFontCharWidths, osGetFontStringWidths+		, osGetFontMetrics, osGetPicFontMetrics+		, defaultFont, dialogFont, serifFont+		, sansSerifFont, smallFont, nonProportionalFont, symbolFont +		) where++++import Graphics.UI.ObjectIO.CommonDef(dumpFatalError, isBetween, minmax)+import Graphics.UI.ObjectIO.OS.Cutil_12+import Graphics.UI.ObjectIO.OS.ClCCall_12+import Graphics.UI.ObjectIO.OS.ClCrossCall_12+import Graphics.UI.ObjectIO.OS.Types+import System.IO.Unsafe(unsafePerformIO)+++data	Font +	= Font+		{ fontName        :: !String	-- Name of the font+		, fontSize        :: !Int	-- Size of the font+		, fontIsBold      :: !Bool+		, fontIsUnderline :: !Bool+		, fontIsItalic    :: !Bool+		, fontIsStrikeout :: !Bool+		} deriving Eq++iStrikeOut, iUnderline, iItalic, iBold :: Int+iStrikeOut	= 8+iUnderline	= 4+iItalic		= 2+iBold		= 1++{-# NOINLINE defaultFont #-}+defaultFont = unsafePerformIO osDefaultFont+    where+	osDefaultFont :: IO Font+	osDefaultFont = do+	    a1 <- malloc+	    a2 <- malloc+	    a3 <- malloc+	    winDialogFontDef a1 a2 a3+	    fname <- fpeek a1 >>= peekCString+	    styles<- fpeek a2+	    size  <- fpeek a3+	    return (osCreateFont fname styles size)+foreign import ccall "cpicture_121.h WinDefaultFontDef" winDefaultFontDef :: Ptr CString -> Ptr Int -> Ptr Int -> IO ()++{-# NOINLINE dialogFont #-}+dialogFont = unsafePerformIO osDialogFont+    where+        osDialogFont :: IO Font+        osDialogFont = do+ 	    a1 <- malloc+	    a2 <- malloc+	    a3 <- malloc+	    winDialogFontDef a1 a2 a3+	    fname <- fpeek a1 >>= peekCString+	    styles<- fpeek a2+	    size  <- fpeek a3+	    return (osCreateFont fname styles size)+foreign import ccall "cpicture_121.h WinDialogFontDef" winDialogFontDef :: Ptr CString -> Ptr Int -> Ptr Int -> IO ()++{-# NOINLINE serifFont #-}+serifFont = unsafePerformIO osSerifFont+    where+        osSerifFont :: IO Font+        osSerifFont = do+	    a1 <- malloc+	    a2 <- malloc+	    a3 <- malloc+	    winSerifFontDef a1 a2 a3+	    fname <- fpeek a1 >>= peekCString+	    styles<- fpeek a2+	    size  <- fpeek a3+	    return (osCreateFont fname styles size)+foreign import ccall "cpicture_121.h WinSerifFontDef" winSerifFontDef :: Ptr CString -> Ptr Int -> Ptr Int -> IO ()++{-# NOINLINE sansSerifFont #-}+sansSerifFont = unsafePerformIO osSansSerifFont+    where+        osSansSerifFont :: IO Font+        osSansSerifFont = do+	    a1 <- malloc+	    a2 <- malloc+	    a3 <- malloc+	    winSansSerifFontDef a1 a2 a3+	    fname <- fpeek a1 >>= peekCString+	    styles<- fpeek a2+	    size  <- fpeek a3+	    return (osCreateFont fname styles size)+foreign import ccall "cpicture_121.h WinSansSerifFontDef" winSansSerifFontDef :: Ptr CString -> Ptr Int -> Ptr Int -> IO ()++{-# NOINLINE smallFont #-}+smallFont = unsafePerformIO osSmallFont+    where+        osSmallFont :: IO Font+        osSmallFont = do+	    a1 <- malloc+	    a2 <- malloc+	    a3 <- malloc+	    winSmallFontDef a1 a2 a3+	    fname <- fpeek a1 >>= peekCString+	    styles<- fpeek a2+	    size  <- fpeek a3+	    return (osCreateFont fname styles size)+foreign import ccall "cpicture_121.h WinSmallFontDef" winSmallFontDef :: Ptr CString -> Ptr Int -> Ptr Int -> IO ()++{-# NOINLINE nonProportionalFont #-}+nonProportionalFont = unsafePerformIO osNonProportionalFont+    where+        osNonProportionalFont :: IO Font+        osNonProportionalFont = do+  	    a1 <- malloc+	    a2 <- malloc+	    a3 <- malloc+	    winNonProportionalFontDef a1 a2 a3+	    fname <- fpeek a1 >>= peekCString+	    styles<- fpeek a2+	    size  <- fpeek a3+	    return (osCreateFont fname styles size)+foreign import ccall "cpicture_121.h WinNonProportionalFontDef" winNonProportionalFontDef :: Ptr CString -> Ptr Int -> Ptr Int -> IO ()++{-# NOINLINE symbolFont #-}+symbolFont = unsafePerformIO osSymbolFont+    where+        osSymbolFont :: IO Font+        osSymbolFont = do+	    a1 <- malloc+	    a2 <- malloc+	    a3 <- malloc+	    winSymbolFontDef a1 a2 a3+	    fname <- fpeek a1 >>= peekCString+	    styles<- fpeek a2+	    size  <- fpeek a3+	    return (osCreateFont fname styles size)+foreign import ccall "cpicture_121.h WinSymbolFontDef" winSymbolFontDef :: Ptr CString -> Ptr Int -> Ptr Int -> IO ()++osFontGetImp :: Font -> (String, Int, Int)+osFontGetImp font = +	( fontName font+	, (if fontIsBold      font then iBold      else 0) .|.+	  (if fontIsItalic    font then iItalic    else 0) .|.+	  (if fontIsUnderline font then iUnderline else 0) .|.+	  (if fontIsStrikeout font then iStrikeOut else 0)+	, fontSize font+	)++osCreateFont fname styles size = +	Font+	  { fontName        = fname+	  , fontSize        = size+	  , fontIsBold      = styles .&. iBold      /= 0+	  , fontIsItalic    = styles .&. iItalic    /= 0+	  , fontIsUnderline = styles .&. iUnderline /= 0+	  , fontIsStrikeout = styles .&. iStrikeOut /= 0+	  }++osFontNames :: IO [String]+osFontNames+	= do {+		(_,unsortednames) <- issueCleanRequest fontnamesCallback (rq0Cci ccRqGETFONTNAMES) [];+		return (sortAndRemoveDuplicates unsortednames)+	  }+	where+		fontnamesCallback :: CrossCallInfo -> [String] -> IO (CrossCallInfo,[String])+		fontnamesCallback cci names+			= do {+				newname <- peekCString (int2addr (p1 cci));+				return (return0Cci,newname:names)+			  }++sortAndRemoveDuplicates :: (Ord a) => [a] -> [a]+sortAndRemoveDuplicates (e:es)+	= insert e (sortAndRemoveDuplicates es)+	where+		insert :: (Ord a) => a -> [a] -> [a]+		insert a list@(b:x)+			| a<b       = a:list+			| a>b       = b:(insert a x)+			| otherwise = list+		insert a _ = [a]+sortAndRemoveDuplicates _ = []+++osFontSizes :: Int -> Int -> String -> IO [Int]+osFontSizes between1 between2 fname+	= do {+		textptr           <- newCString fname;+		(_,unsortedsizes) <- issueCleanRequest fontSizesCallback (rq1Cci ccRqGETFONTSIZES (addr2int textptr)) [];+		return (sortAndRemoveDuplicates unsortedsizes)+	  }+	where+		(low,high)         = minmax between1 between2+		+		fontSizesCallback :: CrossCallInfo -> [Int] -> IO (CrossCallInfo,[Int])+		fontSizesCallback (CrossCallInfo {p1=size,p2=0}) sizes+			= return (return0Cci,newsizes)+			where+				newsizes = if   isBetween size low high+				           then size:sizes+				           else sizes+		fontSizesCallback _ _+			= return (return0Cci,[low..high])++fn Nothing  = nullPtr+fn (Just x) = x++osGetFontCharWidths :: Maybe OSPictContext -> [Char] -> Font -> IO [Int]+osGetFontCharWidths maybeHdc chars font = do+	let (fname,fstyles,fsize) = osFontGetImp font+	s1 <- newCString fname+	r <- sequence [winGetCharWidth c s1 fstyles fsize (fn maybeHdc) | c <- chars]+	free s1+	return r+foreign import ccall "cpicture_121.h WinGetCharWidth" winGetCharWidth :: Char -> CString -> Int -> Int -> OSPictContext -> IO Int++osGetFontStringWidths :: Maybe OSPictContext -> [String] -> Font -> IO [Int]+osGetFontStringWidths maybeHdc strings font = do+	let (fname,fstyles,fsize) = osFontGetImp font+	s1 <- newCString fname+	r <- sequence [withCString s (\s -> winGetStringWidth s s1 fstyles fsize (fn maybeHdc)) | s <- strings]+	free s1+	return r+foreign import ccall "cpicture_121.h WinGetStringWidth" winGetStringWidth :: CString -> CString -> Int -> Int -> OSPictContext -> IO Int++osGetFontMetrics :: Maybe OSPictContext -> Font -> IO (Int,Int,Int,Int)+osGetFontMetrics maybeHdc font = do+	let (fname,fstyles,fsize) = osFontGetImp font+	-- Marshal arguments:+	s1 <- newCString fname+	o1 <- malloc+	o2 <- malloc+	o3 <- malloc+	o4 <- malloc+	-- Call C:+	winGetFontInfo s1 fstyles fsize (fn maybeHdc) o1 o2 o3 o4+	-- Read/free:+	free s1+	ascent <- fpeek o1+	descent <- fpeek o2+	maxwidth <- fpeek o3+	leading <- fpeek o4	+	return (ascent,descent,leading,maxwidth)+foreign import ccall "cpicture_121.h WinGetFontInfo" winGetFontInfo :: CString -> Int -> Int -> OSPictContext -> Ptr Int -> Ptr Int -> Ptr Int -> Ptr Int -> IO ()+	+osGetPicFontMetrics :: OSPictContext -> IO (Int,Int,Int,Int)+osGetPicFontMetrics a1 = do+	-- Marshal arguments:+	o1 <- malloc+	o2 <- malloc+	o3 <- malloc+	o4 <- malloc		+	-- Call C:+	winGetPicFontInfo a1 o1 o2 o3 o4+	-- Read/free:+	r1 <- fpeek o1+	r2 <- fpeek o2+	r3 <- fpeek o3+	r4 <- fpeek o4+	return (r1,r2,r3,r4)+foreign import ccall "cpicture_121.h WinGetPicFontInfo" winGetPicFontInfo :: OSPictContext -> Ptr Int -> Ptr Int -> Ptr Int -> Ptr Int -> IO ()
+ Graphics/UI/ObjectIO/OS/Menu.hs view
@@ -0,0 +1,161 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.Menu+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.Menu where+++import Graphics.UI.ObjectIO.OS.DocumentInterface(OSMenuBar(..))+import Graphics.UI.ObjectIO.OS.Types(OSWindowPtr, osNoWindowPtr)+import Graphics.UI.ObjectIO.OS.ClCrossCall_12+import Graphics.UI.ObjectIO.OS.Cutil_12+import Graphics.UI.ObjectIO.OS.Types(OSWindowPtr,OSMenu,osNoMenu,OSMenuItem,osNoMenuItem)+import Foreign.Marshal.Utils(fromBool)+import Control.Monad(when)+import Data.Char(ord)+++--	Enabling and disabling menus and menu elements:++osDisableMenu :: OSMenu -> OSMenuBar -> IO ()+osDisableMenu submenu osMenuBar@(OSMenuBar {menuBar=menuBar}) = do+	issueCleanRequest2 (errorCallback2 "osDisableMenu") (rq3Cci ccRqMENUENABLE menuBar submenu (fromBool False))+	return ()++osEnableMenu :: OSMenu -> OSMenuBar -> IO ()+osEnableMenu submenu osMenuBar@(OSMenuBar {menuBar=menuBar}) = do+	issueCleanRequest2 (errorCallback2 "osEnableMenu") (rq3Cci ccRqMENUENABLE menuBar submenu (fromBool True))+	return ()++osEnableMenuItem :: OSMenu -> OSMenuItem -> IO ()+osEnableMenuItem menuHandle item = do	+	issueCleanRequest2 (errorCallback2 "osEnableMenuItem") (rq3Cci ccRqITEMENABLE menuHandle item (fromBool True))+	return ()++osDisableMenuItem :: OSMenu -> OSMenuItem -> IO ()+osDisableMenuItem menuHandle item = do+	issueCleanRequest2 (errorCallback2 "osEnableMenuItem") (rq3Cci ccRqITEMENABLE menuHandle item (fromBool False))+	return ()+++--	Changing and updating the menu bar:++drawMenuBar :: OSMenuBar -> IO ()+drawMenuBar (OSMenuBar {menuWindow=menuWindow,menuClient=menuClient}) = do+	issueCleanRequest2 (errorCallback2 "drawMenuBar") (rq2Cci ccRqDRAWMBAR menuWindow menuClient)+	return ()++osMenuBarClear :: IO ()+osMenuBarClear = return ()++osMenuBarSet :: OSMenuBar -> IO ()+osMenuBarSet menuBar = return ()+	+osMenuInsert :: OSMenuBar -> Int -> String -> Bool -> IO OSMenu+osMenuInsert (OSMenuBar {menuBar=menuBar}) index title able = do+	textPtr <- newCString title+	rcci <- issueCleanRequest2 (errorCallback2 "osMenuInsert") (rq4Cci ccRqINSERTMENU (fromBool able) menuBar (addr2int textPtr) index)+	free textPtr+	(if ccMsg rcci == ccRETURN1+	 then return (p1 rcci)+	 else if ccMsg rcci == ccWASQUIT+	      then return osNoMenu+	      else error "[osMenuInsert] expected CcRETURN1 value.")+	+osSubMenuInsert :: OSMenu -> Int -> String -> Bool -> IO OSMenu+osSubMenuInsert parentMenu index title able = do+	textPtr <- newCString title+	rcci <- issueCleanRequest2 (errorCallback2 "osSubMenuInsert") (rq4Cci ccRqINSERTMENU (fromBool able) parentMenu (addr2int textPtr) index)+	free textPtr+	(if ccMsg rcci == ccRETURN1 +	 then return (p1 rcci)+	 else if ccMsg rcci == ccWASQUIT +	      then return osNoMenu+	      else error "[osSubMenuInsert] expected CcRETURN1 value.")++osMenuRemove :: OSMenu -> OSMenuBar -> IO ()+osMenuRemove menu (OSMenuBar {menuBar=menuBar}) = do	+	issueCleanRequest2 (errorCallback2 "osMenuRemove") (rq2Cci ccRqDELETEMENU menuBar menu)	+	return ()	++osSubMenuRemove :: OSMenu -> OSMenu -> IO ()+osSubMenuRemove subMenu parentMenu = do+	issueCleanRequest2 (errorCallback2 "osMenuRemove") (rq2Cci ccRqDELETEMENU parentMenu subMenu)+	return ()++osCreatePopUpMenu :: IO OSMenu+osCreatePopUpMenu = do+	rcci <- issueCleanRequest2 (errorCallback2 "CreatePopupMenuHandle ") (rq0Cci ccRqCREATEPOPMENU)+	let menu =+		if ccMsg rcci == ccRETURN1 then p1 rcci else+		if ccMsg rcci == ccWASQUIT then 0	else+						error "[CreatePopupMenuHandle] expected CcRETURN1 value."+	return menu++osTrackPopUpMenu :: OSMenu -> OSWindowPtr -> IO Bool+osTrackPopUpMenu menu framePtr = do+	rcci <- issueCleanRequest2 (errorCallback2 "osTrackPopUpMenu") (rq2Cci ccRqTRACKPOPMENU menu framePtr)+	let ok = +		if ccMsg rcci == ccRETURN1 then p1 rcci /= 0 else+	  	if ccMsg rcci == ccWASQUIT then False	     else+	  				        error "[osTrackPopUpMenu] expected CcRETURN1 value."+	return ok+++--	Changing (sub)menus:+osMenuItemInsert :: OSMenuBar -> OSMenu -> Int -> String -> Bool -> Bool -> Char -> IO OSMenuItem+osMenuItemInsert (OSMenuBar {menuWindow=menuWindow}) menu index title able mark key = do+	textPtr <- newCString title+	let insertCci = rq6Cci ccRqINSERTMENUITEM ((fromBool able)*2 + (fromBool mark)) menuWindow menu (addr2int textPtr) (ord key) index+	rcci <- issueCleanRequest2 (errorCallback2 "osAppendMenuItem") insertCci+	let item =+		if ccMsg rcci == ccRETURN1 then p1 rcci      else+		if ccMsg rcci == ccWASQUIT then osNoMenuItem else+						error "[osAppendMenuItem] expected CcRETURN1 value."+	free textPtr+	return item++osMenuSeparatorInsert :: OSMenu -> Int -> IO OSMenuItem+osMenuSeparatorInsert menu index = do+	rcci <- issueCleanRequest2 (errorCallback2 "osAppendMenuSeparator") (rq2Cci ccRqINSERTSEPARATOR menu index)+	let hitem =+		if ccMsg rcci == ccRETURN1 then p1 rcci      else+		if ccMsg rcci == ccWASQUIT then osNoMenuItem else+					        error "[osAppendMenuSeparator] expected CcRETURN1 value."+	return hitem++osChangeMenuTitle :: OSMenuBar -> OSMenu -> String -> IO ()+osChangeMenuTitle (OSMenuBar {menuBar=menuBar}) menu title = do+	textPtr <- newCString title+	issueCleanRequest2 (errorCallback2 "ModifyMenu") (rq3Cci ccRqMODIFYMENU menu menuBar (addr2int textPtr))+	free textPtr++osChangeMenuItemTitle :: OSMenu -> OSMenuItem -> String -> IO ()+osChangeMenuItemTitle menu item title = do+	textPtr <- newCString title+	issueCleanRequest2 (errorCallback2 "ModifyMenuItem") (rq3Cci ccRqMODIFYMENUITEM item menu (addr2int textPtr))+	free textPtr++osMenuItemCheck :: Bool -> OSMenu -> OSMenuItem -> IO ()+osMenuItemCheck check menu item = do+	issueCleanRequest2 (errorCallback2 "CheckMenuItem") (rq3Cci ccRqCHECKMENUITEM menu item (fromBool check))+	return ()++osMenuRemoveItem :: OSMenuItem -> OSMenu -> IO ()+osMenuRemoveItem item menu = do+	issueCleanRequest2 (errorCallback2 "RemoveMenuItem") (rq2Cci ccRqREMOVEMENUITEM menu item)+	return ()++osRemoveMenuShortKey :: OSWindowPtr -> Int -> IO ()+osRemoveMenuShortKey framePtr cmd = do+	issueCleanRequest2 (errorCallback2 "osRemoveMenuShortKey") (rq2Cci ccRqREMOVEMENUSHORTKEY framePtr cmd)+	return ()
+ Graphics/UI/ObjectIO/OS/MenuEvent.hs view
@@ -0,0 +1,245 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.MenuEvent+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- OS.MenuEvent defines the DeviceEventFunction for the menu device.+-- This function is placed in a separate module because it is platform dependent.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.MenuEvent(menuEvent, menuHandlesGetMenuStateHandles) where+++import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.Device.Events+import  Graphics.UI.ObjectIO.Device.SystemState+import	Graphics.UI.ObjectIO.Process.IOState+import  Graphics.UI.ObjectIO.StdGUI+import  Graphics.UI.ObjectIO.Menu.Handle+import	Graphics.UI.ObjectIO.Menu.Access(menuStateHandleGetHandle, menuStateHandleGetMenuId)+import	Graphics.UI.ObjectIO.StdProcessAttribute(getProcessToolbarAtt, isProcessToolbar)+import  Graphics.UI.ObjectIO.OS.Event(SchedulerEvent(..), OSEvent)+import  Graphics.UI.ObjectIO.OS.ToolBar(OSToolbar(..))+import  Graphics.UI.ObjectIO.OS.Menu+import  Graphics.UI.ObjectIO.OS.Types+import	Graphics.UI.ObjectIO.OS.ClCrossCall_12+import	Graphics.UI.ObjectIO.OS.ClCCall_12+import  Graphics.UI.ObjectIO.OS.Cutil_12(addr2int)+import  Graphics.UI.ObjectIO.Id(IdParent(..))+import  Foreign.C.String+import  Data.Bits		-- Defines .&. for bitand;+import  Data.Int		-- Defines Int32 instance for Bits;+import  Data.IORef(readIORef)+import  Data.Map as Map (lookup)+++menuEventFatalError :: String -> String -> x+menuEventFatalError function error+	= dumpFatalError function "OS.MenuEvent" error+++{-	menuEvent filters the scheduler events that can be handled by this menu device.+	For the time being no timer menu elements are added, so these events are ignored.+	menuEvent assumes that it is not applied to an empty IOSt and that its device is+	present.+-}+menuEvent :: IOSt ps -> SchedulerEvent -> IO (Bool,Maybe DeviceEvent,SchedulerEvent)+menuEvent ioState schedulerEvent+    | ioStHasDevice MenuDevice ioState	= menuEvent schedulerEvent ioState +    | otherwise 			= menuEventFatalError "menuEvent" "MenuDevice.dEvent applied while MenuDevice not present in IOSt"       +    where+	menuEvent :: SchedulerEvent -> IOSt ps -> IO (Bool,Maybe DeviceEvent,SchedulerEvent)+	menuEvent schedulerEvent@(ScheduleOSEvent osEvent@(CrossCallInfo {ccMsg=ccMsg}) _) ioState+		| isToolbarOSEvent ccMsg = do			+			(myEvent,replyToOS,deviceEvent) <- filterToolbarEvent (ioStGetOSDInfo ioState) osEvent ioState+			let schedulerEvent1 =+				if isJust replyToOS then+				 	(ScheduleOSEvent osEvent (fromJust replyToOS))+				else schedulerEvent+			return (myEvent,deviceEvent,schedulerEvent1)+		| isMenuOSEvent ccMsg = do+			let (found,mDevice) = ioStGetDevice MenuDevice ioState+			let menus = menuSystemStateGetMenuHandles mDevice+			(myEvent,replyToOS,deviceEvent) <- filterOSEvent osEvent (found {-&& systemId==ioId-}) menus+			let schedulerEvent1 = if isJust replyToOS then (ScheduleOSEvent osEvent (fromJust replyToOS)) else schedulerEvent+			return (myEvent,deviceEvent,schedulerEvent1)+		| otherwise =+			return (False,Nothing,schedulerEvent)+		where+			isMenuOSEvent :: Int -> Bool+			isMenuOSEvent msg = msg == ccWmCOMMAND++			isToolbarOSEvent :: Int -> Bool+			isToolbarOSEvent msg = msg == ccWmBUTTONCLICKED || msg == ccWmGETTOOLBARTIPTEXT+	+	menuEvent schedulerEvent@(ScheduleMsgEvent rId) ioState = do+		iocontext <- readIORef (ioStGetContext ioState)+		case Map.lookup rId (ioContextGetIdTable iocontext) of+			Just idParent | idpIOId idParent == ioStGetIOId ioState && idpDevice idParent == MenuDevice ->+				let (_,mDevice) = ioStGetDevice MenuDevice ioState+				    menus = menuSystemStateGetMenuHandles mDevice+				    found = hasMenuHandlesMenu (idpId idParent) menus+				    deviceEvent	= if found then (Just (ReceiverEvent rId)) else Nothing			    +				in return (found,deviceEvent,schedulerEvent)+	       		_ -> return (False,Nothing,schedulerEvent)+	    where+		hasMenuHandlesMenu :: Id -> MenuHandles ps -> Bool+		hasMenuHandlesMenu menuId mHs@(MenuHandles {mMenus=mMenus}) =+			any (eqMenuId menuId) mMenus+			where+				eqMenuId :: Id -> MenuStateHandle ps -> Bool+				eqMenuId theId msH = theId == menuStateHandleGetMenuId msH+++{-	filterToolbarEvent filters the OSEvents that can be handled by this menu device. -}++filterToolbarEvent :: OSDInfo -> OSEvent -> IOSt ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)++filterToolbarEvent osdInfo cci@(CrossCallInfo{ccMsg=ccMsg}) ioState+	{-	ccWmBUTTONCLICKED is a menu event in case of a toolbar selection.  -}+	| ccMsg == ccWmBUTTONCLICKED =	+		if isToolbarEvent osdInfo (p2 cci) then+			return (True,Nothing,Just (ToolbarSelection (p4 cci)))+		else+			return (False,Nothing,Nothing)+	{-	ccWmGETTOOLBARTIPTEXT does not continue platform independent event handling, but returns the +		String associated with the requested toolbar item.+	-}+	| ccMsg == ccWmGETTOOLBARTIPTEXT =+		if isToolbarEvent osdInfo (p1 cci) then+			let atts = ioStGetProcessAttributes ioState+			    (found,att)	= cselect isProcessToolbar undefined atts+			    maybe_tip = gettooltip (p2 cci) (getProcessToolbarAtt att)+			    +			    gettooltip :: Int -> [ToolbarItem ps] -> Maybe String+			    gettooltip i (item:items)+				| i==1 && isItem	= tip+				| otherwise		= gettooltip i' items+				where+					(isItem,i',tip)		= case item of+						ToolbarItem _ tip _	-> (True,i-1,tip)+						ToolbarSeparator	-> (False,i,Nothing)+		       	    gettooltip _ _ = Nothing+		       	in+			    if not found || isNothing maybe_tip then return (True,Nothing,Nothing)+			    else do+				 textptr <- newCString (fromJust maybe_tip)+				 return (True,Just [addr2int textptr],Nothing)+		else+			return (False,Nothing,Nothing)		     +	| otherwise = menuEventFatalError "filterToolbarEvent" "unmatched OSEvent"+++{-	filterOSEvent filters the OSEvents that can be handled by this menu device.+		The Bool argument is True iff the parent process is visible and active.+-}+filterOSEvent :: OSEvent -> Bool -> (MenuHandles ps) -> IO (Bool,Maybe [Int],Maybe DeviceEvent)++{-	ccWmCOMMAND returns the selected menu item.+	This item is identified by:+	-	the top level menu Id,+	-	a possibly empty list of parent sub menus. This list is given by zero based indices starting from the top level menu.+	-	in the parent (sub) menu, the zero based index of the item.+	Only MenuItemHandle and SubMenuHandle elements increase the index; all other elements don't.+-}+filterOSEvent CrossCallInfo{ccMsg=ccMsg,p1=item,p2=mods} _ menus@(MenuHandles {mEnabled=mEnabled,mMenus=mHs})+    | ccMsg == ccWmCOMMAND =+	if not mEnabled then return (False,Nothing,Nothing)+	else do+		(found,deviceEvent) <- getSelectedMenuStateHandlesItem item mods mHs+		return (found,Nothing,deviceEvent)+    | otherwise =+	menuEventFatalError "filterOSEvent" "unmatched OSEvent"+    where+	getSelectedMenuStateHandlesItem :: Int -> Int -> [MenuStateHandle ps] -> IO (Bool,Maybe DeviceEvent)+	getSelectedMenuStateHandlesItem item mods [] =+	    return (False,Nothing)+	getSelectedMenuStateHandlesItem item mods (msH:msHs) = do+	    (found,menuEvent) <- getSelectedMenuStateHandleItem item mods msH+	    (if found then return (found,menuEvent)+	     else getSelectedMenuStateHandlesItem item mods msHs)+	    where+		getSelectedMenuStateHandleItem :: Int -> Int -> MenuStateHandle ps -> IO (Bool,Maybe DeviceEvent)+		getSelectedMenuStateHandleItem item mods msH@(MenuStateHandle mlsH@(MenuLSHandle {mlsHandle=mH@(MenuHandle {mSelect=mSelect,mMenuId=mMenuId,mItems=mItems})}))+		    | not mSelect =+			return (False,Nothing)+		    | otherwise = do+			(found,menuEvent,_,_) <- getSelectedMenuElementHandlesItem item mMenuId mods [] 0 mItems+			return (found,menuEvent)+		    where+			getSelectedMenuElementHandlesItem :: Int -> Id -> Int -> [Int] -> Int -> [MenuElementHandle ls ps] -> IO (Bool,Maybe DeviceEvent,[Int],Int)+			getSelectedMenuElementHandlesItem item menuId mods parents zIndex [] =+			    return (False,Nothing,parents,zIndex)+			getSelectedMenuElementHandlesItem item menuId mods parents zIndex (itemH:itemHs) = do+			    (found,menuEvent,parents,zIndex) <- getSelectedMenuElementHandle item menuId mods parents zIndex itemH+			    (if found then return (found,menuEvent,parents,zIndex)+			     else getSelectedMenuElementHandlesItem item menuId mods parents zIndex itemHs)+			    where+				getSelectedMenuElementHandle :: Int -> Id -> Int -> [Int] -> Int -> MenuElementHandle ls ps -> IO (Bool,Maybe DeviceEvent,[Int],Int)+				+				getSelectedMenuElementHandle item menuId mods parents zIndex itemH@(MenuItemHandle {mOSMenuItem=mOSMenuItem,mItemId=mItemId})+					| item==mOSMenuItem =+						return (True,Just (MenuTraceEvent (MenuTraceInfo {mtId=menuId,mtParents=parents,mtItemNr=zIndex,mtModifiers=toModifiers mods})),parents,zIndex+1)+					| otherwise =+						return (False,Nothing,parents,zIndex+1)+				+				getSelectedMenuElementHandle item menuId mods parents zIndex itemH@(SubMenuHandle {mSubSelect=mSubSelect,mSubHandle=mSubHandle,mSubItems=mSubItems})+					| not mSubSelect =+						return (False,Nothing,parents,zIndex+1)+					| otherwise = do+						(found,menuEvent,parents1,_) <- getSelectedMenuElementHandlesItem item menuId mods (parents++[zIndex]) 0 mSubItems+						let parents2 = if found then parents1 else parents+						return (found,menuEvent,parents2,zIndex+1)++				getSelectedMenuElementHandle item menuId mods parents zIndex itemH@(RadioMenuHandle {mRadioSelect=mRadioSelect,mRadioItems=itemHs,mRadioIndex=mRadioIndex})+					| not mRadioSelect =+						return (False,Nothing,parents,zIndex+(length itemHs))+					| otherwise =+						getSelectedMenuElementHandlesItem item menuId mods parents zIndex itemHs						+				+				getSelectedMenuElementHandle item menuId mods parents zIndex (MenuListLSHandle itemHs) = do+					getSelectedMenuElementHandlesItem item menuId mods parents zIndex itemHs					+				+				getSelectedMenuElementHandle item menuId mods parents zIndex (MenuExtendLSHandle exLS itemHs) = do+					getSelectedMenuElementHandlesItem item menuId mods parents zIndex itemHs					+				+				getSelectedMenuElementHandle item menuId mods parents itemNr (MenuChangeLSHandle chLS itemHs) = do+					getSelectedMenuElementHandlesItem item menuId mods parents zIndex itemHs					+				+				getSelectedMenuElementHandle _ _ _ parents zIndex itemH =+					return (False,Nothing,parents,zIndex)+++--	PA: this function is also defined identically in windowevent.+toModifiers :: Int -> Modifiers+toModifiers i+	= Modifiers+		{ shiftDown   = shifton+		, optionDown  = alton+		, commandDown = ctrlon+		, controlDown = ctrlon+		, altDown     = alton+		}+	where+		shifton = (i1 .&. (fromIntegral shiftBIT)) /= 0+		alton   = (i1 .&. (fromIntegral altBIT))   /= 0+		ctrlon  = (i1 .&. (fromIntegral ctrlBIT))  /= 0+		i1      = fromIntegral i :: Int32++--	isToolbarEvent checks whether the toolbar equals the OSDInfo toolbar.+isToolbarEvent :: OSDInfo -> OSWindowPtr -> Bool+isToolbarEvent osdInfo tPtr = +	case getOSDInfoOSToolbar osdInfo of+		Nothing -> False+		Just toolbar -> toolbarPtr toolbar == tPtr	++menuHandlesGetMenuStateHandles :: MenuHandles ps -> ([MenuStateHandle ps],MenuHandles ps)+menuHandlesGetMenuStateHandles mHs@(MenuHandles {mMenus=mMenus})+	= (mMenus,mHs{mMenus=[]})
+ Graphics/UI/ObjectIO/OS/Picture.hs view
@@ -0,0 +1,623 @@+{-# OPTIONS_GHC -#include "cpicture_121.h" #-}++-- #hide+-----------------------------------------------------------------------------+-- Module      :  OS.Picture+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- OS.Picture contains drawing functions and other operations on Pictures.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.Picture+		( Picture(..), Origin, OSPictContext, Pen(..), Graphics.UI.ObjectIO.OS.Font.Font(..)+		, peekOSPictContext+		, pictGetStringWidth, pictGetCharWidth+		, defaultPen, dialogPen, setPenAttribute+		, Draw(..), doDraw, doScreenDraw+		, getPictOrigin, setPictOrigin, getPictPen, setPictPen, setPictPenPos, getPictPenPos+		, movePictPenPos, setPictPenSize, getPictPenSize, setPictPenColour, setPictBackColour +		, getPictPenColour, getPictBackColour, setPictPenFont, getPictPenFont, setPictPenDefaultFont +		, setPictXorMode, setPictHiliteMode, setPictNormalMode, pictDrawPoint+		, pictDrawLine, pictUndrawLine, pictDrawChar, pictUndrawChar, pictDrawString, pictUndrawString +		, pictDrawOval, pictUndrawOval, pictFillOval, pictUnfillOval, pictDrawCurve, pictUndrawCurve +		, pictFillCurve, pictUnfillCurve, pictDrawRect, pictUndrawRect, pictFillRect, pictUnfillRect +		, pictScroll, pictDrawPolygon, pictUndrawPolygon, pictFillPolygon, pictUnfillPolygon, pictGetClipRgn +		, pictSetClipRgn, pictAndClipRgn+		, module Graphics.UI.ObjectIO.StdPictureDef+		, getResolutionC, getPictureScalingFactors+		) where+++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.StdIOBasic+import Graphics.UI.ObjectIO.StdPictureDef+import Graphics.UI.ObjectIO.OS.Types+import Graphics.UI.ObjectIO.OS.Rgn+import Graphics.UI.ObjectIO.OS.Font+import Graphics.UI.ObjectIO.OS.Cutil_12+import Control.Monad(when)++data	Picture+	= Picture+		{ pictContext   :: !OSPictContext	-- The context for drawing operations+		, pictOrigin    :: !Origin		-- The current origin of the picture+		, pictPen       :: !Pen			-- The current state of the pen+		, pictToScreen  :: !Bool		-- Flag: the output goes to screen (True) or printer (False)+		}+		+type	Origin = Point2++data  Pen+	= Pen+		{ penSize       :: !Int			-- The width and height of the pen+  		, penForeColour :: !Colour		-- The drawing colour of the pen+		, penBackColour :: !Colour		-- The background colour of the pen+		, penPos        :: !Point2		-- The pen position in local coordinates+		, penFont       :: !Font		-- The font information to draw text and characters+		}+++iModeNotBic, iModeNotXor, iModeNotOr, iModeNotCopy, iModeBic, iModeXor, iModeOr, iModeCopy :: Int+iModeNotBic	= 7+iModeNotXor	= 6+iModeNotOr	= 5+iModeNotCopy	= 4+iModeBic	= 3+iModeXor	= 2+iModeOr		= 1+iModeCopy	= 0+++pictGetStringWidth :: String -> Draw Int+pictGetStringWidth s = Draw (\picture@(Picture {pictContext=context}) -> do	+	w <- withCString s (\s -> cWinGetPicStringWidth s context)+	return (w, picture))+	+foreign import ccall "cpicture_121.h WinGetPicStringWidth" cWinGetPicStringWidth :: CString -> OSPictContext -> IO Int++pictGetCharWidth :: Char -> Draw Int+pictGetCharWidth c = Draw (\picture@(Picture {pictContext=context}) -> do+	w <- cWinGetPicCharWidth c context+	return (w, picture))+	+foreign import ccall "cpicture_121.h WinGetPicCharWidth" cWinGetPicCharWidth :: Char -> OSPictContext -> IO Int	+		+--	Conversion operations to and from Picture++peekOSPictContext :: Draw OSPictContext+peekOSPictContext = Draw (\picture ->+	return (pictContext picture,picture))+	+defaultPen :: Pen+defaultPen+	= Pen+		{ penSize       = 1+		, penForeColour = black+		, penBackColour = white+		, penPos        = Point2 {x=0,y=0}+		, penFont       = defaultFont+		}++dialogPen :: Pen+dialogPen+	= Pen+		{ penSize       = 1+		, penForeColour = black+		, penBackColour = white+		, penPos        = Point2 {x=0,y=0}+		, penFont       = dialogFont+		}++setPenAttribute :: PenAttribute -> Pen -> Pen+setPenAttribute (PenSize   size)   pen = pen {penSize      =max 1 size}+setPenAttribute (PenPos    pos)    pen = pen {penPos       =pos       }+setPenAttribute (PenColour colour) pen = pen {penForeColour=colour    }+setPenAttribute (PenBack   colour) pen = pen {penBackColour=colour    }+setPenAttribute (PenFont   font)   pen = pen {penFont      =font      }+++-- Drawing monads++-- | While drawing we need the current state called 'Picture' state.+-- The functions that are used for drawing need a 'Picture' state as an argument and return the new updated state.+-- The Draw monad is defined so that it would be easier for the user to write the functions.+-- The Draw monad is in fact an IO monad, but it also takes care of the management of the 'Picture' state.+-- The definition of Draw is abstract.+newtype Draw a = Draw (Picture -> IO (a, Picture))++instance Monad Draw where+   return x = Draw (\pict -> return (x, pict))+   (Draw f) >>= g = Draw (\pict -> do+   	(x, pict) <- f pict+   	let (Draw f2) = g x+   	f2 pict)+   	+instance  Functor Draw where+   fmap f x = x >>= (return . f)++instance IOMonad Draw where+	liftIO f = Draw (\picture -> f >>= \x -> return (x, picture))++doDraw :: Origin -> Pen -> Bool -> OSRgnHandle -> OSPictContext -> Bool -> Draw a -> IO (a, Origin, Pen, Bool)+doDraw origin pen@(Pen {penSize=penSize,penForeColour=penForeColour,penBackColour=penBackColour,penFont=penFont}) isScreenOutput clipRgn context isBuffered (Draw drawf) = do+    let (fname,fstyles,fsize) = osFontGetImp penFont+    withCString fname (\fontname -> winInitPicture+	      penSize+	      iModeCopy+	      (r penForeColour) (g penForeColour) (b penForeColour)+	      (r penBackColour) (g penBackColour) (b penBackColour)+	      fontname+	      fstyles+	      fsize+	      clipRgn+	      isBuffered+	      context)+    (res, picture) <- drawf (Picture+	    { pictContext = context+	    , pictOrigin  = origin+	    , pictPen     = pen+	    , pictToScreen= isScreenOutput	    +	    }+	   )+    winDonePicture context+    return (res, pictOrigin picture,pictPen picture,pictToScreen picture)+foreign import ccall "cpicture_121.h WinInitPicture" winInitPicture :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> CString -> Int -> Int -> OSRgnHandle -> Bool -> OSPictContext -> IO ()+foreign import ccall "cpicture_121.h WinDonePicture" winDonePicture :: OSPictContext -> IO ()+		+doScreenDraw :: Draw x -> IO x+doScreenDraw f = do+	hdc <- winCreateScreenHDC+	(x,_,_,_) <- doDraw zero defaultPen True osNoRgn hdc False f	+	winDestroyScreenHDC hdc+	return x+foreign import ccall "cpicture_121.h WinCreateScreenHDC"  winCreateScreenHDC  :: IO OSPictContext+foreign import ccall "cpicture_121.h WinDestroyScreenHDC" winDestroyScreenHDC :: OSPictContext -> IO ()+++-- Attribute functions.++--	Access to Origin and Pen:+getPictOrigin :: Draw Origin+getPictOrigin = Draw (\picture -> return (pictOrigin picture,picture))++setPictOrigin :: Origin -> Draw ()+setPictOrigin origin = Draw (\picture -> return ((), picture{pictOrigin=origin}))++getPictPen :: Draw Pen+getPictPen = Draw (\picture -> return (pictPen picture,picture))++setPictPen :: Pen -> Draw ()+setPictPen pen = do+	setPictPenSize    (penSize pen)+	setPictPenColour  (penForeColour pen)+	setPictBackColour (penBackColour pen)+	setPictPenPos     (penPos pen)+	setPictPenFont    (penFont pen)+++--	Change the pen position:+setPictPenPos :: Point2 -> Draw ()+setPictPenPos newpos = Draw (\picture@Picture{pictOrigin=origin,pictPen=pen@(Pen {penPos=pos}),pictContext=context} ->+	return ((), picture{pictPen=pen{penPos=newpos}}))++getPictPenPos :: Draw Point2+getPictPenPos = Draw (\picture -> return (penPos (pictPen picture),picture))++movePictPenPos :: Vector2 -> Draw ()+movePictPenPos v@(Vector2{vx=vx,vy=vy}) = Draw (\picture@(Picture{pictPen=pen@(Pen{penPos=Point2{x=x,y=y}}),pictContext=context}) ->+	return ((), picture{pictPen=pen{penPos=Point2{x=x+vx,y=y+vy}}}))++--	Change the pen size:+setPictPenSize :: Int -> Draw ()+setPictPenSize w = Draw (\picture@(Picture {pictContext=context,pictPen=pen}) ->+	let w' = max 1 w+	in  if w' == penSize pen then return ((), picture)+	    else do+		    winSetPenSize w' context		  +		    return ((), picture{pictPen=pen{penSize=w'}}))+		    +foreign import ccall "cpicture_121.h WinSetPenSize" winSetPenSize :: Int -> OSPictContext -> IO ()+++getPictPenSize :: Draw Int+getPictPenSize = Draw (\picture -> return (penSize (pictPen picture),picture))+++--	Change the PenColour:+setPictPenColour :: Colour -> Draw ()+setPictPenColour colour = Draw (\picture@(Picture {pictPen=pen,pictContext=context}) ->	+    if colour == penForeColour pen then return ((), picture)+    else do+	    winSetPenColor (r colour) (g colour) (b colour) context+	    return ((), picture{pictPen=pen{penForeColour=colour}}))+		    +foreign import ccall "cpicture_121.h WinSetPenColor" winSetPenColor :: Int -> Int -> Int -> OSPictContext -> IO ()+	++setPictBackColour :: Colour -> Draw ()+setPictBackColour colour = Draw (\picture@(Picture {pictPen=pen,pictContext=context}) ->+     if colour == penBackColour pen then return ((), picture)+     else do+	     winSetBackColor (r colour) (g colour) (b colour) context+	     return ((), picture{pictPen=pen{penBackColour=colour}}))+	     +foreign import ccall "cpicture_121.h WinSetBackColor" winSetBackColor :: Int -> Int -> Int -> OSPictContext -> IO ()+	++getPictPenColour :: Draw Colour+getPictPenColour = Draw (\picture -> return (penForeColour (pictPen picture), picture))++getPictBackColour :: Draw Colour+getPictBackColour = Draw (\picture -> return (penBackColour (pictPen picture), picture))+++--	Change the font attributes:+setPictPenFont :: Font -> Draw ()+setPictPenFont font = Draw (\picture@(Picture{pictContext=context,pictPen=pen}) ->+	let (fname,fstyles,fsize) = osFontGetImp font+	in+	  if font == penFont pen then return ((), picture)+	  else do+		  withCString fname (\s -> winSetFont s fstyles fsize context)+		  return ((), picture{pictPen=pen{penFont=font}}))+		  +getPictPenFont :: Draw Font+getPictPenFont = Draw (\picture -> return (penFont (pictPen picture),picture))++setPictPenDefaultFont :: Draw ()+setPictPenDefaultFont = Draw (\picture@(Picture{pictContext=context,pictPen=pen}) -> do+	let (fname,fstyles,fsize) = osFontGetImp dialogFont+	withCString fname (\s -> winSetFont s fstyles fsize context)+	return ((), picture{pictPen=pen{penFont=dialogFont}}))+	+foreign import ccall "cpicture_121.h WinSetFont" winSetFont :: CString -> Int -> Int -> OSPictContext -> IO ()+++--	Drawing mode setting functions.++setPictXorMode :: Draw ()+setPictXorMode = Draw (\picture@(Picture {pictContext=context}) -> do+	winSetMode iModeXor context+	return ((), picture))+	+setPictHiliteMode :: Draw ()+setPictHiliteMode = Draw (\picture@(Picture {pictContext=context}) -> do+	winSetMode iModeXor context+	return ((), picture))+	+setPictNormalMode :: Draw ()+setPictNormalMode = Draw (\picture@(Picture {pictContext=context}) -> do+	winSetMode iModeCopy context+	return ((), picture))+	+foreign import ccall "cpicture_121.h WinSetMode" winSetMode :: Int -> OSPictContext -> IO ()+++{-	Point2 drawing operations.+	pictDrawPoint+		only draws a point at that position. The pen position is not changed.+-}+pictDrawPoint :: Point2 -> Draw ()+pictDrawPoint pos = Draw (\picture@(Picture{pictPen=pen,pictOrigin=origin,pictContext=context}) ->+	let psize = penSize pen		+	    Point2 x' y' = (pos-origin)+	in do+	   (if psize==1+	    then winDrawPoint x' y'+	    else winFillRectangle x' y' (x'+psize) (y'+psize)) context+	   return ((), picture))+foreign import ccall "cpicture_121.h WinDrawPoint" winDrawPoint :: Int -> Int -> OSPictContext -> IO ()++{-	Line drawing operations.+	pictDrawLine+		draws a line from the first point to the second point. The pen position+		is not changed.+-}++pictDrawLine :: Point2 -> Point2 -> Draw ()+pictDrawLine a b = Draw (\picture@(Picture {pictContext=context,pictOrigin=origin}) -> do+	let Point2 ax ay = (a-origin)+	let Point2 bx by = (b-origin)+	winDrawLine ax ay bx by context+	return ((), picture))+foreign import ccall "cpicture_121.h WinDrawLine" winDrawLine :: Int -> Int -> Int -> Int -> OSPictContext -> IO ()++pictUndrawLine :: Point2 -> Point2 -> Draw ()+pictUndrawLine a b = Draw (\picture@(Picture {pictContext=context,pictOrigin=origin}) -> do+	let Point2 ax ay = (a-origin)+	let Point2 bx by = (b-origin)+	winUndrawLine ax ay bx by context+	return ((), picture))+foreign import ccall "cpicture_121.h WinUndrawLine" winUndrawLine :: Int -> Int -> Int -> Int -> OSPictContext -> IO ()++{-	Text drawing operations.+	pictDraw(char/string) draws a char/string at the current pen position. The new+		pen position is immediately after the drawn char/string.+-}+pictDrawChar :: Point2 -> Char -> Draw ()+pictDrawChar pos char = Draw (\picture@(Picture {pictContext=context,pictOrigin=origin}) -> do+	let Point2 x y = (pos-origin)+	winDrawChar x y char context+	return ((), picture))	+foreign import ccall "cpicture_121.h WinDrawChar" winDrawChar :: Int -> Int -> Char -> OSPictContext -> IO ()++pictUndrawChar :: Point2 -> Char -> Draw ()+pictUndrawChar pos char = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	let Point2 x y = (pos-origin)+	winUndrawChar x y char context+	return ((), picture))	+foreign import ccall "cpicture_121.h WinUndrawChar" winUndrawChar :: Int -> Int -> Char -> OSPictContext -> IO ()++pictDrawString :: Point2 -> String -> Draw ()+pictDrawString pos string = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	let Point2 x y = (pos-origin)+	withCString string (\s -> winDrawString x y s context)+	return ((), picture))	+foreign import ccall "cpicture_121.h WinDrawString" winDrawString :: Int -> Int -> CString -> OSPictContext -> IO ()++pictUndrawString :: Point2 -> String -> Draw ()+pictUndrawString pos string = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	let Point2 x y = (pos-origin)+	withCString string (\s -> winUndrawString x y s context)+	return ((), picture))+foreign import ccall "cpicture_121.h WinUndrawString" winUndrawString :: Int -> Int -> CString -> OSPictContext -> IO ()+++{-	Oval drawing operations.+	pict(Draw/Fill)oval center oval +		draws/fills an oval at center with horizontal and vertical radius. The new+		pen position is not changed.+-}+pictDrawOval :: Point2 -> Oval -> Draw ()+pictDrawOval center oval = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	let Rect{rleft=l,rtop=t,rright=r,rbottom=b} = ovalToRect (center-origin) oval+	winDrawOval l t r b context+	return ((), picture))+foreign import ccall "cpicture_121.h WinDrawOval" winDrawOval :: Int -> Int -> Int -> Int -> OSPictContext -> IO ()+++pictUndrawOval :: Point2 -> Oval -> Draw ()+pictUndrawOval center oval = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	let Rect{rleft=l,rtop=t,rright=r,rbottom=b} = ovalToRect (center-origin) oval+	winUndrawOval l t r b context+	return ((), picture))+foreign import ccall "cpicture_121.h WinUndrawOval" winUndrawOval :: Int -> Int -> Int -> Int -> OSPictContext -> IO ()+++pictFillOval :: Point2 -> Oval -> Draw ()+pictFillOval center oval = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	let Rect{rleft=l,rtop=t,rright=r,rbottom=b} = ovalToRect (center-origin) oval+	winFillOval l t r b context+	return ((), picture))+foreign import ccall "cpicture_121.h WinFillOval" winFillOval :: Int -> Int -> Int -> Int -> OSPictContext -> IO ()+++pictUnfillOval :: Point2 -> Oval -> Draw ()+pictUnfillOval center oval = Draw (\picture@(Picture{pictContext=context,pictPen=pen,pictOrigin=origin}) -> do+	let Rect{rleft=l,rtop=t,rright=r,rbottom=b} = ovalToRect (center-origin) oval+	winUnfillOval l t r b context+	return ((), picture))+foreign import ccall "cpicture_121.h WinEraseOval" winUnfillOval :: Int -> Int -> Int -> Int -> OSPictContext -> IO ()+++ovalToRect :: Point2 -> Oval -> Rect+ovalToRect (Point2{x=x,y=y}) (Oval{oval_rx=oval_rx,oval_ry=oval_ry}) =+	Rect{rleft=x-rx,rtop=y-ry,rright=x+rx,rbottom=y+ry}+	where+	   rx = abs oval_rx+	   ry = abs oval_ry+++{-	Curve drawing operations.+	pict(Draw/Fill)curve movePen point curve+		draws/fills a curve starting at point with a shape defined by curve. If movePen+		is True, then the new pen position is at the end of the curve, otherwise it does+		not change.+-}+pictDrawCurve :: Point2 -> Curve -> Draw ()+pictDrawCurve start curve = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	let Point2 x y = start-origin+	let oval = curve_oval curve+	winDrawCurve x y (oval_rx oval) (oval_ry oval) (curve_from curve) (curve_to curve) (curve_clockwise curve) context+	return ((), picture))+foreign import ccall "cpicture_121.h WinDrawCurve" winDrawCurve :: Int -> Int -> Int -> Int -> Float -> Float -> Bool -> OSPictContext -> IO ()+++pictUndrawCurve :: Point2 -> Curve -> Draw ()+pictUndrawCurve start curve = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	let Point2 x y = start-origin+	let oval = curve_oval curve+	winUndrawCurve x y (oval_rx oval) (oval_ry oval) (curve_from curve) (curve_to curve) (curve_clockwise curve) context+	return ((), picture))+foreign import ccall "cpicture_121.h WinUndrawCurve" winUndrawCurve :: Int -> Int -> Int -> Int -> Float -> Float -> Bool -> OSPictContext -> IO ()+	++pictFillCurve :: Point2 -> Curve -> Draw ()+pictFillCurve start curve = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	let Point2 x y = start-origin+	let oval = curve_oval curve+	winFillWedge x y (oval_rx oval) (oval_ry oval) (curve_from curve) (curve_to curve) (curve_clockwise curve) context+	return ((), picture))+foreign import ccall "cpicture_121.h WinFillWedge" winFillWedge :: Int -> Int -> Int -> Int -> Float -> Float -> Bool -> OSPictContext -> IO ()+	++pictUnfillCurve :: Point2 -> Curve -> Draw ()+pictUnfillCurve start curve = Draw (\picture@(Picture{pictContext=context,pictPen=pen,pictOrigin=origin}) -> do+	let Point2 x y = start-origin+	let oval = curve_oval curve+	winEraseWedge x y (oval_rx oval) (oval_ry oval) (curve_from curve) (curve_to curve) (curve_clockwise curve) context+	return ((), picture))+foreign import ccall "cpicture_121.h WinEraseWedge" winEraseWedge :: Int -> Int -> Int -> Int -> Float -> Float -> Bool -> OSPictContext -> IO ()+	++{-	Rect drawing operations.+	pict(draw/fill)rect rect+		draws/fills a rect. The pen position is not changed.+-}+pictDrawRect :: Rect -> Draw ()+pictDrawRect rect = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	let (Rect {rleft=l,rtop=t,rright=r,rbottom=b}) = subVector (toVector origin) rect+	winDrawRectangle l t r b context+	return ((), picture))+foreign import ccall "cpicture_121.h WinDrawRectangle" winDrawRectangle :: Int -> Int -> Int -> Int -> OSPictContext -> IO ()++pictUndrawRect :: Rect -> Draw ()+pictUndrawRect rect = Draw (\picture@(Picture{pictContext=context,pictPen=pen,pictOrigin=origin}) -> do+	let (Rect {rleft=l,rtop=t,rright=r,rbottom=b}) = subVector (toVector origin) rect+	winUndrawRectangle l t r b context+	return ((), picture))+foreign import ccall "cpicture_121.h WinUndrawRectangle" winUndrawRectangle :: Int -> Int -> Int -> Int -> OSPictContext -> IO ()+++pictFillRect :: Rect -> Draw ()+pictFillRect rect = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	let (Rect {rleft=l,rtop=t,rright=r,rbottom=b}) = subVector (toVector origin) rect+	winFillRectangle l t r b context+	return ((), picture))+foreign import ccall "cpicture_121.h WinFillRectangle" winFillRectangle :: Int -> Int -> Int -> Int -> OSPictContext -> IO ()++pictUnfillRect :: Rect -> Draw ()+pictUnfillRect rect = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	let (Rect {rleft=l,rtop=t,rright=r,rbottom=b}) = subVector (toVector origin) rect+	winEraseRectangle l t r b context+	return ((), picture))+foreign import ccall "cpicture_121.h WinEraseRectangle" winEraseRectangle :: Int -> Int -> Int -> Int -> OSPictContext -> IO ()++++{-	Scrolling operation (handle with care).+-}+pictScroll :: Rect -> Vector2 -> Draw Rect+pictScroll rect v = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	let (Rect {rleft=l,rtop=t,rright=r,rbottom=b}) = subVector (toVector origin) rect+	let Vector2 vx vy = v+	-- Marshal arguments:+	o1 <- malloc;+	o2 <- malloc;+	o3 <- malloc;+	o4 <- malloc;+	-- Call C:+	winScrollRectangle l t r b vx vy context o1 o2 o3 o4;+	-- Read/free:+	l <- fpeek o1;+	t <- fpeek o2;+	r <- fpeek o3;+	b <- fpeek o4;	+	return (Rect {rleft=l,rtop=t,rright=r,rbottom=b}, picture))+foreign import ccall "cpicture_121.h WinScrollRectangle" winScrollRectangle :: Int -> Int -> Int -> Int -> Int -> Int -> OSPictContext -> Ptr Int -> Ptr Int -> Ptr Int -> Ptr Int -> IO ()++{-	Polygon drawing operations.+	pict(Draw/Fill)polygon point polygon+		draws/fills a polygon starting at point. The pen position is not changed.+-}+pictDrawPolygon :: Point2 -> Polygon -> Draw ()+pictDrawPolygon start (Polygon{polygon_shape=shape}) = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	transferPolygon (start-origin) shape+	winDrawPolygon context+	winEndPolygon+	return ((), picture))+foreign import ccall "cpicture_121.h WinDrawPolygon"   winDrawPolygon   :: OSPictContext -> IO ()++pictUndrawPolygon :: Point2 -> Polygon -> Draw ()+pictUndrawPolygon start (Polygon{polygon_shape=shape}) = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	transferPolygon (start-origin) shape	+	winUndrawPolygon context+	winEndPolygon+	return ((), picture))+foreign import ccall "cpicture_121.h WinUndrawPolygon" winUndrawPolygon :: OSPictContext -> IO ()++pictFillPolygon :: Point2 -> Polygon -> Draw ()+pictFillPolygon start (Polygon{polygon_shape=shape}) = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	transferPolygon (start-origin) shape	+	winFillPolygon context+	winEndPolygon+	return ((), picture))+foreign import ccall "cpicture_121.h WinFillPolygon"   winFillPolygon   :: OSPictContext -> IO ()++pictUnfillPolygon :: Point2 -> Polygon -> Draw ()+pictUnfillPolygon start (Polygon{polygon_shape=shape}) = Draw (\picture@(Picture{pictContext=context,pictOrigin=origin}) -> do+	transferPolygon (start-origin) shape+	winErasePolygon  context+	winEndPolygon+	return ((), picture))+foreign import ccall "cpicture_121.h WinErasePolygon"  winErasePolygon  :: OSPictContext -> IO ()++transferPolygon :: Point2 -> [Vector2] -> IO ()+transferPolygon start vs = do+	winStartPolygon (1 + length vs)+	winAddPolygonPoint x y+	transferShape x y vs+	where+	  Point2 x y = start++	  transferShape :: Int -> Int -> [Vector2] -> IO ()+	  transferShape x y ((Vector2 {vx=vx,vy=vy}):vs) = do+	  	winAddPolygonPoint new_x new_y+	  	transferShape new_x new_y vs+	  	where+	  		new_x = x+vx+	  		new_y = y+vy+	  transferShape _ _ [] = return ()++foreign import ccall "cpicture_121.h WinStartPolygon"    winStartPolygon :: Int -> IO ()+foreign import ccall "cpicture_121.h WinAddPolygonPoint" winAddPolygonPoint :: Int -> Int -> IO ()+foreign import ccall "cpicture_121.h WinEndPolygon"      winEndPolygon :: IO ()++{-	Clipping operations.+	pictGetClipRgn gets the current clipping region.+	pictSetClipRgn sets the given clipping region.+	pictAndClipRgn takes the intersection of the current clipping region and the argument region.+-}+--	Operation to retrieve the current clipping region.+pictGetClipRgn :: Draw OSRgnHandle+pictGetClipRgn = Draw (\picture@(Picture{pictContext=context}) -> do+	clipRgn <- winGetClipRgnPicture context+	return (clipRgn, picture))+foreign import ccall "cpicture_121.h WinGetClipRgnPicture" winGetClipRgnPicture :: OSPictContext -> IO OSRgnHandle++--	Operation to set the complete clipping region.+pictSetClipRgn :: OSRgnHandle -> Draw ()+pictSetClipRgn clipRgn = Draw (\picture@(Picture{pictContext=context}) -> do+	winSetClipRgnPicture clipRgn context+	return ((), picture))+foreign import ccall "cpicture_121.h WinSetClipRgnPicture" winSetClipRgnPicture :: OSRgnHandle -> OSPictContext -> IO ()++--	Operation to set the clipping region.+pictAndClipRgn :: OSRgnHandle -> Draw ()+pictAndClipRgn clipRgn = Draw (\picture@(Picture{pictContext=context}) -> do+	winClipRgnPicture clipRgn context+	return ((), picture))+foreign import ccall "cpicture_121.h WinClipRgnPicture" winClipRgnPicture :: OSRgnHandle -> OSPictContext -> IO ()++getResolutionC :: OSPictContext -> IO (Int, Int)+getResolutionC a1 = do+	o1 <- malloc+	o2 <- malloc+	cgetResolutionC a1 o1 o2+	r1 <- fpeek o1+	r2 <- fpeek o2+	return (r1, r2)++foreign import ccall "cpicture_121.h getResolutionC" cgetResolutionC :: OSPictContext -> Ptr Int -> Ptr Int -> IO ()+++getPictureScalingFactors :: OSPictContext -> IO ((Int, Int), (Int, Int))+getPictureScalingFactors a1 = do+	o1 <- malloc+	o2 <- malloc+	o3 <- malloc+	o4 <- malloc+	cWinGetPictureScaleFactor a1 o1 o2 o3 o4+	r1 <- fpeek o1+	r2 <- fpeek o2+	r3 <- fpeek o3+	r4 <- fpeek o4+	return ((r1, r2), (r3, r4))+	+foreign import ccall "cpicture_121.h WinGetPictureScaleFactor" cWinGetPictureScaleFactor :: OSPictContext -> Ptr Int -> Ptr Int -> Ptr Int -> Ptr Int -> IO ()
+ Graphics/UI/ObjectIO/OS/ProcessEvent.hs view
@@ -0,0 +1,98 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.ProcessEvent+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- OS.ProcessEvent defines the DeviceEventFunction for the process device.+-- This function is placed in a separate module because it is platform dependent.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.ProcessEvent (processEvent) where++++import Graphics.UI.ObjectIO.StdIOCommon+import Graphics.UI.ObjectIO.CommonDef (dumpFatalError)+import Graphics.UI.ObjectIO.Device.Events+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.OS.ClCrossCall_12+import Graphics.UI.ObjectIO.OS.Event+import Graphics.UI.ObjectIO.OS.Types (osNoWindowPtr, OSWindowPtr)+import Graphics.UI.ObjectIO.OS.Cutil_12(int2addr, free)+import Foreign.C.String(peekCString)+++processeventFatalError :: String -> String -> x+processeventFatalError function error+	= dumpFatalError function "ProcessEvent" error+++{-	processEvent filters the scheduler events that can be handled by this process device.+	processEvent assumes that it is not applied to an empty IOSt.+-}++processEvent :: IOSt ps -> SchedulerEvent -> IO (Bool,Maybe DeviceEvent,SchedulerEvent)++processEvent ioState schedulerEvent@(ScheduleOSEvent osEvent@(CrossCallInfo {ccMsg=msg}) _)+	| isProcessOSEvent msg = do+		(myEvent,replyToOS,deviceEvent) <- filterOSEvent osEvent True (ioStGetOSDInfo ioState)+		let schedulerEvent1 =+			if   isJust replyToOS+			then ScheduleOSEvent osEvent (fromJust replyToOS)+			else schedulerEvent+		return (myEvent,deviceEvent,schedulerEvent1)+	| otherwise = return (False,Nothing,schedulerEvent)+	where+		isProcessOSEvent :: Int -> Bool+		isProcessOSEvent msg = msg==ccWmPROCESSCLOSE || msg==ccWmDDEEXECUTE || msg==ccWmPROCESSDROPFILES++processEvent ioState schedulerEvent@(ScheduleMsgEvent _) =+    return (False,Nothing,schedulerEvent)++++{-	filterOSEvent filters the OSEvents that can be handled by this process device.+		This implementation only handles the ccWmPROCESSCLOSE event (ccWmDDEEXECUTE and ccWmPROCESSDROPFILES skipped).+-}+filterOSEvent :: OSEvent -> Bool -> OSDInfo -> IO (Bool,Maybe [Int],Maybe DeviceEvent)++filterOSEvent (CrossCallInfo {ccMsg=msg,p1=p1,p2=p2}) isActive osdInfo+	| msg==ccWmDDEEXECUTE =+		if not isActive+		then return (False,Nothing,Nothing)+		else do+			let txt = int2addr p1+			fName <- peekCString txt+			free txt+			return (True,Nothing,Just (ProcessRequestOpenFiles [fName]))+		+	| msg==ccWmPROCESSCLOSE+		= if   p1==getOSDInfoFramePtr osdInfo+		  then return (True, Nothing,Just ProcessRequestClose)+		  else return (False,Nothing,Nothing)++	| msg==ccWmPROCESSDROPFILES =+		if p1 /= getOSDInfoFramePtr osdInfo+		then return (False,Nothing,Nothing)+		else do+			let txt = int2addr p2+			allNames <- peekCString txt+			free txt			+			let names = filter (not . null) (lines allNames)+			return (True,Nothing,Just (ProcessRequestOpenFiles names))	+	| otherwise+		= processeventFatalError "filterOSEvent" "unmatched OSEvent"+++getOSDInfoFramePtr :: OSDInfo -> OSWindowPtr+getOSDInfoFramePtr osdInfo+	= case getOSDInfoOSInfo osdInfo of+		Just info -> osFrame info+		_         -> osNoWindowPtr
+ Graphics/UI/ObjectIO/OS/ReceiverEvent.hs view
@@ -0,0 +1,46 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.ReceiverEvent+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- OS.ReceiverEvent defines the DeviceEventFunction for the receiver device.+-- This function is placed in a separate module because it is platform dependent.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.ReceiverEvent where++++import Graphics.UI.ObjectIO.Device.Events+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.OS.Event+import Graphics.UI.ObjectIO.Id(IdParent(..))+import Data.IORef(readIORef)+import qualified Data.Map as Map (lookup)++++{-	receiverEvent filters the appropriate events for the receiver device.+	These are only the message events (as long as receivers do not contain timers).+	receiverEvent assumes that it is not applied to an empty IOSt.+	+	Currently, in this implementation only asynchronous message events are supported.+-}++receiverEvent :: IOSt ps -> SchedulerEvent -> IO (Bool,Maybe DeviceEvent,SchedulerEvent)++receiverEvent ioState schedulerEvent@(ScheduleMsgEvent rId) = do+	iocontext <- readIORef (ioStGetContext ioState)+	case Map.lookup rId (ioContextGetIdTable iocontext) of+		Just idParent | idpIOId idParent == ioStGetIOId ioState && idpDevice idParent == ReceiverDevice ->+        		return (True,Just (ReceiverEvent rId),schedulerEvent)+    		_ -> return (False,Nothing,schedulerEvent)++receiverEvent ioState schedulerEvent = return (False,Nothing,schedulerEvent)
+ Graphics/UI/ObjectIO/OS/Rgn.hs view
@@ -0,0 +1,100 @@+{-# OPTIONS_GHC -#include "cpicture_121.h" #-}++-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.Rgn+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- OS.Rgn contains OS operations to manage regions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.Rgn+		( OSRgnHandle+		, osNewRgn, osNewRectRgn, osDisposeRgn, osPolyRgn+		, osSectRgn, osUnionRgn, osDiffRgn, osXorRgn+		, osGetRgnBox, osIsEmptyRgn, osNoRgn+		) where++++import Graphics.UI.ObjectIO.OS.Types+import Graphics.UI.ObjectIO.OS.Cutil_12+import Foreign.Ptr(Ptr(..), nullPtr)+++--	Constants for drawing polygons.+alternate, winding :: Int+alternate	= 1+winding		= 2++--	Region creation and disposal operations.+foreign import ccall "cpicture_121.h WinCreateEmptyRgn" osNewRgn :: IO OSRgnHandle++osNewRectRgn :: Rect -> IO OSRgnHandle+osNewRectRgn (Rect {rleft=l,rtop=t,rright=r,rbottom=b}) = winCreateRectRgn l t r b+foreign import ccall "cpicture_121.h WinCreateRectRgn" winCreateRectRgn :: Int -> Int -> Int -> Int -> IO OSRgnHandle++osPolyRgn :: (Int,Int) -> [(Int,Int)] -> IO OSRgnHandle+osPolyRgn base shape+	= do {		+		if   len==0+		then osNewRgn+		else +		do {+			shapeH <- winAllocPolyShape len;+			setPolyShape shapeH 0 base shape;+			prgn   <- winCreatePolygonRgn shapeH len winding;+			winFreePolyShape shapeH;+			return prgn+		}+	  }+	where+		len = length shape+		+		setPolyShape :: Ptr Int -> Int -> (Int,Int) -> [(Int,Int)] -> IO ()+		setPolyShape shapeH i (x,y) ((vx,vy):vs)+			= winSetPolyPoint i x y shapeH >> setPolyShape shapeH (i+1) (x+vx,y+vy) vs+		setPolyShape _ _ _ _ = return ()+foreign import ccall "cpicture_121.h WinAllocPolyShape" winAllocPolyShape :: Int -> IO (Ptr Int)+foreign import ccall "cpicture_121.h WinSetPolyPoint"   winSetPolyPoint   :: Int -> Int -> Int -> Ptr Int -> IO ()+foreign import ccall "cpicture_121.h WinFreePolyShape"  winFreePolyShape  :: Ptr Int -> IO ()+foreign import ccall "cpicture_121.h WinCreatePolygonRgn" winCreatePolygonRgn :: Ptr Int -> Int -> Int -> IO OSRgnHandle+		+foreign import ccall "cpicture_121.h WinDisposeRgn" osDisposeRgn :: OSRgnHandle -> IO ()+++--	Combining the shapes of two Regions into a new Region.+foreign import ccall "cpicture_121.h WinSectRgn" osSectRgn :: OSRgnHandle -> OSRgnHandle -> IO OSRgnHandle+foreign import ccall "cpicture_121.h WinUnionRgn" osUnionRgn :: OSRgnHandle -> OSRgnHandle -> IO OSRgnHandle+foreign import ccall "cpicture_121.h WinDiffRgn" osDiffRgn :: OSRgnHandle -> OSRgnHandle -> IO OSRgnHandle+foreign import ccall "cpicture_121.h WinXorRgn" osXorRgn :: OSRgnHandle -> OSRgnHandle -> IO OSRgnHandle+++--	Region property access functions.+osGetRgnBox :: OSRgnHandle -> IO (Bool,Rect)+osGetRgnBox rgn = do+	-- Marshal arguments:+	o1 <- malloc+	o2 <- malloc+	o3 <- malloc+	o4 <- malloc+	o5 <- malloc+	-- Call C:+	winGetRgnBox rgn o1 o2 o3 o4 o5+	-- Read/free:+	l <- fpeek o1+	t <- fpeek o2+	r <- fpeek o3+	b <- fpeek o4+    	isRect <- fpeek o5+	return (isRect,Rect {rleft=l,rtop=t,rright=r,rbottom=b})	+foreign import ccall "cpicture_121.h WinGetRgnBox" winGetRgnBox :: OSRgnHandle -> Ptr Int -> Ptr Int -> Ptr Int -> Ptr Int -> Ptr Bool -> IO ()+	+foreign import ccall "cpicture_121.h WinIsEmptyRgn" osIsEmptyRgn :: OSRgnHandle -> IO Bool
+ Graphics/UI/ObjectIO/OS/System.hs view
@@ -0,0 +1,117 @@+{-# OPTIONS_GHC -#include "cCCallWindows_121.h" #-}++-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.System+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- OS.System defines system dependent functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.System where+++import Graphics.UI.ObjectIO.OS.ClCCall_12+import Graphics.UI.ObjectIO.OS.ClCrossCall_12+import Graphics.UI.ObjectIO.OS.DocumentInterface+import Graphics.UI.ObjectIO.OS.Font+import Graphics.UI.ObjectIO.OS.Types(Rect(..))+import Graphics.UI.ObjectIO.OS.WindowCrossCall_12+import Data.Maybe+++data	OSWindowMetrics+	= OSWindowMetrics+		{ osmFont          :: Font		-- The internal Font used in Windows for controls+		, osmFontMetrics   :: (Int,Int,Int)	-- The ascent, descent, leading of osmFont+		, osmHeight        :: Int		-- The height of the internal Font+		, osmHorMargin     :: Int		-- The default horizontal margin+		, osmVerMargin     :: Int		-- The default vertical   margin+		, osmHorItemSpace  :: Int		-- The default horizontal item space+		, osmVerItemSpace  :: Int		-- The default vertical   item space+		, osmHSliderHeight :: Int		-- The default height of a horizontal slider control+		, osmVSliderWidth  :: Int		-- The default width  of a vertical   slider control+		}+++osNewLineChars = "\r\n"					-- OS newline convention++osTicksPerSecond = 1000	:: Int				-- OS max resolution of ticks per second++foreign import ccall "cpicture_121.h OsMMtoHPixels" osMMtoHPixels :: Float -> Int+foreign import ccall "cpicture_121.h OsMMtoVPixels" osMMtoVPixels :: Float -> Int++osMaxScrollWindowSize :: (Int,Int)+osMaxScrollWindowSize = winMaxScrollWindowSize++osMaxFixedWindowSize :: (Int,Int)+osMaxFixedWindowSize = winMaxFixedWindowSize++osScreenRect :: IO Rect+osScreenRect+	= do {+		screenWidth  <- winScreenXSize;+		screenHeight <- winScreenYSize;+		return (Rect {rleft=0,rtop=0,rright=screenWidth,rbottom=screenHeight})+	  }+	  +osPrintSetupTypical :: Bool -- MW11+++osPrintSetupTypical = False++osGetProcessWindowDimensions :: OSDInfo -> IO Rect+osGetProcessWindowDimensions osdinfo+	| isNothing maybeOSInfo+		= osScreenRect+	| otherwise+		= let osinfo = fromJust maybeOSInfo+		  in  do {+		  		(x,y) <- winGetWindowPos  (osFrame  osinfo);+				(w,h) <- winGetClientSize (osClient osinfo);+				return (Rect {rleft=x,rtop=y,rright=x+w,rbottom=y+h})+		      }+	where+		maybeOSInfo = getOSDInfoOSInfo osdinfo++osDefaultWindowMetrics :: IO OSWindowMetrics+osDefaultWindowMetrics+	= do {+		(ascent,descent,leading,_) <- osGetFontMetrics Nothing dialogFont;+		(scrollWidth,scrollHeight) <- winScrollbarSize;+		let+			height              = ascent+descent+leading+			unit                = (fromIntegral height)/8.0+			margin              = round (unit*7.0)+			itemspace           = round (unit*4.0)+		in return (OSWindowMetrics+				{ osmFont          = dialogFont+				, osmFontMetrics   = (ascent,descent,leading)+				, osmHeight        = height+				, osmHorMargin     = margin+				, osmVerMargin     = margin+				, osmHorItemSpace  = itemspace+				, osmVerItemSpace  = itemspace+				, osmHSliderHeight = scrollHeight+				, osmVSliderWidth  = scrollWidth+				}+			  )+	  }++{-	osStripOuterSize isMDI isResizable (width,height)+		returns (dw,dh) required to add/subtract to view size/outer size in order to obtain+		outer size/view size.+-}+osStripOuterSize :: Bool -> Bool -> IO (Int,Int)+osStripOuterSize isMDI isResizable+	| isMDI+		= winMDIClientToOuterSizeDims styleFlags+	| otherwise+		= winSDIClientToOuterSizeDims styleFlags+	where+		styleFlags = if isResizable then ws_THICKFRAME else 0
+ Graphics/UI/ObjectIO/OS/Time.hs view
@@ -0,0 +1,23 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.Time+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.Time where+++type OSTime = Int++osMaxTime :: OSTime+osMaxTime = 2^31-1++foreign import ccall "cCCallSystem_121.h WinGetTickCount" osGetTime ::  IO OSTime+foreign import ccall "cCCallSystem_121.h WinGetBlinkTime" osGetBlinkInterval :: IO Int
+ Graphics/UI/ObjectIO/OS/TimerEvent.hs view
@@ -0,0 +1,71 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.TimerEvent+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.TimerEvent(timerEvent) where++++import	Graphics.UI.ObjectIO.Device.Events+import  Graphics.UI.ObjectIO.Device.SystemState+import	Graphics.UI.ObjectIO.Timer.Access+import	Graphics.UI.ObjectIO.Timer.Table+import	Graphics.UI.ObjectIO.Timer.Handle(TimerHandles(..))+import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.Process.IOState+import  Graphics.UI.ObjectIO.OS.Event+import  Graphics.UI.ObjectIO.OS.Time+import	Graphics.UI.ObjectIO.OS.ClCrossCall_12+import	Graphics.UI.ObjectIO.Id(IdParent(..))+import  Data.IORef+import  Data.Map as Map (lookup)++timerEventFatalError :: String -> String -> x+timerEventFatalError function error = dumpFatalError function "OS.TimerEvent" error+++{-	The timerEvent function determines whether the given SchedulerEvent can be applied+	to a timer of this process. These are the following cases:+	*	ScheduleTimerEvent: the timer event belongs to this process and device+	*	ScheduleMsgEvent:   the message event belongs to this process and device+	timerEvent assumes that it is not applied to an empty IOSt.+-}+timerEvent :: IOSt ps -> SchedulerEvent -> IO (Bool,Maybe DeviceEvent,SchedulerEvent)+timerEvent ioState schedulerEvent = do+	(if not (ioStHasDevice TimerDevice ioState)+	 then timerEventFatalError "timerFunctions.dEvent" "could not retrieve TimerSystemState from IOSt"+	 else timerEvent schedulerEvent)+	where+		timerEvent :: SchedulerEvent -> IO (Bool,Maybe DeviceEvent,SchedulerEvent)+		timerEvent schedulerEvent@(ScheduleOSEvent osEvent@(CrossCallInfo {ccMsg=ccMsg}) _)+			| ccMsg == ccWmIDLETIMER || ccMsg == ccWmTIMER = do+				iocontext <- readIORef (ioStGetContext ioState)+				let tt = ioContextGetTimerTable iocontext+				let t1 = ioContextGetTime iocontext+				t2 <- osGetTime+				let tt1 = shiftTimeInTimerTable (t2-t1) tt+				let (mb_te, tt2) = getActiveTimerInTimerTable tt1+				(case mb_te of+					Just te | tlIOId (teLoc te) == ioStGetIOId ioState -> do+						let iocontext1 = ioContextSetTimerTable tt2 iocontext+						let iocontext2 = ioContextSetTime t2 iocontext1+						writeIORef (ioStGetContext ioState) iocontext2+						return (True, Just (TimerDeviceEvent te),schedulerEvent)+					_ -> return (False,Nothing,schedulerEvent))+			| otherwise = return (False,Nothing,schedulerEvent)++		timerEvent schedulerEvent@(ScheduleMsgEvent rId) = do+			iocontext <- readIORef (ioStGetContext ioState)			+			case Map.lookup rId (ioContextGetIdTable iocontext) of+				Just idParent | idpIOId idParent == ioStGetIOId ioState && idpDevice idParent == TimerDevice ->+					return (True,Just (ReceiverEvent rId),schedulerEvent)+				_ -> return (False,Nothing,schedulerEvent)
+ Graphics/UI/ObjectIO/OS/ToolBar.hs view
@@ -0,0 +1,66 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.ToolBar+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- OS.ToolBar contains operations to add and remove tools.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.ToolBar+		( OSToolbar(..), OSToolbarHandle+		, osDefaultToolbarHeight+		, osCreateToolbar, osCreateBitmapToolbarItem, osCreateToolbarSeparator+		) where++++import Graphics.UI.ObjectIO.OS.Cutil_12(addr2int)+import Graphics.UI.ObjectIO.OS.ClCrossCall_12+import Graphics.UI.ObjectIO.OS.WindowCCall_12+import Graphics.UI.ObjectIO.OS.Types (OSWindowPtr, osNoWindowPtr)+import Graphics.UI.ObjectIO.OS.Bitmap(OSBitmap(..), osGetBitmapSize)+++data	OSToolbar+	= OSToolbar+		{ toolbarPtr    :: !OSToolbarHandle	-- The toolbar of the frame window (zero if no toolbar)+		, toolbarHeight :: !Int			-- The height of the toolbar       (zero if no toolbar)+		}+type	OSToolbarHandle+	= OSWindowPtr++osDefaultToolbarHeight = 16 :: Int			-- The default height of the toolbar+++{-	osCreateToolbar wPtr height+		creates a toolbar in the argument window with the given size of the bitmap images.+		The return Int is the actual height of the toolbar. +-}+osCreateToolbar :: Bool -> OSWindowPtr -> (Int,Int) -> IO (OSToolbarHandle,Int)+osCreateToolbar forMDI hwnd (w,h)+	= do {+		rcci <- issueCleanRequest2 (errorCallback2 "osCreateToolbar") (rq3Cci (if forMDI then ccRqCREATEMDITOOLBAR else ccRqCREATESDITOOLBAR) hwnd w h);+		let msg          = ccMsg rcci+		    tbPtr_Height = if      msg==ccRETURN2 then (p1 rcci,p2 rcci)+		                   else if msg==ccWASQUIT then (osNoWindowPtr,0)+		                   else    error "[osCreateToolbar] expected ccRETURN1 value."+		in  return tbPtr_Height+	  }++osCreateBitmapToolbarItem :: OSToolbarHandle -> OSBitmap -> Int -> IO ()+osCreateBitmapToolbarItem tbPtr osBitmap index = do+	issueCleanRequest2 (errorCallback2 "osCreateBitmapToolbarItem") (rq3Cci ccRqCREATETOOLBARITEM tbPtr (addr2int (bitmapHandle osBitmap)) index)+	return ()+	where+		(w,_)     = osGetBitmapSize    osBitmap++osCreateToolbarSeparator :: OSToolbarHandle -> IO ()+osCreateToolbarSeparator tbPtr+	= issueCleanRequest2 (errorCallback2 "osCreateToolbarSeparator") (rq1Cci ccRqCREATETOOLBARSEPARATOR tbPtr) >> return ()
+ Graphics/UI/ObjectIO/OS/ToolTip.hs view
@@ -0,0 +1,46 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.ToolTip+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Control.Create contains all control creation functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.ToolTip(osRemoveControlToolTip, osAddControlToolTip) where+++--	Operations to add and remove tooltip controls and areas.++{-	Tooltip controls are added and removed by OSaddControlTooltip and OSremoveControlTooltip.+	The first  OSWindowPtr argument identifies the parent window.+	The second OSWindowPtr argument identifies the control.+	The String argument is the tooltip text.+-}++import	Graphics.UI.ObjectIO.OS.ClCrossCall_12+import	Graphics.UI.ObjectIO.OS.Types(OSWindowPtr)+import  Graphics.UI.ObjectIO.OS.Cutil_12(addr2int, newCString, free)++osIgnoreCallback :: CrossCallInfo -> IO CrossCallInfo+osIgnoreCallback _+	= return return0Cci++osAddControlToolTip :: OSWindowPtr -> OSWindowPtr -> String -> IO ()+osAddControlToolTip parentPtr controlPtr tip = do+	textptr <- newCString tip+	let cci = rq3Cci ccRqADDCONTROLTIP parentPtr controlPtr (addr2int textptr)+	issueCleanRequest2 osIgnoreCallback cci+	free textptr+		++osRemoveControlToolTip :: OSWindowPtr -> OSWindowPtr -> IO ()+osRemoveControlToolTip parentPtr controlPtr = do+	issueCleanRequest2 osIgnoreCallback (rq2Cci ccRqDELCONTROLTIP parentPtr controlPtr)+	return ()
+ Graphics/UI/ObjectIO/OS/Types.hs view
@@ -0,0 +1,50 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.Types+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- OS.Types defines standard types for the OS.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.Types where++import Foreign.Ptr++data	Rect					-- A Rect is supposed to be an ordered rectangle with+	= Rect+		{ rleft   :: !Int		-- rleft<=rright && rtop<=rbottom+		, rtop    :: !Int+		, rright  :: !Int+		, rbottom :: !Int+		}+	deriving (Eq)+	+type	OSWindowPtr = Int+osNoWindowPtr = 0 :: OSWindowPtr++type OSRgnHandle = Ptr ()+osNoRgn = nullPtr :: OSRgnHandle++type	OSPictContext = Ptr ()++type OSBmpHandle = Ptr ()++type	OSMenu		= Int+osNoMenu 		= 0 :: OSMenu++type	OSMenuItem	= Int+osNoMenuItem 		= 0 :: OSMenuItem+++data	DelayActivationInfo+	= DelayActivatedWindow    OSWindowPtr			-- the window has become active+	| DelayDeactivatedWindow  OSWindowPtr			-- the window has become inactive+	| DelayActivatedControl   OSWindowPtr OSWindowPtr	-- the control (@2) in window (@1) has become active+	| DelayDeactivatedControl OSWindowPtr OSWindowPtr	-- the control (@2) in window (@1) has become inactive
+ Graphics/UI/ObjectIO/OS/Window.hs view
@@ -0,0 +1,1496 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.Window+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- OS.Window contains OS operations to manage windows and controls.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.Window+		( osControlTitleSpecialChars+                , osMinWindowSize, osMinCompoundSize+                , osGetCompoundContentRect, osGetCompoundHScrollRect, osGetCompoundVScrollRect+                , osGetWindowContentRect, osGetWindowHScrollRect, osGetWindowVScrollRect+                , osGetButtonControlSize, osGetButtonControlHeight+                , osGetTextControlSize,   osGetTextControlHeight+                , osGetEditControlSize,   osGetEditControlHeight+                , osGetPopUpControlSize,  osGetPopUpControlHeight+                , osGetListBoxControlSize, osGetListBoxControlHeight +		, osGetRadioControlItemSize, osGetRadioControlItemHeight+		, osGetCheckControlItemSize, osGetCheckControlItemHeight+		, osGetSliderControlSize+                , osGetButtonControlMinWidth, osGetTextControlMinWidth, osGetEditControlMinWidth+                , osGetPopUpControlMinWidth, osGetListBoxControlMinWidth, osGetRadioControlItemMinWidth+                , osGetCheckControlItemMinWidth, osGetSliderControlMinWidth+                , osCreateDialog, osCreateWindow, osCreateModalDialog+                , OKorCANCEL(..)+                , osCreateRadioControl, osCreateCheckControl, osCreateEmptyPopUpControl, osAddPopUpControlItem+                , osCreateEmptyListBoxControl, osAddListBoxControlItem+                , osCreateSliderControl, osCreateTextControl, osCreateEditControl, osCreateButtonControl+                , osCreateCustomButtonControl, osCreateCustomControl, osCreateCompoundControl+                , Graphics.UI.ObjectIO.OS.Types.DelayActivationInfo(..)+                , osDestroyWindow+                , osDestroyRadioControl, osDestroyCheckControl, osDestroyPopUpControl, osDestroyListBoxControl+                , osDestroySliderControl, osDestroyTextControl, osDestroyEditControl, osDestroyButtonControl+                , osDestroyCustomButtonControl, osDestroyCustomControl, osDestroyCompoundControl+                , osUpdateRadioControl, osUpdateCheckControl, osUpdatePopUpControl, osUpdateSliderControl+                , osUpdateTextControl, osUpdateEditControl, osUpdateButtonControl, osUpdateCompoundControl+                , osUpdateListBoxControl+                , osClipRadioControl, osClipCheckControl, osClipPopUpControl, osClipSliderControl+                , osClipTextControl, osClipEditControl, osClipButtonControl, osClipListBoxControl+                , osClipCustomButtonControl, osClipCustomControl, osClipCompoundControl+                , osGrabControlPictContext, osGrabWindowPictContext, osReleaseControlPictContext, osReleaseWindowPictContext+                , toOSscrollbarRange, fromOSscrollbarRange, osScrollbarIsVisible, osScrollbarsAreVisible+                , osSetWindowSliderThumb, osSetWindowSliderThumbSize, osSetWindowSlider+                , osInvalidateWindow, osInvalidateWindowRect, osValidateWindowRect, osValidateWindowRgn+                , osDisableWindow, osEnableWindow+                , osActivateWindow, osActivateControl+                , osStackWindow+                , osHideWindow, osShowWindow+                , osSetWindowCursor+                , osGetWindowPos, osGetWindowViewFrameSize, osGetWindowSize+                , osSetWindowPos, osSetWindowViewFrameSize, osSetWindowSize+                , osSetWindowTitle+                , osCreateCaret, osSetCaretPos, osDestroyCaret+                , osInvalidateCompound, osInvalidateCompoundRect, osSetCompoundSliderThumb+                , osSetCompoundSliderThumbSize, osSetCompoundSlider, osSetCompoundSelect+                , osSetCompoundShow, osSetCompoundPos, osSetCompoundSize, osCompoundMovesControls+		, osSetSliderThumb, osSetSliderControlSelect, osSetSliderControlShow+		, osSetSliderControlPos, osSetSliderControlSize+                , osCheckRadioControl, osSetRadioControlSelect, osSetRadioControlShow+                , osSetRadioControlPos, osSetRadioControlSize+                , osCheckCheckControl, osSetCheckControlSelect, osSetCheckControlShow+		, osSetCheckControlShow, osSetCheckControlPos, osSetCheckControlSize+		, osSetPopUpControlSize, osSetPopUpControlPos, osSetPopUpControlShow+		, osSetPopUpControlSelect, osSelectPopUpControlItem+		, osSelectListBoxControlItem, osMarkListBoxControlItem, osSetListBoxControlSelect+		, osSetListBoxControlShow, osSetListBoxControlPos, osSetListBoxControlSize+                , osSetEditControlText, osGetEditControlText, osSetEditControlCursor, osSetEditControlSelect+                , osSetEditControlShow, osSetEditControlPos, osSetEditControlSize+                , osSetTextControlText, osSetTextControlSelect, osSetTextControlShow, osSetTextControlPos, osSetTextControlSize+                , osSetButtonControlText, osSetButtonControlSelect, osSetButtonControlShow, osSetButtonControlPos, osSetButtonControlSize+                , osSetCustomButtonControlSelect, osSetCustomButtonControlShow, osSetCustomButtonControlPos, osSetCustomButtonControlSize+                , osSetCustomControlSelect, osSetCustomControlShow, osSetCustomControlPos, osSetCustomControlSize+                , Graphics.UI.ObjectIO.OS.System.OSWindowMetrics(..), ScrollbarInfo(..)+                ) where++++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Window.Handle+import Graphics.UI.ObjectIO.OS.ClCCall_12+import Graphics.UI.ObjectIO.OS.ClCrossCall_12+import Graphics.UI.ObjectIO.OS.Cutil_12(addr2int, int2addr, newCString, free, nullPtr)+import Graphics.UI.ObjectIO.OS.DocumentInterface+import Graphics.UI.ObjectIO.OS.Event+import Graphics.UI.ObjectIO.OS.Font+import Graphics.UI.ObjectIO.OS.Picture+import Graphics.UI.ObjectIO.OS.Rgn+import Graphics.UI.ObjectIO.OS.System+import Graphics.UI.ObjectIO.OS.Types+import Graphics.UI.ObjectIO.OS.WindowCCall_12+import Graphics.UI.ObjectIO.OS.WindowCrossCall_12+import Foreign.Marshal.Utils(fromBool)+import Data.Word+import Data.Bits++oswindowFatalError :: String -> String -> x+oswindowFatalError function error+	= dumpFatalError function "OSWindow" error+++{-	System dependent constants:+-}+osControlTitleSpecialChars :: [Char]+osControlTitleSpecialChars = []		-- Special prefix characters that should be removed+++{-	System dependent metrics:+-}++osMinWindowSize :: (Int,Int)+osMinWindowSize = winMinimumWinSize++osMinCompoundSize :: (Int,Int)+osMinCompoundSize = (0,0)		-- PA: (0,0)<--WinMinimumWinSize (Check if this safe)+++{-	Window frame dimensions: (PA: were defined as constants in windowvalidate. Moved here.)+-}++osWindowFrameWidth     :: Int+osWindowFrameWidth     = 0++osWindowTitleBarHeight :: Int+osWindowTitleBarHeight = 0+++--	Calculating the view frame of window/compound with visibility of scrollbars.++osGetCompoundContentRect :: OSWindowMetrics -> (Bool,Bool) -> Rect -> Rect+osGetCompoundContentRect (OSWindowMetrics {osmHSliderHeight=hSliderHeight,osmVSliderWidth=vSliderWidth}) (visHScroll,visVScroll) itemRect@(Rect{rright=rright,rbottom=rbottom})+	| visHScroll && visVScroll	= itemRect{rright=r,rbottom=b}+	| visHScroll			= itemRect{rbottom=b}+	| visVScroll			= itemRect{rright=r}+	| otherwise			= itemRect+	where+		r	= rright -vSliderWidth+		b	= rbottom-hSliderHeight++osGetCompoundHScrollRect :: OSWindowMetrics -> (Bool,Bool) -> Rect -> Rect+osGetCompoundHScrollRect (OSWindowMetrics {osmHSliderHeight=hSliderHeight,osmVSliderWidth=vSliderWidth}) (visHScroll,visVScroll) itemRect@(Rect{rright=rright,rbottom=rbottom})+	| not visHScroll	= zero+	| otherwise		= itemRect{rtop=b,rright=if visVScroll then r else rright}+	where+		r	= rright -vSliderWidth+		b	= rbottom-hSliderHeight++osGetCompoundVScrollRect :: OSWindowMetrics -> (Bool,Bool) -> Rect -> Rect+osGetCompoundVScrollRect (OSWindowMetrics {osmHSliderHeight=hSliderHeight,osmVSliderWidth=vSliderWidth}) (visHScroll,visVScroll) itemRect@(Rect{rright=rright,rbottom=rbottom})+	| not visVScroll	= zero+	| otherwise		= itemRect{rleft=r,rbottom=if visHScroll then b else rbottom}+	where+		r	= rright -vSliderWidth+		b	= rbottom-hSliderHeight+++osGetWindowContentRect :: OSWindowMetrics -> (Bool,Bool) -> Rect -> Rect+osGetWindowContentRect (OSWindowMetrics {osmHSliderHeight=hSliderHeight,osmVSliderWidth=vSliderWidth}) (visHScroll,visVScroll) itemRect@(Rect{rright=rright,rbottom=rbottom})+	| visHScroll && visVScroll	= itemRect{rright=r,rbottom=b}+	| visHScroll			= itemRect{rbottom=b}+	| visVScroll			= itemRect{rright=r}+	| otherwise			= itemRect+	where+		r	= rright -vSliderWidth+		b	= rbottom-hSliderHeight++osGetWindowHScrollRect :: OSWindowMetrics -> (Bool,Bool) -> Rect -> Rect+osGetWindowHScrollRect (OSWindowMetrics {osmHSliderHeight=hSliderHeight,osmVSliderWidth=vSliderWidth}) (visHScroll,visVScroll) itemRect@(Rect{rleft=rleft,rright=rright,rbottom=rbottom})+	| not visHScroll	= zero+	| otherwise		= Rect{rleft=rleft-1,rtop=b,rright=if visVScroll then r+1 else rright+1,rbottom=rbottom+1}+	where+		r	= rright -vSliderWidth  + 1+		b	= rbottom-hSliderHeight + 1++osGetWindowVScrollRect :: OSWindowMetrics -> (Bool,Bool) -> Rect -> Rect+osGetWindowVScrollRect (OSWindowMetrics {osmHSliderHeight=hSliderHeight,osmVSliderWidth=vSliderWidth}) (visHScroll,visVScroll) itemRect@(Rect{rtop=rtop,rright=rright,rbottom=rbottom})+	| not visVScroll	= zero+	| otherwise		= Rect{rleft=r,rtop=rtop-1,rright=rright+1,rbottom=if visHScroll then b+1 else rbottom+1}+	where+		r	= rright -vSliderWidth  + 1+		b	= rbottom-hSliderHeight + 1+++{-	Determine the size of controls.+-}+osGetButtonControlSize :: OSWindowMetrics -> String -> IO (Int,Int)+osGetButtonControlSize wMetrics text+	= do {+		[width] <- osGetFontStringWidths Nothing [text] (osmFont wMetrics);+		return (2*osmHeight wMetrics+width,osGetButtonControlHeight wMetrics)+	  }++osGetButtonControlHeight :: OSWindowMetrics -> Int+osGetButtonControlHeight wMetrics = 2*osmHeight wMetrics++osGetTextControlSize :: OSWindowMetrics -> String -> IO (Int,Int)+osGetTextControlSize wMetrics text+	= do {+		widths <- osGetFontStringWidths Nothing [text] (osmFont wMetrics);+		return (head widths+round ((fromIntegral (osmHeight wMetrics))/4.0),osGetTextControlHeight wMetrics)+	  }++osGetTextControlHeight :: OSWindowMetrics -> Int+osGetTextControlHeight (OSWindowMetrics {osmHeight=osmHeight}) = osmHeight+round ((fromIntegral osmHeight)/2)++osGetEditControlSize :: OSWindowMetrics -> Int -> Int -> IO (Int,Int)+osGetEditControlSize wMetrics width nrlines+	= return (width,osGetEditControlHeight wMetrics nrlines)++osGetEditControlHeight :: OSWindowMetrics -> Int -> Int+osGetEditControlHeight (OSWindowMetrics {osmHeight=osmHeight}) nrlines = round ((fromIntegral osmHeight)/2.0)+osmHeight*nrlines++osGetPopUpControlSize :: OSWindowMetrics -> [String] -> IO (Int,Int)+osGetPopUpControlSize wMetrics@(OSWindowMetrics{osmFont=osmFont,osmHeight=osmHeight}) items = do+	widths <- osGetFontStringWidths Nothing items osmFont+	return ((maximum widths)+2*osmHeight+(round ((fromIntegral osmHeight)/2)), osGetPopUpControlHeight wMetrics)++osGetPopUpControlHeight :: OSWindowMetrics -> Int+osGetPopUpControlHeight (OSWindowMetrics{osmHeight=osmHeight}) = osmHeight+(round ((fromIntegral osmHeight)/2))+2++osGetListBoxControlSize :: OSWindowMetrics -> NrLines -> [String] -> IO (Int,Int)+osGetListBoxControlSize wMetrics@(OSWindowMetrics{osmFont=osmFont,osmHeight=osmHeight}) nrLines items = do+	widths <- osGetFontStringWidths Nothing items osmFont+	return ((maximum widths)+2*osmHeight+(round ((fromIntegral osmHeight)/2)), osGetListBoxControlHeight wMetrics nrLines)+	+osGetListBoxControlHeight :: OSWindowMetrics -> NrLines -> Int+osGetListBoxControlHeight (OSWindowMetrics{osmHeight=osmHeight}) nrLines = (osmHeight+(round ((fromIntegral osmHeight)/2))+2)*nrLines++osGetRadioControlItemSize :: OSWindowMetrics -> String -> IO (Int,Int)+osGetRadioControlItemSize wMetrics@(OSWindowMetrics{osmFont=osmFont,osmHeight=osmHeight}) text = do+	widths <- osGetFontStringWidths Nothing [text] osmFont+	return (head widths+2*osmHeight+(round ((fromIntegral osmHeight)/2)),osGetRadioControlItemHeight wMetrics)++osGetRadioControlItemHeight :: OSWindowMetrics -> Int+osGetRadioControlItemHeight (OSWindowMetrics{osmHeight=osmHeight}) = osmHeight+round ((fromIntegral osmHeight)/2)++osGetCheckControlItemSize :: OSWindowMetrics -> String -> IO (Int,Int)+osGetCheckControlItemSize wMetrics@(OSWindowMetrics{osmFont=osmFont,osmHeight=osmHeight}) text = do+	widths <- osGetFontStringWidths Nothing [text] osmFont+	return (head widths+2*osmHeight+(round ((fromIntegral osmHeight)/2)),osGetCheckControlItemHeight wMetrics)++osGetCheckControlItemHeight :: OSWindowMetrics -> Int+osGetCheckControlItemHeight (OSWindowMetrics{osmHeight=osmHeight}) = osmHeight+round ((fromIntegral osmHeight)/2)++osGetSliderControlSize :: OSWindowMetrics -> Bool -> Int -> (Int,Int)+osGetSliderControlSize wMetrics isHorizontal length+	| isHorizontal	= (length,osmHSliderHeight wMetrics)+	| otherwise	= (osmVSliderWidth wMetrics,length)+++{-	Determine the minimum width of controls. -}+osGetButtonControlMinWidth :: OSWindowMetrics -> Int+osGetButtonControlMinWidth (OSWindowMetrics {osmHeight=osmHeight}) = 2*osmHeight++osGetTextControlMinWidth :: OSWindowMetrics -> Int+osGetTextControlMinWidth (OSWindowMetrics {osmHeight=osmHeight}) = round ((fromIntegral osmHeight)/4.0)++osGetEditControlMinWidth :: OSWindowMetrics -> Int+osGetEditControlMinWidth _ = 0++osGetPopUpControlMinWidth :: OSWindowMetrics -> Int+osGetPopUpControlMinWidth (OSWindowMetrics {osmHeight=osmHeight}) = 2*osmHeight+(round ((fromIntegral osmHeight)/2))++osGetListBoxControlMinWidth :: OSWindowMetrics -> Int+osGetListBoxControlMinWidth (OSWindowMetrics {osmHeight=osmHeight}) = 2*osmHeight+(round ((fromIntegral osmHeight)/2))++osGetRadioControlItemMinWidth :: OSWindowMetrics -> Int+osGetRadioControlItemMinWidth (OSWindowMetrics {osmHeight=osmHeight}) = 2*osmHeight+(round ((fromIntegral osmHeight)/2))++osGetCheckControlItemMinWidth :: OSWindowMetrics -> Int+osGetCheckControlItemMinWidth (OSWindowMetrics {osmHeight=osmHeight}) = 2*osmHeight+(round ((fromIntegral osmHeight)/2))++osGetSliderControlMinWidth :: OSWindowMetrics -> Int+osGetSliderControlMinWidth _ = 0+++{-	Window creation functions. -}+osCreateDialog :: Bool -> Bool -> String -> (Int,Int) -> (Int,Int) -> OSWindowPtr+               -> (s -> OSWindowPtr)+               -> (OSWindowPtr -> s -> IO s)+               -> (OSWindowPtr -> OSWindowPtr -> OSPictContext -> s -> IO s)+               -> OSDInfo -> s+               -> IO ([DelayActivationInfo],OSWindowPtr,s)+osCreateDialog isModal isClosable title pos size behindptr get_focus create_controls update_controls osdinfo control_info+	= do {+		textptr      <- newCString title;+		let createcci = rq4Cci ccRqCREATEDIALOG (addr2int textptr) parentptr behindptr (fromBool isModal)+		in+		do {+			(returncci,(control_info1,delay_info))+			     <- issueCleanRequest (osCreateDialogCallback get_focus create_controls update_controls)+			                          createcci+			                          (control_info,[]);+			free textptr;+			let msg  = ccMsg returncci+			    wptr = if      msg==ccRETURN1 then p1 returncci+			           else if msg==ccWASQUIT then osNoWindowPtr+			           else                        oswindowCreateError 1 "osCreateDialog"+			in  return (reverse delay_info,wptr,control_info1)+		}+	  }+	where+		parentptr = case getOSDInfoOSInfo osdinfo of+		                Nothing   -> 0+		                Just info -> osFrame info++		osCreateDialogCallback :: (s -> OSWindowPtr)+		                       -> (OSWindowPtr -> s -> IO s)+		                       -> (OSWindowPtr -> OSWindowPtr -> OSPictContext -> s -> IO s)+		                       -> CrossCallInfo+		                       -> (s,[DelayActivationInfo])+		                       -> IO (CrossCallInfo,(s,[DelayActivationInfo]))+		osCreateDialogCallback get_focus create_controls update_controls cci s@(control_info,delay_info)+			| msg==ccWmPAINT+				= winFakePaint (p1 cci) >> return (return0Cci, s)+			| msg==ccWmACTIVATE+				= return (return0Cci, (control_info,(DelayActivatedWindow (p1 cci)):delay_info))+			| msg==ccWmDEACTIVATE+				= return (return0Cci, (control_info,(DelayDeactivatedWindow (p1 cci)):delay_info))+			| msg==ccWmINITDIALOG+				= do {+					control_info1 <- create_controls (p1 cci) control_info;+					let defhandle = get_focus control_info1+					    (x,y)     = pos+					    (w,h)     = size+					    r5cci     = return5Cci x y w h defhandle+					in  return (r5cci, (control_info1,delay_info))+				  }+			| msg==ccWmDRAWCONTROL+				= do {+					control_info1 <- update_controls (p1 cci) (p2 cci) (int2addr (p3 cci)) control_info;+					return (return0Cci, (control_info1,delay_info))+				  }+			| msg==ccWmKEYBOARD || msg==ccWmSETFOCUS || msg==ccWmKILLFOCUS+				= return (return0Cci, s)+			| otherwise+				= oswindowFatalError "osCreateDialogCallback" ("unknown message type ("++show msg++")")+			where+				msg = ccMsg cci++++osCreateWindow :: OSWindowMetrics -> Bool -> ScrollbarInfo -> ScrollbarInfo ->+				  (Int,Int) -> (Int,Int) -> Bool -> String -> (Int,Int) -> (Int,Int) ->+				  (s->OSWindowPtr) ->+				  (OSWindowPtr -> s -> IO s) ->+				  (OSWindowPtr -> OSWindowPtr -> OSPictContext -> s -> IO s) ->+				  OSDInfo -> OSWindowPtr -> s ->+			   	  IO ([DelayActivationInfo],OSWindowPtr,OSWindowPtr,OSWindowPtr,OSDInfo,s)+osCreateWindow	wMetrics isResizable hInfo@(ScrollbarInfo {cbiHasScroll=hasHScroll}) vInfo@(ScrollbarInfo {cbiHasScroll=hasVScroll}) minSize maxSize+				isClosable title pos size+				get_focus+				create_controls+				update_controls+				osdInfo behindPtr control_info+	| di==MDI =+		do+		   textPtr <- newCString title+		   let styleFlags = ws_SYSMENU+		  		  + ws_OVERLAPPED+		  		  + (if hasHScroll then ws_HSCROLL else 0)+		  		  + (if hasVScroll then ws_VSCROLL else 0)+		  		  + (if isResizable then ws_THICKFRAME else 0)+		       createcci = rq6Cci ccRqCREATEMDIDOCWINDOW (addr2int textPtr) (osClient osinfo) behindPtr pos' size' styleFlags+		   (returncci,(control_info,delay_info)) <-+						issueCleanRequest (osCreateWindowCallback isResizable minSize maxSize create_controls update_controls)+											createcci+											(control_info,[])+		   free textPtr+		   let msg  = ccMsg returncci+		       wPtr = if      msg==ccRETURN1 then p1 returncci+		   	      else if msg==ccWASQUIT then osNoWindowPtr+			      else                        oswindowCreateError 1 "osCreateWindow (MDI)"+		   setScrollRangeAndPos hasHScroll False wMetrics sb_HORZ (cbiState hInfo) (0,0) wPtr+		   setScrollRangeAndPos hasVScroll False wMetrics sb_VERT (cbiState vInfo) (0,0) wPtr+		   return (reverse delay_info,wPtr,osNoWindowPtr,osNoWindowPtr,osdInfo,control_info)++	| di==SDI =+		do+		   let styleFlags = (if hasHScroll then ws_HSCROLL else 0) + (if hasVScroll then ws_VSCROLL else 0)+		       createcci  = rq6Cci ccRqCREATESDIDOCWINDOW 0 (osFrame osinfo) pos' (fst size) (snd size) styleFlags+		   (returncci,(control_info,delay_info)) <-+						issueCleanRequest (osCreateWindowCallback isResizable minSize maxSize create_controls update_controls)+											createcci+											(control_info,[])+		   let msg  = ccMsg returncci+		       clientPtr = if      msg==ccRETURN1 then p1 returncci+		   	       	   else if msg==ccWASQUIT then osNoWindowPtr+			      	   else                        oswindowCreateError 1 "osCreateWindow (SDI)"+		       osdInfo1 = setOSDInfoOSInfo osinfo{osClient=clientPtr} osdInfo+		   setScrollRangeAndPos hasHScroll True wMetrics sb_HORZ (cbiState hInfo) (0,0) clientPtr+		   setScrollRangeAndPos hasVScroll True wMetrics sb_VERT (cbiState vInfo) (0,0) clientPtr+		   osSetWindowTitle (osFrame osinfo) title+		   return (reverse delay_info,clientPtr,osNoWindowPtr,osNoWindowPtr,osdInfo1,control_info)++	| otherwise+		= oswindowFatalError "osCreateWindow" "unexpected OSDInfo (OSNoInfo) argument"+	where+		pos'	= pack pos	-- packed into one 32-bit integer+		size'	= pack size+		di	= getOSDInfoDocumentInterface osdInfo+		osinfo	= fromJust (getOSDInfoOSInfo  osdInfo)++		pack (x,y) = fromIntegral ((shiftL (fromIntegral x) 16 .|. ((fromIntegral y) .&. 0xFFFF)) :: Word32)+++osCreateWindowCallback :: Bool -> (Int,Int) -> (Int,Int) ->+				(OSWindowPtr -> s -> IO s) ->+				(OSWindowPtr -> OSWindowPtr -> OSPictContext -> s -> IO s) ->+				CrossCallInfo -> (s,[DelayActivationInfo]) ->+				IO (CrossCallInfo,(s,[DelayActivationInfo]))+osCreateWindowCallback _ _ _ createControls updateControls (CrossCallInfo {ccMsg=msg,p1=hwnd,p2=p2,p3=p3}) s@(control_info,delay_info)+	| msg == ccWmPAINT = do+	      hdc <- winBeginPaint hwnd+	      winEndPaint hwnd hdc+	      return (return0Cci, s)+	| msg == ccWmACTIVATE =+	      return (return0Cci, (control_info,DelayActivatedWindow hwnd:delay_info))+	| msg == ccWmDEACTIVATE =+	      return (return0Cci, (control_info,DelayDeactivatedWindow hwnd:delay_info))+	| msg == ccWmCREATE = do+	      control_info <- createControls hwnd control_info+	      return (return0Cci, (control_info,delay_info))+	| msg == ccWmNEWHTHUMB =+	      return (return0Cci, s)+	| msg == ccWmNEWVTHUMB =+	      return (return0Cci, s)+	| msg == ccWmSIZE =+	      return (return0Cci, s)+	| msg == ccWmDRAWCONTROL = do+	      control_info1 <- updateControls hwnd p2 (int2addr p3) control_info+	      return (return0Cci, (control_info1,delay_info))+	| msg == ccWmKILLFOCUS =+	      return (return0Cci, s)+	| msg == ccWmKEYBOARD =+	      return (return0Cci, s)+	| otherwise =+	      oswindowFatalError "osCreateWindowCallback" ("unknown message type (" ++ show msg ++")")+++{-	PA: new function that creates modal dialog and handles events until termination. +		The Bool result is True iff no error occurred. +-}+osCreateModalDialog :: Bool -> String -> OSDInfo -> Maybe OSWindowPtr -> (OSEvent -> IO [Int]) -> IO Bool+osCreateModalDialog isClosable title osdinfo currentActiveModal handleOSEvents = do+	textPtr <- newCString title+	let createcci = rq2Cci ccRqCREATEMODALDIALOG (addr2int textPtr) parentPtr+	returncci <- issueCleanRequest2 (osCreateModalDialogCallback handleOSEvents) createcci+	free textPtr+	return (if ccMsg returncci == ccRETURN1 then p1 returncci==0 else+		if ccMsg returncci == ccWASQUIT then True	      else+						     oswindowCreateError 1 "osCreateModalDialog")+	where+		parentPtr =+			case currentActiveModal of+				Nothing -> (case (getOSDInfoOSInfo osdinfo) of+						Just info -> osFrame info+						Nothing   -> 0+					)+				Just _  -> 0+	+		osCreateModalDialogCallback :: (OSEvent -> IO [Int]) -> CrossCallInfo -> IO CrossCallInfo+		osCreateModalDialogCallback handleOSEvents osEvent = do+			replyToOS <- handleOSEvents osEvent+			return (setReplyInOSEvent replyToOS)+++-- Window caret++osCreateCaret  = winCreateCaret+osSetCaretPos  = winSetCaretPos+osDestroyCaret = winDestroyCaret++--	Control creation functions.++oswindowCreateError :: Int -> String -> x+oswindowCreateError arity function+	= oswindowFatalError function ("Expected ccRETURN"++show arity++" value")++osIgnoreCallback :: CrossCallInfo -> IO CrossCallInfo+osIgnoreCallback ccinfo+	| ccMsg ccinfo==ccWmPAINT+		= winFakePaint (p1 ccinfo) >> return return0Cci+	| otherwise+		= return return0Cci++osIgnoreCallback' :: CrossCallInfo -> [DelayActivationInfo] -> IO (CrossCallInfo,[DelayActivationInfo])+osIgnoreCallback' ccinfo delayinfo+	| msg==ccWmPAINT+		= winFakePaint (p1 ccinfo) >> return (return0Cci,delayinfo)+	| msg==ccWmACTIVATE+		= return (return0Cci,(DelayActivatedWindow (p1 ccinfo)):delayinfo)+	| msg==ccWmDEACTIVATE+		= return (return0Cci,(DelayDeactivatedWindow (p1 ccinfo)):delayinfo)+	| otherwise+		= return (return0Cci,delayinfo)+	where+		msg = ccMsg ccinfo+++{-	OKorCANCEL type is used to tell Windows that a (Custom)ButtonControl is+	the OK, CANCEL, or normal button.+-}+data	OKorCANCEL+	= OK | CANCEL | NORMAL+	deriving (Show)++ok_toInt OK     = isOKBUTTON+ok_toInt CANCEL = isCANCELBUTTON+ok_toInt NORMAL = isNORMALBUTTON++osCreateSliderControl :: OSWindowPtr -> (Int,Int) -> Bool -> Bool -> Bool -> (Int,Int) -> (Int,Int) -> (Int,Int,Int,Int) -> IO OSWindowPtr+osCreateSliderControl parentWindow parentPos show able horizontal (x',y') (w,h) (min,thumb,max,thumbSize)+	= do {+		returncci <- issueCleanRequest2 osIgnoreCallback createcci;+		let msg = ccMsg returncci+	  	    sliderPtr = if      msg == ccRETURN1 then p1 returncci+	  		       	else if msg == ccWASQUIT then osNoWindowPtr+			    	else 		     	 oswindowCreateError 1 "osCreateSliderControl"+		in+		do {+			winSetScrollRange sliderPtr sb_CTL min max False;+			winSetScrollPos   sliderPtr sb_CTL thumb (x+w) (y+h) (if horizontal then h else w);+			winEnableControl  sliderPtr able;+			winShowControl	  sliderPtr show;+			return sliderPtr+		}+	}+	where+		(x,y)	  	= (x'-fst parentPos,y'-snd parentPos)+		nisHorizontal 	= if horizontal then 1 else 0+	    	createcci	= rq6Cci ccRqCREATESCROLLBAR parentWindow x y w h nisHorizontal++osCreateTextControl :: OSWindowPtr -> (Int,Int) -> String -> Bool -> (Int,Int) -> (Int,Int) -> IO OSWindowPtr+osCreateTextControl parentWindow parentPos text show (x,y) (w,h)+	= do {+		returncci <- issueCleanRequest2 osIgnoreCallback createcci;+		let msg     = ccMsg returncci+		    textPtr = if      msg==ccRETURN1  then p1 returncci+		              else if msg==ccWASQUIT then osNoWindowPtr+		              else                        oswindowCreateError 1 "osCreateTextControl"+		in+		do {+			winSetWindowTitle textPtr text;+			winShowControl    textPtr show;+			return textPtr+		}+	  }+	where+		createcci = rq5Cci ccRqCREATESTATICTXT parentWindow (x-fst parentPos) (y-snd parentPos) w h++osCreateEditControl :: OSWindowPtr -> (Int,Int) -> String -> Bool -> Bool -> Bool -> (Int,Int) -> (Int,Int) -> IO OSWindowPtr+osCreateEditControl parentWindow parentPos text visible able isKeySensitive (x,y) (w,h)+	= do {+		wMetrics           <- osDefaultWindowMetrics;+		let nrLines         = round ((fromIntegral (h-osmHeight wMetrics))/(fromIntegral (osmHeight wMetrics)))+		    isMultiLine     = nrLines>1+		    editflags       = (if isMultiLine then editISMULTILINE else 0) + (if isKeySensitive then editISKEYSENSITIVE else 0)+		    createcci       = rq6Cci ccRqCREATEEDITTXT parentWindow (x-fst parentPos) (y-snd parentPos) w h editflags+		in+		do {+			returncci  <- issueCleanRequest2 osIgnoreCallback createcci;+			let msg     = ccMsg returncci+			    editPtr = if      msg==ccRETURN1 then p1 returncci+			              else if msg==ccWASQUIT then osNoWindowPtr+			              else                        oswindowCreateError 1 "osCreateEditControl"+			in+			do {+				winSetWindowTitle editPtr text;+				winEnableControl  editPtr able;+				winShowControl    editPtr visible;+				return editPtr+			}+		}+	  }+++osCreateButtonControl :: OSWindowPtr -> (Int,Int) -> String -> Bool -> Bool -> (Int,Int) -> (Int,Int) -> OKorCANCEL -> IO OSWindowPtr+osCreateButtonControl parentWindow parentPos title show able (x,y) (w,h) okOrCancel+	= do {+		returncci    <- issueCleanRequest2 osIgnoreCallback createcci;+		let msg       = ccMsg returncci+		    buttonPtr = if      msg==ccRETURN1 then p1 returncci+		                else if msg==ccWASQUIT then osNoWindowPtr+		                else                   oswindowCreateError 1 "osCreateButtonControl"+		in+		do {+			winSetWindowTitle buttonPtr title;+			winEnableControl  buttonPtr able;+			winShowControl    buttonPtr show;+			return buttonPtr+		}+	  }+	where+		createcci = rq6Cci ccRqCREATEBUTTON parentWindow (x-fst parentPos) (y-snd parentPos) w h (ok_toInt okOrCancel)+++osCreateCustomButtonControl :: OSWindowPtr -> (Int,Int) -> Bool -> Bool -> (Int,Int) -> (Int,Int) -> OKorCANCEL -> IO OSWindowPtr+osCreateCustomButtonControl parentWindow parentPos show able (x',y') (w,h) okOrCancel = do+	let (x,y) = (x'-fst parentPos,y'-snd parentPos)+	let createcci = rq6Cci ccRqCREATEICONBUT parentWindow x y w h (ok_toInt okOrCancel)+	returncci <- issueCleanRequest2 osIgnoreCallback createcci+	let buttonPtr =+		if      ccMsg returncci == ccRETURN1 then p1 returncci+		else if ccMsg returncci == ccWASQUIT then osNoWindowPtr+		else                                 oswindowCreateError 1 "OScreateCustomButtonControl"+	winEnableControl buttonPtr able+	winShowControl	buttonPtr show+	return buttonPtr++osCreateCustomControl :: OSWindowPtr -> (Int,Int) -> Bool -> Bool -> (Int,Int) -> (Int,Int) -> IO OSWindowPtr+osCreateCustomControl parentWindow parentPos show able (x',y') (w,h) = do+	let (x,y) = (x'-fst parentPos,y'-snd parentPos)+	let createcci = rq5Cci ccRqCREATECUSTOM parentWindow x y w h+	returncci <- issueCleanRequest2 osIgnoreCallback createcci+	let customPtr =+		if      ccMsg returncci == ccRETURN1 then p1 returncci+		else if ccMsg returncci == ccWASQUIT then osNoWindowPtr+		else    			     oswindowCreateError 1 "OScreateCustomControl"+	winEnableControl customPtr able+	winShowControl	customPtr show+	return customPtr++osCreateCompoundControl ::  OSWindowMetrics -> OSWindowPtr -> (Int,Int) -> Bool -> Bool -> Bool -> (Int,Int) -> (Int,Int)+							-> ScrollbarInfo ->  ScrollbarInfo -> IO (OSWindowPtr,OSWindowPtr,OSWindowPtr)+osCreateCompoundControl wMetrics parentWindow parentPos show able isTransparent (x,y) (w,h)+						hInfo@(ScrollbarInfo {cbiHasScroll=hasHScroll})+						vInfo@(ScrollbarInfo {cbiHasScroll=hasVScroll}) = do+	let (x1,y1) = (x-fst parentPos,y-snd parentPos)+	    scrollFlags	= (if hasHScroll then ws_HSCROLL else 0) .|. (if hasVScroll then ws_VSCROLL else 0)+	    createcci = rq6Cci ccRqCREATECOMPOUND parentWindow ((x1 `shiftL` 16)+((y1 `shiftL` 16) `shiftR` 16)) w h scrollFlags (fromBool isTransparent)+	returncci <- issueCleanRequest2 osIgnoreCallback createcci+	let msg = ccMsg returncci+	    compoundPtr	= if      msg == ccRETURN1 then p1 returncci+			  else if msg == ccWASQUIT then osNoWindowPtr+			  else 			   oswindowCreateError 1 "osCreateCompoundControl"+	setScrollRangeAndPos hasHScroll False wMetrics sb_HORZ (cbiState hInfo) (0,0) compoundPtr+	setScrollRangeAndPos hasVScroll False wMetrics sb_VERT (cbiState vInfo) (0,0) compoundPtr+	winSetSelectStateWindow	compoundPtr (hasHScroll,hasVScroll) able False+	winShowControl compoundPtr show+	return (compoundPtr,osNoWindowPtr,osNoWindowPtr)+++osCreateRadioControl :: OSWindowPtr -> (Int,Int) -> String -> Bool -> Bool -> (Int,Int) -> (Int,Int) -> Bool -> Bool -> IO OSWindowPtr+osCreateRadioControl parentWindow parentPos title show able (x,y) (w,h) selected isfirst+	= do {+		returncci <- issueCleanRequest2 osIgnoreCallback createcci;+		let msg = ccMsg returncci+		    radioPtr = if      msg==ccRETURN1 then p1 returncci+		     	       else if msg==ccWASQUIT then osNoWindowPtr+		     	       else                   oswindowCreateError 1 "osCreateRadioControl"+		in+		do {+			winSetWindowTitle radioPtr title;+			winCheckControl   radioPtr selected;+			winEnableControl  radioPtr able;+			winShowControl	radioPtr show;+			return radioPtr+		}+	}+	where+		nfirst = if isfirst then 1 else 0+		createcci = rq6Cci ccRqCREATERADIOBUT parentWindow (x-fst parentPos) (y-snd parentPos) w h nfirst+++osCreateCheckControl :: OSWindowPtr -> (Int,Int) -> String -> Bool -> Bool -> (Int,Int) -> (Int,Int) -> Bool -> Bool -> IO OSWindowPtr+osCreateCheckControl parentWindow parentPos title show able (x,y) (w,h) selected isfirst+	= do {+		returncci    <- issueCleanRequest2 osIgnoreCallback createcci;+		let msg       = ccMsg returncci+		    checkPtr = if      msg==ccRETURN1 then p1 returncci+		               else if msg==ccWASQUIT then osNoWindowPtr+		               else                   oswindowCreateError 1 "osCreateCheckControl"+		in+		do {+			winSetWindowTitle checkPtr title;+			winCheckControl   checkPtr  selected;+			winEnableControl  checkPtr able;+			winShowControl    checkPtr show;+			return checkPtr+		}+	  }+	where+		nfirst = if isfirst then 1 else 0+		createcci = rq6Cci ccRqCREATECHECKBOX parentWindow (x-fst parentPos) (y-snd parentPos) w h nfirst+++maxComboboxWidth	= 65535		-- System maximum for width  of combo box+maxComboboxHeight	= 65535		-- System maximum for height of combo box+maxComboElementsVisible	= 15		-- If there are <=MaxComboElementsVisible then show all elements+maxComboElementsScroll	= 12		-- otherwise, show MaxComboElementsScroll elements++osCreateEmptyPopUpControl :: OSWindowPtr -> (Int,Int) -> Bool -> Bool -> (Int,Int) -> (Int,Int) -> Int -> Bool -> IO (OSWindowPtr,OSWindowPtr)+osCreateEmptyPopUpControl parentWindow parentPos show able (x,y) (w1,h1) nrItems isEditable+	= do {+		screenRect <- osScreenRect;+		wMetrics <- osDefaultWindowMetrics;+	  	let screenSize	= rectSize screenRect+		    height	= osmHeight wMetrics+		    okNrItems	= if (nrItems<=maxComboElementsVisible) then nrItems else maxComboElementsScroll+		    overall_h	= min (h screenSize) (min maxComboboxHeight (h1 + (okNrItems+1)*(height+2)))+		    overall_w	= min (w screenSize) (min maxComboboxWidth w1)+		    nisEditable = if isEditable then 1 else 0+		    createcci	= rq6Cci ccRqCREATEPOPUP parentWindow (x-fst parentPos) (y-snd parentPos) overall_w overall_h nisEditable+	  	in+	 	do {+	 		returncci <- issueCleanRequest2 osIgnoreCallback createcci;+	  		let msg = ccMsg returncci+	  		    (popUpPtr,editPtr) = if      msg == ccRETURN2 then (p1 returncci, p2 returncci)+						 else if msg == ccWASQUIT then (osNoWindowPtr,osNoWindowPtr)+						 else			  oswindowCreateError 2 "OScreateEmptyPopUpControl"+			in+			do {+				winEnableControl popUpPtr able;+				winShowControl   popUpPtr show;+				return (popUpPtr,editPtr)+			}+		}+	}++osAddPopUpControlItem :: OSWindowPtr -> String -> Bool -> IO Int+osAddPopUpControlItem parentPopUp title selected+	= do {+		textPtr <- newCString title;+	  	let addcci = rq3Cci ccRqADDTOPOPUP parentPopUp (addr2int textPtr) (fromBool selected)+	  	in+	  	do {+	  		returncci <- issueCleanRequest2 osIgnoreCallback addcci;+			free textPtr;+			(let msg = ccMsg returncci+			     index = if      msg == ccRETURN1 then p1 returncci+				     else if msg == ccWASQUIT then 0+				     else		      oswindowCreateError 1 "osCreatePopUpControlItem"+			 in return index)+		}+	}+++osCreateEmptyListBoxControl :: OSWindowPtr -> (Int,Int) -> Bool -> Bool -> (Int,Int) -> (Int,Int) -> Bool -> IO OSWindowPtr+osCreateEmptyListBoxControl parentWindow parentPos show able (x,y) (w,h) multi+	= do {+		wMetrics <- osDefaultWindowMetrics;+	  	let createcci	= rq6Cci ccRqCREATELISTBOX parentWindow (x-fst parentPos) (y-snd parentPos) w h (fromBool multi)+	  	in+	 	do {+	 		returncci <- issueCleanRequest2 osIgnoreCallback createcci;+	  		let msg = ccMsg returncci+	  		    listBoxPtr = if      msg == ccRETURN1 then p1 returncci+				         else if msg == ccWASQUIT then osNoWindowPtr+				         else oswindowCreateError 2 "osCreateEmptyListBoxControl"+			in+			do {+				winEnableControl listBoxPtr able;+				winShowControl   listBoxPtr show;+				return listBoxPtr+			}+		}+	}++osAddListBoxControlItem :: OSWindowPtr -> String -> Bool -> IO Int+osAddListBoxControlItem parentListBox title selected+	= do {+		textPtr <- newCString title;+	  	let addcci = rq3Cci ccRqADDTOLISTBOX parentListBox (addr2int textPtr) (fromBool selected)+	  	in+	  	do {+	  		returncci <- issueCleanRequest2 osIgnoreCallback addcci;+			free textPtr;+			(let msg = ccMsg returncci+			     index = if      msg == ccRETURN1 then p1 returncci+				     else if msg == ccWASQUIT then 0+				     else		      oswindowCreateError 1 "OScreatePopUpControlItem"+			 in return index)+		}+	}+++data ScrollbarInfo+   = ScrollbarInfo+   	{ cbiHasScroll	:: !Bool		-- The scrollbar exists+	, cbiPos	:: (Int,Int)		-- Its position within the parent+	, cbiSize	:: (Int,Int)		-- Its size within the parent+	, cbiState	:: (Int,Int,Int,Int)	-- Its (min,thumb,max,thumbsize) settings+	}+++setScrollRangeAndPos :: Bool -> Bool -> OSWindowMetrics -> Int -> (Int,Int,Int,Int) -> (Int,Int) -> OSWindowPtr -> IO ()+setScrollRangeAndPos hasScroll redraw wMetrics iBar state maxcoords wPtr =+	if hasScroll then do+	    winSetScrollRange     wPtr iBar min max   False+	    winSetScrollPos       wPtr iBar thumb     0 0 0+	    (if redraw then winSetScrollThumbSize wPtr iBar thumbsize maxx maxy extent+	     else winSetScrollThumbSize wPtr iBar thumbsize 0 0 0)+	else return ()+	where+	    (min,thumb,max,thumbsize) = state+	    (maxx,maxy)		      = maxcoords+	    extent		      = (if iBar==sb_HORZ then osmHSliderHeight else osmVSliderWidth) wMetrics++++{-	Window destruction operations.+	osDestroyWindow checks the process document interface and applies the appropriate destruction operation.+-}+osDestroyWindow :: OSDInfo -> Bool -> Bool -> OSWindowPtr -> (SchedulerEvent -> IO [Int]) -> IO [DelayActivationInfo]+osDestroyWindow osdInfo isModal isWindow wPtr handleOSEvent+	| di==MDI+		= let osinfo     = fromJust (getOSDInfoOSInfo  osdInfo)+		      destroycci = if   isWindow   then rq3Cci ccRqDESTROYMDIDOCWINDOW (osFrame osinfo) (osClient osinfo) wPtr+		                   else if isModal then rq1Cci ccRqDESTROYMODALDIALOG wPtr+		                   else                 rq1Cci ccRqDESTROYWINDOW wPtr+		  in do {+		  	(_,delayInfo) <- issueCleanRequest (osDelayCallback handleOSEvent) destroycci [];+		  	return (reverse delayInfo)+		     }+	| di==SDI+		= let destroycci = if isModal then rq1Cci ccRqDESTROYMODALDIALOG wPtr+		                              else rq1Cci ccRqDESTROYWINDOW wPtr+		  in do {+		  	(_,delayInfo) <- issueCleanRequest (osDelayCallback handleOSEvent) destroycci [];+		  	return (reverse delayInfo)+		     }+	-- It's a NDI process+	| isWindow		{- This condition should never occur (NDI processes have only dialogues). -}+		= oswindowFatalError "osDestroyWindow" "trying to destroy window of NDI process"+	| otherwise+		= let destroycci = if isModal then rq1Cci ccRqDESTROYMODALDIALOG wPtr+		                              else rq1Cci ccRqDESTROYWINDOW wPtr+		  in do {+		  	(_,delayInfo) <- issueCleanRequest (osDelayCallback handleOSEvent) destroycci [];+		  	return (reverse delayInfo)+		     }+	where+		di     = getOSDInfoDocumentInterface osdInfo++osDelayCallback :: (SchedulerEvent -> IO [Int]) -> CrossCallInfo -> [DelayActivationInfo] -> IO (CrossCallInfo,[DelayActivationInfo])+osDelayCallback handleOSEvent osEvent delayinfo+	| toBeHandled = do+		replyToOS <- handleOSEvent (ScheduleOSEvent osEvent [])+		return (setReplyInOSEvent replyToOS,delayinfo)+	| msg==ccWmACTIVATE =+		return (return0Cci,(DelayActivatedWindow (p1 osEvent)):delayinfo)+	| msg==ccWmDEACTIVATE =+		return (return0Cci,(DelayDeactivatedWindow (p1 osEvent)):delayinfo)+	| toBeSkipped =+		return (return0Cci,delayinfo)+	| otherwise =+		oswindowFatalError "osDelayCallback" ("unexpected delay message "++show msg)+	where+		msg         = ccMsg osEvent+		toBeHandled = msg `elem` [ccWmPAINT,ccWmDRAWCONTROL,ccWmKEYBOARD,ccWmKILLFOCUS,ccWmMOUSE,ccWmSETFOCUS]+		toBeSkipped = msg `elem` [ccWmCLOSE,ccWmIDLETIMER,ccWmSIZE]+++{-	Control destruction operations.+-}+destroycontrol :: OSWindowPtr -> IO ()+destroycontrol wPtr+	= issueCleanRequest2 osDestroyControlCallback (rq1Cci ccRqDESTROYWINDOW wPtr) >> return ()+	where+		osDestroyControlCallback :: CrossCallInfo -> IO CrossCallInfo+		osDestroyControlCallback info@(CrossCallInfo {ccMsg=ccMsg})+			| ccMsg==ccWmPAINT+				= winFakePaint (p1 info) >> return return0Cci+			| expected+				= return return0Cci+			| otherwise+				= oswindowFatalError "osDestroyControlCallback" ("unexpected message "++show ccMsg)+			where+				expected = ccMsg `elem`   [ccWmACTIVATE,ccWmBUTTONCLICKED,ccWmITEMSELECT,ccWmCOMMAND,ccWmDEACTIVATE+				                          ,ccWmDRAWCONTROL,ccWmIDLETIMER,ccWmKEYBOARD,ccWmKILLFOCUS,ccWmSETFOCUS+				                          ]+osDestroyRadioControl :: OSWindowPtr -> IO ()+osDestroyRadioControl wPtr = destroycontrol wPtr++osDestroyCheckControl :: OSWindowPtr -> IO ()+osDestroyCheckControl wPtr = destroycontrol wPtr++osDestroyPopUpControl :: OSWindowPtr -> IO ()+osDestroyPopUpControl wPtr = destroycontrol wPtr++osDestroyListBoxControl :: OSWindowPtr -> IO ()+osDestroyListBoxControl wPtr = destroycontrol wPtr++osDestroySliderControl :: OSWindowPtr -> IO ()+osDestroySliderControl wPtr = destroycontrol wPtr++osDestroyTextControl :: OSWindowPtr -> IO ()+osDestroyTextControl wPtr = destroycontrol wPtr++osDestroyEditControl :: OSWindowPtr -> IO ()+osDestroyEditControl wPtr = destroycontrol wPtr++osDestroyButtonControl :: OSWindowPtr -> IO ()+osDestroyButtonControl wPtr = destroycontrol wPtr++osDestroyCustomButtonControl :: OSWindowPtr -> IO ()+osDestroyCustomButtonControl wPtr = destroycontrol wPtr++osDestroyCustomControl :: OSWindowPtr -> IO ()+osDestroyCustomControl wPtr = destroycontrol wPtr++osDestroyCompoundControl :: OSWindowPtr -> IO ()+osDestroyCompoundControl wPtr = destroycontrol wPtr++--	Control update operations.++osUpdateRadioControl :: Rect -> OSWindowPtr -> OSWindowPtr -> IO ()+osUpdateRadioControl area parentWindow theControl = updateControl theControl area++osUpdateCheckControl :: Rect -> OSWindowPtr -> OSWindowPtr -> IO ()+osUpdateCheckControl area parentWindow theControl = updateControl theControl area++osUpdatePopUpControl :: Rect -> OSWindowPtr -> OSWindowPtr -> IO ()+osUpdatePopUpControl area parentWindow theControl = updateControl theControl area++osUpdateListBoxControl :: Rect -> OSWindowPtr -> OSWindowPtr -> IO ()+osUpdateListBoxControl area parentWindow theControl = updateControl theControl area++osUpdateSliderControl :: Rect -> OSWindowPtr -> OSWindowPtr -> IO ()+osUpdateSliderControl area parentWindow theControl = updateControl theControl area++osUpdateTextControl :: Rect -> OSWindowPtr -> OSWindowPtr -> IO ()+osUpdateTextControl area parentWindow theControl = updateControl theControl area++osUpdateEditControl :: Rect -> OSWindowPtr -> OSWindowPtr -> IO ()+osUpdateEditControl area parentWindow theControl = updateControl theControl area++osUpdateButtonControl :: Rect -> OSWindowPtr -> OSWindowPtr -> IO ()+osUpdateButtonControl area parentWindow theControl = updateControl theControl area++osUpdateCompoundControl :: Rect -> OSWindowPtr -> OSWindowPtr -> IO ()+osUpdateCompoundControl area parentWindow theControl = updateControl theControl area++updateControl :: OSWindowPtr -> Rect -> IO ()+updateControl theControl rect = winUpdateWindowRect theControl (toTuple4 rect)+++{-	Control clipping operations.+-}+osClipRectRgn :: (Int,Int) -> Rect -> (Int,Int) -> (Int,Int) -> IO OSRgnHandle+osClipRectRgn parent_pos@(parent_x,parent_y) rect (x,y) (w,h)+	= osNewRectRgn (intersectRects area item)+	where+		area = subVector (fromTuple parent_pos) rect+		x'   = x-parent_x+		y'   = y-parent_y+		item = Rect {rleft=x',rtop=y',rright=x'+w,rbottom=y'+h}++osClipRadioControl :: OSWindowPtr -> (Int,Int) -> Rect -> (Int,Int) -> (Int,Int) -> IO OSRgnHandle+osClipRadioControl _ parentPos area itemPos itemSize = osClipRectRgn parentPos area itemPos itemSize++osClipCheckControl :: OSWindowPtr -> (Int,Int) -> Rect -> (Int,Int) -> (Int,Int) -> IO OSRgnHandle+osClipCheckControl _ parentPos area itemPos itemSize = osClipRectRgn parentPos area itemPos itemSize++osClipPopUpControl :: OSWindowPtr -> (Int,Int) -> Rect -> (Int,Int) -> (Int,Int) -> IO OSRgnHandle+osClipPopUpControl _ parentPos area itemPos itemSize = osClipRectRgn parentPos area itemPos itemSize++osClipListBoxControl :: OSWindowPtr -> (Int,Int) -> Rect -> (Int,Int) -> (Int,Int) -> IO OSRgnHandle+osClipListBoxControl _ parentPos area itemPos itemSize = osClipRectRgn parentPos area itemPos itemSize++osClipSliderControl :: OSWindowPtr -> (Int,Int) -> Rect -> (Int,Int) -> (Int,Int) -> IO OSRgnHandle+osClipSliderControl _ parentPos area itemPos itemSize = osClipRectRgn parentPos area itemPos itemSize++osClipTextControl :: OSWindowPtr -> (Int,Int) -> Rect -> (Int,Int) -> (Int,Int) -> IO OSRgnHandle+osClipTextControl _ parentPos area itemPos itemSize = osClipRectRgn parentPos area itemPos itemSize++osClipEditControl :: OSWindowPtr -> (Int,Int) -> Rect -> (Int,Int) -> (Int,Int) -> IO OSRgnHandle+osClipEditControl _ parentPos area itemPos itemSize = osClipRectRgn parentPos area itemPos itemSize++osClipButtonControl :: OSWindowPtr -> (Int,Int) -> Rect -> (Int,Int) -> (Int,Int) -> IO OSRgnHandle+osClipButtonControl _ parentPos area itemPos itemSize = osClipRectRgn parentPos area itemPos itemSize++osClipCustomButtonControl :: OSWindowPtr -> (Int,Int) -> Rect -> (Int,Int) -> (Int,Int) -> IO OSRgnHandle+osClipCustomButtonControl _ parentPos area itemPos itemSize = osClipRectRgn parentPos area itemPos itemSize++osClipCustomControl :: OSWindowPtr -> (Int,Int) -> Rect -> (Int,Int) -> (Int,Int) -> IO OSRgnHandle+osClipCustomControl _ parentPos area itemPos itemSize = osClipRectRgn parentPos area itemPos itemSize++osClipCompoundControl :: OSWindowPtr -> (Int,Int) -> Rect -> (Int,Int) -> (Int,Int) -> IO OSRgnHandle+osClipCompoundControl _ parentPos area itemPos itemSize = osClipRectRgn parentPos area itemPos itemSize+++{-	Window graphics context access operations.+-}+osGrabWindowPictContext :: OSWindowPtr -> IO OSPictContext+osGrabWindowPictContext wPtr = winGetDC wPtr++osGrabControlPictContext :: OSWindowPtr -> OSWindowPtr -> IO OSPictContext+osGrabControlPictContext wPtr cPtr = winGetDC cPtr++osReleaseWindowPictContext :: OSWindowPtr -> OSPictContext -> IO ()+osReleaseWindowPictContext wPtr hdc = winReleaseDC wPtr hdc++osReleaseControlPictContext :: OSWindowPtr -> OSPictContext -> IO ()+osReleaseControlPictContext cPtr hdc = winReleaseDC cPtr hdc+++{-	Window access operations.+-}+toOSscrollbarRange :: (Int,Int,Int) -> Int -> (Int,Int,Int,Int)+toOSscrollbarRange (domainMin,viewMin,domainMax) viewSize+	= (osRangeMin,osThumb,osRangeMax,osThumbSize+1)+	where+		(osRangeMin,osRangeMax) = toOSRange (domainMin,domainMax)+		range                   =  domainMax- domainMin+		osRange                 = osRangeMax-osRangeMin+		osThumb                 = inRange osRangeMin osRange (viewMin-domainMin) range+		osThumbSize             = if viewSize>=range then osRange else round (((fromIntegral viewSize)/(fromIntegral range))*(fromIntegral osRange))++fromOSscrollbarRange :: (Int,Int) -> Int -> Int+fromOSscrollbarRange (domainMin,domainMax) osThumb+	= inRange domainMin range (osThumb-osRangeMin) osRange+	where+		(osRangeMin,osRangeMax) = toOSRange (domainMin,domainMax)+		range                   =  domainMax- domainMin+		osRange                 = osRangeMax-osRangeMin++osScrollbarIsVisible :: (Int,Int) -> Int -> Bool+osScrollbarIsVisible (domainMin,domainMax) viewSize+	= viewSize<domainMax-domainMin++osScrollbarsAreVisible :: OSWindowMetrics -> Rect -> (Int,Int) -> (Bool,Bool) -> (Bool,Bool)+osScrollbarsAreVisible (OSWindowMetrics {osmHSliderHeight=osmHSliderHeight,osmVSliderWidth=osmVSliderWidth})+                       (Rect {rleft=xMin,rtop=yMin,rright=xMax,rbottom=yMax})+                       (width,height)+                       (hasHScroll,hasVScroll)+	= visScrollbars (False,False) (hasHScroll && (osScrollbarIsVisible hRange width),hasVScroll && (osScrollbarIsVisible vRange height))+	where+		hRange = (xMin,xMax)+		vRange = (yMin,yMax)++		visScrollbars :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool)+		visScrollbars (showH1,showV1) (showH2,showV2)+			| showH1==showH2 && showV1==showV2+				= (showH1,showV1)+			| otherwise+				= visScrollbars (showH2,showV2) (showH,showV)+			where+				showH = if showV2 then hasHScroll && osScrollbarIsVisible hRange (width -osmVSliderWidth ) else showH2+				showV = if showH2 then hasVScroll && osScrollbarIsVisible vRange (height-osmHSliderHeight) else showV2++toOSRange :: (Int,Int) -> (Int,Int)+toOSRange (min,max)+	= (osSliderMin,if range<=osSliderRange then osSliderMin+range else osSliderMax)+	where+		range = max-min++inRange :: Int -> Int -> Int -> Int -> Int+inRange destMin destRange sourceValue sourceRange+	= destMin + round (((fromIntegral sourceValue) / (fromIntegral sourceRange)) * (fromIntegral destRange))++osSliderMin   = 0		-- 0+osSliderMax   = 32767+osSliderRange = 32767		-- osSliderMax-osSliderMin+++osSetWindowSliderThumb :: OSWindowMetrics -> OSWindowPtr -> Bool -> Int -> (Int,Int) -> Bool -> IO ()+osSetWindowSliderThumb wMetrics theWindow isHorizontal thumb (maxx,maxy) redraw =+    winSetScrollPos theWindow (if isHorizontal then sb_HORZ else sb_VERT) thumb maxx maxy extent+    where+       extent = (if isHorizontal then osmHSliderHeight else osmVSliderWidth) wMetrics++osSetWindowSliderThumbSize :: OSWindowMetrics -> OSWindowPtr -> Bool -> Int -> (Int,Int) -> Bool -> IO ()+osSetWindowSliderThumbSize wMetrics theWindow isHorizontal size (maxx,maxy) redraw =+    winSetScrollThumbSize theWindow (if isHorizontal then sb_HORZ else sb_VERT) size maxx maxy extent+    where+	extent	= (if isHorizontal then osmHSliderHeight else osmVSliderWidth) wMetrics++osSetWindowSlider :: OSWindowMetrics -> OSWindowPtr -> Bool -> (Int,Int,Int,Int) -> (Int,Int) -> IO ()+osSetWindowSlider wMetrics theWindow isHorizontal state maxcoords =+	setScrollRangeAndPos True True wMetrics (if isHorizontal then sb_HORZ else sb_VERT) state maxcoords theWindow+	+{-	Window access operations. -}++osInvalidateWindow :: OSWindowPtr -> IO ()+osInvalidateWindow theWindow+	= winInvalidateWindow theWindow++osInvalidateWindowRect :: OSWindowPtr -> Rect -> IO ()+osInvalidateWindowRect theWindow rect+	= winInvalidateRect theWindow (toTuple4 rect)++osValidateWindowRect :: OSWindowPtr -> Rect -> IO ()+osValidateWindowRect theWindow rect+	= winValidateRect theWindow (toTuple4 rect)++osValidateWindowRgn :: OSWindowPtr -> OSRgnHandle -> IO ()+osValidateWindowRgn theWindow rgn+	= winValidateRgn theWindow rgn++osDisableWindow :: OSWindowPtr -> (Bool,Bool) -> Bool -> IO ()+osDisableWindow theWindow scrollInfo modalContext+	= winSetSelectStateWindow theWindow scrollInfo False modalContext++osEnableWindow :: OSWindowPtr -> (Bool,Bool) -> Bool -> IO ()+osEnableWindow theWindow scrollInfo modalContext+	= winSetSelectStateWindow theWindow scrollInfo True modalContext++osActivateWindow :: OSDInfo -> OSWindowPtr -> (OSEvent -> IO ()) -> IO [DelayActivationInfo]+osActivateWindow osdInfo thisWindow handleOSEvent+	= do {+		(_,delayinfo) <- issueCleanRequest (osCallback handleOSEvent)+		                                            (rq3Cci ccRqACTIVATEWINDOW (fromBool isMDI) clientPtr thisWindow)+		                                            [];+		return (reverse delayinfo)+	  }+	where+		isMDI     = getOSDInfoDocumentInterface osdInfo==MDI+		clientPtr = case getOSDInfoOSInfo osdInfo of+		                Just osinfo -> osClient osinfo+		                nothing     -> oswindowFatalError "osActivateWindow" "illegal DocumentInterface context"++	{-	osCallback delays activate and deactivate events.+		All other events are passed to the callback function.+	-}	osCallback :: (OSEvent -> IO ()) -> CrossCallInfo -> [DelayActivationInfo] -> IO (CrossCallInfo,[DelayActivationInfo])+		osCallback handleOSEvent osEvent@(CrossCallInfo {ccMsg=ccMsg,p1=p1,p2=p2}) delayinfo+			| isJust maybeEvent+				= return (return0Cci,(fromJust maybeEvent):delayinfo)+			| otherwise+				= do { handleOSEvent osEvent;+				       return (return0Cci,delayinfo)+				  }+			where+				maybeEvent   = lookup ccMsg [(ccWmACTIVATE , DelayActivatedWindow    p1)+				                            ,(ccWmDEACTIVATE,DelayDeactivatedWindow  p1)+				                            ,(ccWmKILLFOCUS, DelayDeactivatedControl p1 p2)+				                            ,(ccWmSETFOCUS,  DelayActivatedControl   p1 p2)+				                            ]+++osActivateControl :: OSWindowPtr -> OSWindowPtr -> IO [DelayActivationInfo]+osActivateControl parentWindow controlPtr+	= do {+		(_,delayinfo) <- issueCleanRequest osIgnoreCallback' (rq1Cci ccRqACTIVATECONTROL controlPtr) [];+		return (reverse delayinfo)+	  }+	where+		osIgnoreCallback' :: CrossCallInfo -> [DelayActivationInfo] -> IO (CrossCallInfo,[DelayActivationInfo])+		osIgnoreCallback' cci@(CrossCallInfo {ccMsg=msg,p1=p1, p2=p2}) delayinfo+			| msg==ccWmPAINT+				= winFakePaint p1 >> return (return0Cci,delayinfo)+			| msg==ccWmKILLFOCUS+				= return (return0Cci,(DelayDeactivatedControl p1 p2):delayinfo)+			| msg==ccWmSETFOCUS+				= return (return0Cci,(DelayActivatedControl p1 p2):delayinfo)+			| otherwise+				= return (return0Cci,delayinfo)++osStackWindow :: OSWindowPtr -> OSWindowPtr -> (OSEvent -> IO ()) -> IO [DelayActivationInfo]+osStackWindow thisWindow behindWindow handleOSEvent+	= do {+		(_,delayinfo) <- issueCleanRequest (osCallback handleOSEvent)+		                                            (rq2Cci ccRqRESTACKWINDOW thisWindow behindWindow)+		                                            [];+		return (reverse delayinfo)+	  }+	where+	{-	osCallback delays activate and deactivate events.+		All other events are passed to the callback function.+		PA: is now identical to osActivateWindow!!+	-}	osCallback :: (OSEvent -> IO ()) -> CrossCallInfo -> [DelayActivationInfo] -> IO (CrossCallInfo,[DelayActivationInfo])+		osCallback handleOSEvent osEvent@(CrossCallInfo {ccMsg=msg,p1=p1}) delayinfo+			| msg==ccWmACTIVATE+				= return (return0Cci,(DelayActivatedWindow p1):delayinfo)+			| msg==ccWmDEACTIVATE+				= return (return0Cci,(DelayDeactivatedWindow p1):delayinfo)+			| otherwise+				= handleOSEvent osEvent >> return (return0Cci,delayinfo)++osHideWindow :: OSWindowPtr -> Bool -> IO [DelayActivationInfo]+osHideWindow wPtr activate+	= do {+		(_,delayinfo) <- issueCleanRequest osIgnoreCallback' (rq3Cci ccRqSHOWWINDOW wPtr (fromBool False) (fromBool activate)) [];+		return (reverse delayinfo)+	  }++osShowWindow :: OSWindowPtr -> Bool -> IO [DelayActivationInfo]+osShowWindow wPtr activate+	= do {+		(_,delayinfo) <- issueCleanRequest osIgnoreCallback' (rq3Cci ccRqSHOWWINDOW wPtr (fromBool True) (fromBool activate)) [];+		return (reverse delayinfo)+	  }++osSetWindowCursor :: OSWindowPtr -> Int -> IO ()+osSetWindowCursor wPtr cursorCode+	= winSetWindowCursor wPtr cursorCode++osGetWindowPos :: OSWindowPtr -> IO (Int,Int)+osGetWindowPos wPtr+	= winGetWindowPos wPtr++osGetWindowViewFrameSize :: OSWindowPtr -> IO (Int,Int)+osGetWindowViewFrameSize wPtr+	= winGetClientSize wPtr++osGetWindowSize :: OSWindowPtr -> IO (Int,Int)+osGetWindowSize wPtr+	= winGetWindowSize wPtr++osSetWindowPos :: OSWindowPtr -> (Int,Int) -> Bool -> Bool -> IO ()+osSetWindowPos wPtr pos update inclScrollbars+	= winSetWindowPos wPtr pos update inclScrollbars++osSetWindowViewFrameSize :: OSWindowPtr -> (Int,Int) -> IO ()+osSetWindowViewFrameSize wPtr size+	= winSetClientSize wPtr size++osSetWindowSize :: OSWindowPtr -> (Int,Int) -> Bool -> IO ()+osSetWindowSize wPtr size update+	= winSetWindowSize wPtr size update++osSetWindowTitle :: OSWindowPtr -> String -> IO ()+osSetWindowTitle wPtr title+	= winSetWindowTitle wPtr title+++{-	Control access operations. -}++--	On compound controls:++osInvalidateCompound :: OSWindowPtr -> IO ()+osInvalidateCompound compoundPtr+	= winInvalidateWindow compoundPtr++osInvalidateCompoundRect :: OSWindowPtr -> Rect -> IO ()+osInvalidateCompoundRect compoundPtr rect+	= winInvalidateRect compoundPtr (toTuple4 rect)++osSetCompoundSliderThumb :: OSWindowMetrics -> OSWindowPtr -> Bool -> Int -> (Int,Int) -> Bool -> IO ()+osSetCompoundSliderThumb wMetrics compoundPtr isHorizontal thumb (maxx,maxy) redraw+	= winSetScrollPos compoundPtr (if isHorizontal then sb_HORZ else sb_VERT) thumb maxx' maxy' extent+	where+	   (maxx',maxy',extent) = if redraw then (maxx,maxy,(if isHorizontal then osmHSliderHeight else osmVSliderWidth) wMetrics) else (0,0,0)++osSetCompoundSliderThumbSize :: OSWindowMetrics -> OSWindowPtr -> Bool -> Int -> (Int,Int) -> Bool -> IO ()+osSetCompoundSliderThumbSize wMetrics compoundPtr isHorizontal size (maxx,maxy) redraw+	= winSetScrollThumbSize compoundPtr (if isHorizontal then sb_HORZ else sb_VERT) size maxx' maxy' extent+	where+	   (maxx',maxy',extent)	= if redraw then (maxx,maxy,(if isHorizontal then osmHSliderHeight else osmVSliderWidth) wMetrics) else (0,0,0)++osSetCompoundSlider :: OSWindowMetrics -> OSWindowPtr -> Bool -> (Int,Int,Int,Int) -> (Int,Int) -> IO ()+osSetCompoundSlider wMetrics compoundPtr isHorizontal state maxcoords+	= setScrollRangeAndPos True True wMetrics (if isHorizontal then sb_HORZ else sb_VERT) state maxcoords compoundPtr++osSetCompoundSelect :: OSWindowPtr -> OSWindowPtr -> Rect -> (Bool,Bool) -> Bool -> IO ()+osSetCompoundSelect _ compoundPtr _ scrollInfo select+	= winSetSelectStateWindow compoundPtr scrollInfo select False++osSetCompoundShow :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetCompoundShow _ compoundPtr _ show+	= winShowControl compoundPtr show++osSetCompoundPos :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetCompoundPos _ (parent_x,parent_y) compoundPtr (x,y) _ update+	= winSetWindowPos compoundPtr (x-parent_x,y-parent_y) update True++osSetCompoundSize :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetCompoundSize _ _ compoundPtr _ size update+	= winSetWindowSize compoundPtr size update++osCompoundMovesControls = True++--	On slider controls:++osSetSliderThumb :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> (Int,Int,Int) -> IO ()+osSetSliderThumb _ cPtr _ redraw (min,thumb,max)+	= winSetScrollPos cPtr sb_CTL thumb 0 0 0++osSetSliderControlSelect :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetSliderControlSelect _ cPtr _ select+	= winEnableControl cPtr select++osSetSliderControlShow :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetSliderControlShow _ cPtr _ show+	= winShowControl cPtr show++osSetSliderControlPos :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetSliderControlPos _ (parent_x,parent_y) sliderPtr (x,y) _ update+	= winSetWindowPos sliderPtr (x-parent_x,y-parent_y) update False++osSetSliderControlSize :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetSliderControlSize _ _ sliderPtr _ size update+	= winSetWindowSize sliderPtr size update++--	On radio controls:++osCheckRadioControl :: OSWindowPtr -> OSWindowPtr -> Bool -> IO ()+osCheckRadioControl _ cPtr b+	= winCheckControl cPtr b++osSetRadioControlSelect :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetRadioControlSelect _ cPtr _ select+	= winEnableControl cPtr select++osSetRadioControlShow :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetRadioControlShow _ cPtr _ show+	= winShowControl cPtr show++osSetRadioControlPos :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetRadioControlPos _ (parent_x,parent_y) radioPtr (x,y) _ update+	= winSetWindowPos radioPtr (x-parent_x,y-parent_y) update False++osSetRadioControlSize :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetRadioControlSize _ _ radioPtr _ size update+	= winSetWindowSize radioPtr size update+++--	On check controls:++osCheckCheckControl :: OSWindowPtr -> OSWindowPtr -> Bool -> IO ()+osCheckCheckControl _ cPtr check = winCheckControl cPtr check++osSetCheckControlSelect :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetCheckControlSelect _ cPtr _ select+	= winEnableControl cPtr select++osSetCheckControlShow :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetCheckControlShow _ cPtr _ show+	= winShowControl cPtr show++osSetCheckControlPos :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetCheckControlPos _ (parent_x,parent_y) checkPtr (x,y) _ update+	= winSetWindowPos checkPtr (x-parent_x,y-parent_y) update False++osSetCheckControlSize :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetCheckControlSize _ _ checkPtr _ size update+	= winSetWindowSize checkPtr size update+++--	On pop up controls:++osSelectPopUpControlItem :: OSWindowPtr -> OSWindowPtr -> Int -> IO ()+osSelectPopUpControlItem _ pPtr new+	= winSelectPopupItem pPtr (new-1)++osSetPopUpControlSelect :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetPopUpControlSelect _ pPtr _ select+	= winEnableControl pPtr select++osSetPopUpControlShow :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetPopUpControlShow _ pPtr _ show+	= winShowControl pPtr show++osSetPopUpControlPos :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetPopUpControlPos _ (parent_x,parent_y) popupPtr (x,y) _ update+	= winSetWindowPos popupPtr (x-parent_x,y-parent_y) update False++osSetPopUpControlSize :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetPopUpControlSize _ _ popupPtr _ size update+	= winSetWindowSize popupPtr size update+	+--	On list box controls:++osSelectListBoxControlItem :: OSWindowPtr -> OSWindowPtr -> Int -> IO ()+osSelectListBoxControlItem _ pPtr new+	= winSelectListBoxItem pPtr (new-1)+	+osMarkListBoxControlItem :: OSWindowPtr -> OSWindowPtr -> Int -> Bool -> IO ()+osMarkListBoxControlItem _ pPtr new mark+	= winMarkListBoxItem pPtr (new-1) mark++osSetListBoxControlSelect :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetListBoxControlSelect _ pPtr _ select+	= winEnableControl pPtr select++osSetListBoxControlShow :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetListBoxControlShow _ pPtr _ show+	= winShowControl pPtr show++osSetListBoxControlPos :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetListBoxControlPos _ (parent_x,parent_y) popupPtr (x,y) _ update+	= winSetWindowPos popupPtr (x-parent_x,y-parent_y) update False++osSetListBoxControlSize :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetListBoxControlSize _ _ popupPtr _ size update+	= winSetWindowSize popupPtr size update++--	On edit controls:++osSetEditControlText :: OSWindowPtr -> OSWindowPtr -> Rect -> Rect -> Bool -> String -> IO ()+osSetEditControlText _ ePtr _ _ _ text+	= winSetWindowTitle ePtr text++osGetEditControlText :: OSWindowPtr -> OSWindowPtr -> IO String+osGetEditControlText _ ePtr+	= winGetWindowText ePtr++osSetEditControlCursor :: OSWindowPtr -> OSWindowPtr -> Rect -> Rect -> Int -> IO ()+osSetEditControlCursor _ ePtr _ _ pos+	= winSetEditSelection ePtr pos (pos+1)++osSetEditControlSelect :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetEditControlSelect _ ePtr _ select+	= winEnableControl ePtr select++osSetEditControlShow :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetEditControlShow _ ePtr _ show+	= winShowControl ePtr show++osSetEditControlPos :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetEditControlPos _ (parent_x,parent_y) editPtr (x,y) _ update+	= winSetWindowPos editPtr (x-parent_x,y-parent_y) update False++osSetEditControlSize :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetEditControlSize _ _ editPtr _ size update+	= winSetWindowSize editPtr size update+++--	On text controls:++osSetTextControlText :: OSWindowPtr -> OSWindowPtr -> Rect -> Rect -> Bool -> String -> IO ()+osSetTextControlText _ tPtr _ _ _ text+	= winSetWindowTitle tPtr text++osSetTextControlSelect :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetTextControlSelect _ tPtr _ select+	= winEnableControl tPtr select++osSetTextControlShow :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetTextControlShow _ tPtr _ show+	= winShowControl tPtr show++osSetTextControlPos :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetTextControlPos _ (parent_x,parent_y) textPtr (x,y) _ update+	= winSetWindowPos textPtr (x-parent_x,y-parent_y) update False++osSetTextControlSize :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetTextControlSize _ _ textPtr _ size update+	= winSetWindowSize textPtr size update+++--	On button controls:++osSetButtonControlText :: OSWindowPtr -> OSWindowPtr -> Rect -> String -> IO ()+osSetButtonControlText _ bPtr _ text+	= winSetWindowTitle bPtr text++osSetButtonControlSelect :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetButtonControlSelect _ bPtr _ select+	= winEnableControl bPtr select++osSetButtonControlShow :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetButtonControlShow _ bPtr _ show+	= winShowControl bPtr show++osSetButtonControlPos :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetButtonControlPos _ (parent_x,parent_y) buttonPtr (x,y) _ update+	= winSetWindowPos buttonPtr (x-parent_x,y-parent_y) update False++osSetButtonControlSize :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetButtonControlSize _ _ buttonPtr _ size update+	= winSetWindowSize buttonPtr size update++--	On custom button controls:++osSetCustomButtonControlSelect :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetCustomButtonControlSelect _ cPtr _ select+	= winEnableControl cPtr select++osSetCustomButtonControlShow :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetCustomButtonControlShow _ cPtr _ show+	= winShowControl cPtr show++osSetCustomButtonControlPos :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetCustomButtonControlPos _ (parent_x,parent_y) cPtr (x,y) _ update+	= winSetWindowPos cPtr (x-parent_x,y-parent_y) update False++osSetCustomButtonControlSize :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetCustomButtonControlSize _ _ cPtr _ size update+	= winSetWindowSize cPtr size update++--	On custom controls:++osSetCustomControlSelect :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetCustomControlSelect _ cPtr _ select+	= winEnableControl cPtr select++osSetCustomControlShow :: OSWindowPtr -> OSWindowPtr -> Rect -> Bool -> IO ()+osSetCustomControlShow _ cPtr _ show+	= winShowControl cPtr show++osSetCustomControlPos :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetCustomControlPos _ (parent_x,parent_y) customPtr (x,y) _ update+	= winSetWindowPos customPtr (x-parent_x,y-parent_y) update False++osSetCustomControlSize :: OSWindowPtr -> (Int,Int) -> OSWindowPtr -> (Int,Int) -> (Int,Int) -> Bool -> IO ()+osSetCustomControlSize _ _ customPtr _ size update+	= winSetWindowSize customPtr size update
+ Graphics/UI/ObjectIO/OS/WindowCCall_12.hs view
@@ -0,0 +1,44 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.WindowCCall_12+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- WindowCCall_12 contains C calls for handling windows. +--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.WindowCCall_12+		( winInvalidateWindow, winInvalidateRect+		, winValidateRect, winValidateRgn+		, winGetDC, winReleaseDC                      +		, module Graphics.UI.ObjectIO.OS.Types+		) where++++import Graphics.UI.ObjectIO.OS.Cutil_12+import Graphics.UI.ObjectIO.OS.Types+++foreign import ccall  "cCCallWindows_121.h WinInvalidateWindow" winInvalidateWindow :: OSWindowPtr -> IO ()++winInvalidateRect :: OSWindowPtr -> (Int,Int,Int,Int) -> IO ()+winInvalidateRect a1 (a2,a3,a4,a5)+	= cWinInvalidateRect a1 a2 a3 a4 a5+foreign import ccall "cCCallWindows_121.h WinInvalidateRect" cWinInvalidateRect :: OSWindowPtr -> Int -> Int -> Int -> Int -> IO ()++winValidateRect :: OSWindowPtr -> (Int,Int,Int,Int) -> IO ()+winValidateRect a1 (a2,a3,a4,a5)+	= cWinValidateRect a1 a2 a3 a4 a5+foreign import ccall "cCCallWindows_121.h WinValidateRect" cWinValidateRect :: OSWindowPtr -> Int -> Int -> Int -> Int -> IO ()+++foreign import ccall "cCCallWindows_121.h WinValidateRgn" winValidateRgn :: OSWindowPtr -> OSRgnHandle -> IO ()+foreign import ccall "cpicture_121.h WinGetDC" winGetDC :: OSWindowPtr -> IO OSPictContext+foreign import ccall "cpicture_121.h WinReleaseDC" winReleaseDC :: OSWindowPtr -> OSPictContext -> IO ()
+ Graphics/UI/ObjectIO/OS/WindowCrossCall_12.hs view
@@ -0,0 +1,272 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.WindowCrossCall_12+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- OS.WindowCrossCall_12 collects all the cross call routines related to windows.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.WindowCrossCall_12 where++++import Graphics.UI.ObjectIO.OS.ClCrossCall_12+import Graphics.UI.ObjectIO.OS.Cutil_12(newCString, peekCString, free, addr2int, int2addr)+import Graphics.UI.ObjectIO.OS.Types(OSWindowPtr, OSPictContext)+import Graphics.UI.ObjectIO.OS.ClCrossCall_12+import Foreign.Ptr+import Foreign.Marshal.Utils(fromBool)++--	Cursor shape constants:+cursHIDDEN, cursARROW, cursFATCROSS, cursCROSS, cursIBEAM, cursBUSY :: Int+cursHIDDEN		= 6+cursARROW		= 5+cursFATCROSS		= 4+cursCROSS		= 3+cursIBEAM		= 2+cursBUSY		= 1++--	Constants for handling scrollbars.+sb_HORZ, sb_VERT, sb_CTL, sb_BOTH :: Int+sb_HORZ			= 0+sb_VERT			= 1+sb_CTL			= 2+sb_BOTH			= 3++sb_LINEUP, sb_LINELEFT, sb_LINEDOWN, sb_LINERIGHT, +	sb_PAGEUP, sb_PAGELEFT, sb_PAGEDOWN, sb_PAGERIGHT, +	sb_THUMBPOSITION, sb_THUMBTRACK, +	sb_TOP, sb_LEFT, sb_BOTTOM, sb_RIGHT, +	sb_ENDSCROLL :: Int+sb_LINEUP		= 0+sb_LINELEFT		= 0+sb_LINEDOWN		= 1+sb_LINERIGHT		= 1+sb_PAGEUP		= 2+sb_PAGELEFT		= 2+sb_PAGEDOWN		= 3+sb_PAGERIGHT		= 3+sb_THUMBPOSITION	= 4+sb_THUMBTRACK		= 5+sb_TOP			= 6+sb_LEFT			= 6+sb_BOTTOM		= 7+sb_RIGHT		= 7+sb_ENDSCROLL		= 8++--	constants for handling window styles.+ws_OVERLAPPED, ws_POPUP, ws_CHILD, ws_MINIMIZE, ws_VISIBLE, ws_DISABLED, +	ws_CLIPSIBLINGS, ws_CLIPCHILDREN, ws_MAXIMIZE, ws_CAPTION, ws_BORDER, +	ws_DLGFRAME, ws_VSCROLL, ws_HSCROLL, ws_SYSMENU, ws_THICKFRAME, ws_GROUP, ws_TABSTOP :: Int+ws_OVERLAPPED		= 0x00000000+ws_POPUP		= 0x80000000+ws_CHILD		= 0x40000000+ws_MINIMIZE		= 0x20000000+ws_VISIBLE		= 0x10000000+ws_DISABLED		= 0x08000000+ws_CLIPSIBLINGS		= 0x04000000+ws_CLIPCHILDREN		= 0x02000000+ws_MAXIMIZE		= 0x01000000+ws_CAPTION		= 0x00C00000		{- ws_BORDER | ws_DLGFRAME  -}+ws_BORDER		= 0x00800000+ws_DLGFRAME		= 0x00400000+ws_VSCROLL		= 0x00200000+ws_HSCROLL		= 0x00100000+ws_SYSMENU		= 0x00080000+ws_THICKFRAME		= 0x00040000+ws_GROUP		= 0x00020000+ws_TABSTOP		= 0x00010000++ws_MINIMIZEBOX		= 0x00020000+ws_MAXIMIZEBOX		= 0x00010000++ws_TILED		= ws_OVERLAPPED+ws_ICONIC		= ws_MINIMIZE+ws_SIZEBOX		= ws_THICKFRAME++--	constants for stacking windows.+hwnd_TOP, hwnd_BOTTOM, hwnd_TOPMOST, hwnd_NOTOPMOST :: Int +hwnd_TOP		= 0+hwnd_BOTTOM		= 1+hwnd_TOPMOST		= -1+hwnd_NOTOPMOST		= -2++--	flag values for passing information about edit controls from Clean to OS.+editISMULTILINE, editISKEYSENSITIVE :: Int+editISMULTILINE		= 1			{- flag value: edit control is multi-line. -}+editISKEYSENSITIVE	= 2			{- flag value: edit control sends keyboard events to Clean. -}++--	values for telling Windows if a (custom)button control is OK, CANCEL, or normal. +isNORMALBUTTON, isOKBUTTON, isCANCELBUTTON :: Int+isNORMALBUTTON		= 0			{- The button is a normal button.   -}+isOKBUTTON		= 1			{- The button is the OK button.     -}+isCANCELBUTTON		= 2			{- The button is the CANCEL button. -}+++winSetWindowCursor :: OSWindowPtr -> Int -> IO ()+winSetWindowCursor hwnd cursorcode+	= issueCleanRequest2 (errorCallback2 "winSetWindowCursor") (rq2Cci ccRqCHANGEWINDOWCURSOR hwnd cursorcode) >> return ()++winObscureCursor :: IO ()+winObscureCursor+	= issueCleanRequest2 (errorCallback2 "winObscureCursor") (rq0Cci ccRqOBSCURECURSOR) >> return ()++winSetWindowTitle :: OSWindowPtr -> String -> IO ()+winSetWindowTitle hwnd title+	= do {+		textptr <- newCString title;+		issueCleanRequest2 (errorCallback2 "SetWindowTitle") (rq2Cci ccRqSETWINDOWTITLE hwnd (addr2int textptr));+		free textptr+	  }++winGetWindowText :: OSWindowPtr -> IO String+winGetWindowText hwnd+	= do {+		rcci <- issueCleanRequest2 (errorCallback2 "winGetWindowText") (rq1Cci ccRqGETWINDOWTEXT hwnd);+		let msg = ccMsg rcci+		in  if   msg==ccRETURN1+		    then do+		       r <- peekCString (int2addr (p1 rcci))+		       free (int2addr (p1 rcci))+		       return r+		    else if   msg==ccWASQUIT+		         then return ""+		         else error "[winGetWindowText] expected ccRETURN1 value."+	  }++winUpdateWindowRect :: OSWindowPtr -> (Int,Int,Int,Int) -> IO ()+winUpdateWindowRect hwnd (left,top,right,bottom)+	= issueCleanRequest2 (errorCallback2 "winUpdateWindowRect") (rq5Cci ccRqUPDATEWINDOWRECT hwnd left top right bottom) >> return ()++winSetSelectStateWindow :: OSWindowPtr -> (Bool,Bool) -> Bool -> Bool -> IO ()+winSetSelectStateWindow hwnd (hasHScroll,hasVScroll) toAble modalContext+	= issueCleanRequest2 (errorCallback2 "winSetSelectStateWindow") selectCci >> return ()+	where+		selectCci = rq5Cci ccRqSETSELECTWINDOW hwnd (fromBool hasHScroll) (fromBool hasVScroll) (fromBool toAble) (fromBool modalContext)++winBeginPaint :: OSWindowPtr -> IO OSPictContext+winBeginPaint hwnd+	= do {+		rcci <- issueCleanRequest2 (errorCallback2 "BeginPaint") (rq1Cci ccRqBEGINPAINT hwnd);+		let msg = ccMsg rcci+		in  if   msg==ccRETURN1+		    then return (int2addr (p1 rcci))+		    else if   msg==ccWASQUIT+		         then return nullPtr+		         else error "[winBeginPaint] expected ccRETURN1 value."+	  }++winEndPaint :: OSWindowPtr -> OSPictContext -> IO ()+winEndPaint hwnd hdc+	= issueCleanRequest2 (errorCallback2 "winEndPaint") (rq2Cci ccRqENDPAINT hwnd (addr2int hdc)) >> return ()++winFakePaint :: OSWindowPtr -> IO ()+winFakePaint hwnd+	= issueCleanRequest2 (errorCallback2 "winFakePaint") (rq1Cci ccRqFAKEPAINT hwnd) >> return ()++winGetClientSize :: OSWindowPtr -> IO (Int,Int)+winGetClientSize hwnd+	= do {+		rcci <- issueCleanRequest2 (errorCallback2 "winGetClientSize") (rq1Cci ccRqGETCLIENTSIZE hwnd);+		let msg = ccMsg rcci+		in  if   msg==ccRETURN2+		    then return (p1 rcci,p2 rcci)+		    else if   msg==ccWASQUIT+		         then return (0,0)+		         else error "[winGetClientSize] expected ccRETURN2 value."+	  }++winGetWindowSize :: OSWindowPtr -> IO (Int,Int)+winGetWindowSize hwnd+	= do {+		rcci <- issueCleanRequest2 (errorCallback2 "winGetWindowSize") (rq1Cci ccRqGETWINDOWSIZE hwnd);+		let msg = ccMsg rcci+		in  if   msg==ccRETURN2+		    then return (p1 rcci,p2 rcci)+		    else if   msg==ccWASQUIT+		         then return (0,0)+		         else error "[winGetWindowSize] expected ccRETURN2 value."+	  }++winSetClientSize :: OSWindowPtr -> (Int,Int) -> IO ()+winSetClientSize hwnd (w,h)+	= issueCleanRequest2 (errorCallback2 "winSetClientSize") (rq3Cci ccRqSETCLIENTSIZE hwnd w h) >> return ()++winSetWindowSize :: OSWindowPtr -> (Int,Int) -> Bool -> IO ()+winSetWindowSize hwnd (w,h) update+	= issueCleanRequest2 (errorCallback2 "winSetWindowSize") (rq4Cci ccRqSETWINDOWSIZE hwnd w h (fromBool update)) >> return ()++winGetWindowPos :: OSWindowPtr -> IO (Int,Int)+winGetWindowPos hwnd+	= do {+		rcci <- issueCleanRequest2 (errorCallback2 "winGetWindowPos") (rq1Cci ccRqGETWINDOWPOS hwnd);+		let msg = ccMsg rcci+		in  if   msg==ccRETURN2+		    then return (p1 rcci,p2 rcci)+		    else if   msg==ccWASQUIT+		         then return (0,0)+		         else error "[winGetWindowPos] expected ccRETURN2 value."+	  }++winSetWindowPos :: OSWindowPtr -> (Int,Int) -> Bool -> Bool -> IO ()+winSetWindowPos hwnd (x,y) update inclScrollbars+	= issueCleanRequest2 (errorCallback2 "winSetWindowPos") (rq5Cci ccRqSETWINDOWPOS hwnd x y (fromBool update) (fromBool inclScrollbars)) >> return ()++winSetScrollRange :: OSWindowPtr -> Int -> Int -> Int -> Bool -> IO ()+winSetScrollRange scrollHWND iBar min max redraw+	= issueCleanRequest2 (errorCallback2 "winSetScrollRange") (rq5Cci ccRqSETSCROLLRANGE scrollHWND iBar min max (fromBool redraw)) >> return ()+	+winSetScrollPos :: OSWindowPtr -> Int -> Int -> Int -> Int -> Int -> IO ()+winSetScrollPos scrollHWND iBar thumb maxx maxy extent+	= issueCleanRequest2 (errorCallback2 "winSetScrollPos") (rq6Cci ccRqSETSCROLLPOS scrollHWND iBar thumb maxx maxy extent) >> return ()++winSetScrollThumbSize :: OSWindowPtr -> Int -> Int -> Int -> Int -> Int -> IO ()+winSetScrollThumbSize scrollHWND iBar size maxx maxy extent+	= issueCleanRequest2 (errorCallback2 "winSetScrollThumbSize") (rq6Cci ccRqSETSCROLLSIZE scrollHWND iBar size maxx maxy extent) >> return ()++winSetEditSelection :: OSWindowPtr -> Int -> Int -> IO ()+winSetEditSelection editHWND first last+	= issueCleanRequest2 (errorCallback2 "winSetEditSelection") (rq3Cci ccRqSETEDITSELECTION editHWND first last) >> return ()++winShowControl :: OSWindowPtr -> Bool -> IO ()+winShowControl hwnd bool+	= issueCleanRequest2 (errorCallback2 "winShowControl") (rq2Cci ccRqSHOWCONTROL hwnd (fromBool bool)) >> return ()++winEnableControl :: OSWindowPtr -> Bool -> IO ()+winEnableControl hwnd bool+	= issueCleanRequest2 (errorCallback2 "winEnableControl") (rq2Cci ccRqENABLECONTROL hwnd (fromBool bool)) >> return ()++winCheckControl :: OSWindowPtr -> Bool -> IO ()+winCheckControl hwnd bool+	= issueCleanRequest2 (errorCallback2 "winCheckControl") (rq2Cci ccRqSETITEMCHECK hwnd (fromBool bool)) >> return ()++winSelectPopupItem :: OSWindowPtr -> Int -> IO ()+winSelectPopupItem hwnd pos+	= issueCleanRequest2 (errorCallback2 "winSelectPopupItem") (rq2Cci ccRqSELECTPOPUPITEM hwnd pos) >> return ()+	+winSelectListBoxItem :: OSWindowPtr -> Int -> IO ()+winSelectListBoxItem hwnd pos+	= issueCleanRequest2 (errorCallback2 "winSelectPopupItem") (rq2Cci ccRqSELECTLISTBOXITEM hwnd pos) >> return ()++winMarkListBoxItem :: OSWindowPtr -> Int -> Bool -> IO ()+winMarkListBoxItem hwnd pos mark+	= issueCleanRequest2 (errorCallback2 "winSelectPopupItem") (rq3Cci ccRqMARKLISTBOXITEM hwnd pos (fromBool mark)) >> return ()++winCreateCaret :: OSWindowPtr -> Int -> Int -> IO ()+winCreateCaret hwnd width height+	= issueCleanRequest2 (errorCallback2 "winCreateCaret") (rq3Cci ccRqCREATECARET hwnd width height) >> return ()+	+winSetCaretPos :: OSWindowPtr -> Int -> Int -> IO ()+winSetCaretPos hwnd x y+	= issueCleanRequest2 (errorCallback2 "winSetCaretPos") (rq3Cci ccRqSETCARETPOS hwnd x y) >> return ()+	+winDestroyCaret :: OSWindowPtr -> IO ()+winDestroyCaret hwnd+	= issueCleanRequest2 (errorCallback2 "winDestroyCaret") (rq1Cci ccRqDESTROYCARET hwnd) >> return ()
+ Graphics/UI/ObjectIO/OS/WindowEvent.hs view
@@ -0,0 +1,1074 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.WindowEvent+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- OS.WindowEvent defines the DeviceEventFunction for the window device.+-- This function is placed in a separate module because it is platform dependent.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.OS.WindowEvent (windowEvent, module Graphics.UI.ObjectIO.Process.IOState) where+++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Control.Create+import Graphics.UI.ObjectIO.Device.Events+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.StdControlAttribute+import Graphics.UI.ObjectIO.StdWindowAttribute(isWindowKeyboard, getWindowKeyboardAtt, isWindowMouse, getWindowMouseAtt)+import Graphics.UI.ObjectIO.Window.Access+import Graphics.UI.ObjectIO.OS.ClCCall_12+import Graphics.UI.ObjectIO.OS.ClCrossCall_12+import Graphics.UI.ObjectIO.OS.Event+import Graphics.UI.ObjectIO.OS.WindowCrossCall_12+import Graphics.UI.ObjectIO.OS.Window(fromOSscrollbarRange, osScrollbarsAreVisible)+import Graphics.UI.ObjectIO.OS.Cutil_12 (int2addr)+import Graphics.UI.ObjectIO.Id(IdParent(..))+import Data.Bits		-- Defines .&. for bitand;+import Data.Int			-- Defines Int32 instance for Bits;+import Data.IORef+import qualified Data.Map as Map (lookup)+import Data.Maybe(fromJust)++++windoweventFatalError :: String -> String -> x+windoweventFatalError function error+	= dumpFatalError function "OS.WindowEvent" error+++{-	windowEvent filters the scheduler events that can be handled by this window device.+	For the time being no timer controls are added, so these events are ignored.+	windowEvent assumes that it is not applied to an empty IOSt.+-}+windowEvent :: IOSt ps -> SchedulerEvent -> IO (Bool,Maybe DeviceEvent,SchedulerEvent)+windowEvent ioState schedulerEvent+	| not (ioStHasDevice WindowDevice ioState)		-- This condition should never occur: WindowDevice must have been 'installed'+		= windoweventFatalError "dEvent windowFunctions" "could not retrieve WindowSystemState from IOSt"+	| otherwise+		= windowEvent2 ioState schedulerEvent+	where+		windowEvent2 :: IOSt ps -> SchedulerEvent -> IO (Bool,Maybe DeviceEvent,SchedulerEvent)++		windowEvent2 ioState schedulerEvent@(ScheduleOSEvent osEvent _)+			| isNothing maybe_filterFun+				= return (False,Nothing,schedulerEvent)+			| otherwise+				= do {+					(myEvent,replyToOS,deviceEvent)+					     <- fromJust maybe_filterFun wMetrics osEvent windows;+--					appIOEnv (ioStSetDevice (WindowSystemState windows));+					let schedulerEvent1 = if   isJust replyToOS+					                      then ScheduleOSEvent osEvent (fromJust replyToOS)+					                      else schedulerEvent+					in  return (myEvent,deviceEvent,schedulerEvent1)+				  }+			where+				(_,wDevice) 	= ioStGetDevice WindowDevice ioState+				wMetrics    	= ioStGetOSWindowMetrics ioState+				context   	= ioStGetContext ioState+				windows     	= windowSystemStateGetWindowHandles wDevice+				maybe_filterFun+					= lookup (ccMsg osEvent)+					         [+						   (ccWmACTIVATE,        filterACTIVATE)+						 , (ccWmBUTTONCLICKED,   filterBUTTONCLICKED)+						 , (ccWmCLOSE,           filterCLOSE)+						 , (ccWmITEMSELECT,      filterITEMSELECT)+						 , (ccWmDEACTIVATE,      filterDEACTIVATE)+					         , (ccWmDRAWCONTROL,     filterDRAWCONTROL)+						 , (ccWmIDLEDIALOG,      filterIDLEDIALOG)+						 , (ccWmINITDIALOG,      filterINITDIALOG)+						 , (ccWmKEYBOARD,        filterKEYBOARD context)+					      	 , (ccWmKILLFOCUS,       filterKILLFOCUS)+					         , (ccWmLOSTKEY,         filterLOSTKEY)+					         , (ccWmLOSTMOUSE,       filterLOSTMOUSE)+					         , (ccWmMOUSE,           filterMOUSE context)+					         , (ccWmPAINT,           filterPAINT)+					         , (ccWmSCROLLBARACTION, filterSCROLLBARACTION)+						 , (ccWmSETFOCUS,        filterSETFOCUS)+					         , (ccWmSIZE,            filterSIZE)+					         , (ccWmSPECIALBUTTON,   filterSPECIALBUTTON)+					         ]++		windowEvent2 ioState schedulerEvent@(ScheduleMsgEvent rId) = do+			iocontext <- readIORef (ioStGetContext ioState)+			case Map.lookup rId (ioContextGetIdTable iocontext) of+				Just idParent | idpIOId idParent == ioStGetIOId ioState && idpDevice idParent == WindowDevice ->+					let+						(_,wDevice)	= ioStGetDevice WindowDevice ioState+						windows		= windowSystemStateGetWindowHandles wDevice+						found 		= hasWindowHandlesWindow (toWID (idpId idParent)) windows+						deviceEvent	= if found then Just (ReceiverEvent rId) else Nothing+					in+						return (found,deviceEvent,schedulerEvent)+				_ ->+					return (False,Nothing,schedulerEvent)+			++{-	Because Haskell has no support for macros the function filterOSEvent that was defined by+	pattern matching on the ccWmXXX messages has now been split into distinct functions named+	filterXXX.+	No check is performed on the correct ccMsg field of the OSEvent argument.+	In this implementation not all events are handled. These have been placed in comments.+	They have however already been given the proper name and type.+-}++filterACTIVATE :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterACTIVATE _ (CrossCallInfo {p1=wptr}) windows+	| not found+		= return (False,Nothing,Nothing)+	| active                             -- The window is already active, skip+		= return (True,Nothing,Nothing)+	| otherwise+		= let windows2    = setWindowHandlesWindow wsH windows1+		      activeModal = getWindowHandlesActiveModalDialog windows2+		  in+		      return (True,Nothing,if isJust activeModal then Just (WindowInitialise wids) else Just (WindowActivation wids))+	where+		(found, wsH,windows1) = getWindowHandlesWindow (toWID wptr) windows+		active = getWindowStateHandleActive wsH+		wids   = getWindowStateHandleWIDS   wsH++filterBUTTONCLICKED :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterBUTTONCLICKED _ (CrossCallInfo {p1=wptr,p2=cptr,p3=mods,p4=toolbarIndex}) windows+	| not found+		= return (False,Nothing,Nothing)+	| not (getWindowStateHandleSelect wsH)+		= return (True,Nothing,Nothing)+	| otherwise+		= let wids 		 = getWindowStateHandleWIDS wsH+		      controlSelectInfo  =+		      		case getControlsItemNr cptr wsH of+		      			Nothing     -> Nothing+		      			Just itemNr -> Just (ControlSelection+							(ControlSelectInfo+							    { csWIDS      = wids+							    , csItemNr    = itemNr+							    , csItemPtr   = cptr+							    , csMoreData  = 0+							    , csModifiers = toModifiers mods+							    }+						    	)   )+		  in  return (True,Nothing,controlSelectInfo)+	where+		(found,wsH,_)	= getWindowHandlesWindow (toWID wptr) windows+++		getControlsItemNr :: OSWindowPtr -> WindowStateHandle ps -> Maybe Int+		getControlsItemNr cPtr (WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=(WindowHandle {whItems=whItems})})))+			= getControlsItemNr cPtr whItems+			where+				getControlsItemNr :: OSWindowPtr -> [WElementHandle ls ps] -> Maybe Int+				getControlsItemNr cPtr (itemH:itemHs) =+					case getControlItemNr cPtr itemH of+						Nothing -> getControlsItemNr cPtr itemHs+						Just n  -> Just n+					where+						getControlItemNr :: OSWindowPtr -> (WElementHandle ls ps) -> Maybe Int+						getControlItemNr cPtr itemH@(WItemHandle {wItemPtr=wItemPtr})+							| cPtr==wItemPtr		= Just itemNr+							| itemKind==IsRadioControl	=+								if itemSelect && any (\RadioItemInfo{radioItemPtr=radioItemPtr}->radioItemPtr==cPtr) (radioItems (getWItemRadioInfo info))+								then Just itemNr+								else Nothing+							| itemKind==IsCheckControl	=+								if itemSelect && any (\CheckItemInfo{checkItemPtr=checkItemPtr}->checkItemPtr==cPtr) (checkItems (getWItemCheckInfo info))+								then Just itemNr+								else Nothing+							| itemSelect && (wItemShow itemH) =+								getControlsItemNr cPtr (wItems itemH)+							| otherwise			= Nothing+							where+								info		= wItemInfo itemH+								itemKind	= wItemKind itemH+								itemSelect	= wItemSelect itemH+								itemNr		= wItemNr itemH++						getControlItemNr cPtr (WListLSHandle itemHs)+							= getControlsItemNr cPtr itemHs++						getControlItemNr cPtr (WExtendLSHandle ls1 itemHs)+							= getControlsItemNr cPtr itemHs++						getControlItemNr cPtr (WChangeLSHandle ls1 itemHs)+							= getControlsItemNr cPtr itemHs++				getControlsItemNr _ _+					= Nothing++		getControlsItemNr _ _ = windoweventFatalError "filterBUTTONCLICKED" "window placeholder not expected"++++filterCLOSE :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterCLOSE _ (CrossCallInfo {p1=wPtr}) windows+	| not found+		= return (False,Nothing,Nothing)+	| otherwise+		= let wids = getWindowStateHandleWIDS wsH+		  in  return (True,Nothing,Just (WindowRequestClose wids))+	where+		(found,wsH,_)  = getWindowHandlesWindow (toWID wPtr) windows++filterITEMSELECT :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterITEMSELECT _ (CrossCallInfo {ccMsg=ccWm,p1=wPtr,p2=cPtr,p3=index}) windows+	| not found+		= return (False,Nothing,Nothing)+	| not (getWindowStateHandleSelect wsH)+		= return (True,Nothing,Nothing)+	| otherwise =+		let+			wids			= getWindowStateHandleWIDS wsH+		  	itemNr			= getControlItemNr cPtr wsH+		  	controlSelectInfo	= if (itemNr==0) then Nothing	-- itemNrs are always > 0+						  else 	(Just (ControlSelection (ControlSelectInfo+						  			{csWIDS		= wids+									,csItemNr	= itemNr+									,csItemPtr	= cPtr+									,csMoreData	= index+1+									,csModifiers	= noModifiers+									}))+							)+		in return (True,Nothing,controlSelectInfo)+	where+		(found,wsH,_) 	= getWindowHandlesWindow (toWID wPtr) windows++		getControlItemNr :: OSWindowPtr -> WindowStateHandle ps -> Int+		getControlItemNr cPtr wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=wH@(WindowHandle {whItems=whItems})}))) =+			case getControlsItemNr cPtr whItems of+				Just itemNr -> itemNr+				Nothing	    -> 0+			where+				getControlsItemNr :: OSWindowPtr -> [WElementHandle ls ps] -> Maybe Int+				getControlsItemNr cPtr (itemH:itemHs) =+					case getControlItemNr cPtr itemH of+						Nothing 	-> getControlsItemNr cPtr itemHs+						x		-> x+					where+						getControlItemNr :: OSWindowPtr -> WElementHandle ls ps -> Maybe Int+						getControlItemNr cPtr itemH@(WItemHandle {wItemPtr=wItemPtr,wItemNr=wItemNr,wItemKind=wItemKind,wItemSelect=wItemSelect,wItemShow=wItemShow,wItems=wItems})+							| cPtr==wItemPtr+								= Just (if (wItemKind==IsPopUpControl || wItemKind==IsListBoxControl) && wItemSelect && wItemShow then wItemNr else 0)+							| wItemShow+								= getControlsItemNr cPtr wItems+							| otherwise+								= Nothing++						getControlItemNr cPtr (WListLSHandle itemHs)+							= getControlsItemNr cPtr itemHs++						getControlItemNr cPtr (WExtendLSHandle ls1 itemHs)+							= getControlsItemNr cPtr itemHs++						getControlItemNr cPtr (WChangeLSHandle ls1 itemHs)+							= getControlsItemNr cPtr itemHs++				getControlsItemNr _ []+					= Nothing++		getControlItemNr _ _+			= windoweventFatalError "getControlItemNr" "window placeholder not expected"++filterDEACTIVATE :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterDEACTIVATE _ (CrossCallInfo {p1=wptr}) windows+	| not found+		= return (False,Nothing,Nothing)+	| not active                         -- The window is already inactive, skip+	        = return (True,Nothing,Nothing)+	| otherwise+		= let windows2    = setWindowHandlesWindow wsH windows1+		      activeModal = getWindowHandlesActiveModalDialog windows2+		  in  return (True,Nothing,if isJust activeModal then Nothing else Just (WindowDeactivation wids))+	where+		(found,wsH,windows1)  = getWindowHandlesWindow (toWID wptr) windows+		active	= getWindowStateHandleActive wsH+		wids	= getWindowStateHandleWIDS wsH++filterDRAWCONTROL :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterDRAWCONTROL _ (CrossCallInfo {p1=wPtr,p2=cPtr,p3=gc}) windows+    | not found+	    = return (False,Nothing,Nothing)+    | otherwise	=+	    let controls = getUpdateControls cPtr wsH+		updateInfo = if null controls then Nothing+			     else (Just (WindowUpdate (UpdateInfo {updWIDS=wids,updWindowArea=zero,updControls=controls,updGContext=Just (int2addr gc)})))+	    in return (True,Nothing,updateInfo)+    where+	(found,wsH,windows1)	= getWindowHandlesWindow (toWID wPtr) windows+	wids = getWindowStateHandleWIDS wsH++	getUpdateControls :: OSWindowPtr -> WindowStateHandle ps -> [ControlUpdateInfo]+	getUpdateControls cPtr wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=wH@(WindowHandle {whItems=whItems,whSize=whSize})}))) =+	    fromJust (getUpdateControls cPtr (sizeToRect whSize) whItems)+	    where+		getUpdateControls :: OSWindowPtr -> Rect -> [WElementHandle ls ps] -> Maybe [ControlUpdateInfo]+		getUpdateControls cPtr clipRect (itemH:itemHs) =+			case getUpdateControl cPtr clipRect itemH of+			    Just controls -> Just controls+			    Nothing	  -> getUpdateControls cPtr clipRect itemHs+			where+			    getUpdateControl :: OSWindowPtr -> Rect -> WElementHandle ls ps -> Maybe [ControlUpdateInfo]+			    getUpdateControl cPtr clipRect itemH@(WItemHandle {wItemPtr=wItemPtr,wItemNr=wItemNr,wItemShow=wItemShow,wItemPos=wItemPos,wItemSize=wItemSize,wItems=wItems})+				    | cPtr==wItemPtr+					    = Just [ControlUpdateInfo {cuItemNr=wItemNr,cuItemPtr=wItemPtr,cuArea=clipRect1}]+				    | wItemShow = getUpdateControls cPtr clipRect1 wItems+				    | otherwise = Nothing+				    where+					    clipRect1 = intersectRects clipRect (posSizeToRect wItemPos wItemSize)++			    getUpdateControl cPtr clipRect (WListLSHandle itemHs) =+				    getUpdateControls cPtr clipRect itemHs++			    getUpdateControl cPtr clipRect (WExtendLSHandle exLS itemHs) =+				    getUpdateControls cPtr clipRect itemHs++			    getUpdateControl cPtr clipRect (WChangeLSHandle chLS itemHs) =+				    getUpdateControls cPtr clipRect itemHs++		getUpdateControls _ _ [] = Nothing++	getUpdateControls _ _+		= windoweventFatalError "getUpdateControls" "placeholder not expected"++{-	ccWmIDLEDIALOG is sent after a modal dialogue and its controls have been created.+		At that moment the initialisation action can be evaluated. This is done by the+		WindowInitialise device event.+-}+filterIDLEDIALOG :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterIDLEDIALOG _ (CrossCallInfo {p1=wptr}) windows+	| isNothing maybeWIDS+		= return (False,Nothing,Nothing)+	| wptr/=wPtr wids+		= return (False,Nothing,Nothing)+	| otherwise+		= return (True,Nothing,Just (WindowInitialise (fromJust maybeWIDS)))+	where+		maybeWIDS = getWindowHandlesActiveModalDialog windows+		wids      = fromJust maybeWIDS+++{-	ccWmINITDIALOG is generated for modal dialogs. It contains the ptr to the modal dialog.+	It is assumed that the current active window is the modal dialogue, with a zero ptr.+	filterINITDIALOG updates the ptr field and returns the WindowCreateControls DeviceEvent.+	This causes the WindowDevice dDoIO function to create all the controls of the+	dialog.+	Note that CcWmINITDIALOG now replies to the OS only the desired position, and size.+	The focus control set to 0 as it will be set by windowCreateControls.+-}+filterINITDIALOG :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterINITDIALOG wMetrics (CrossCallInfo {p1=wptr}) windows+	| isNothing maybeWIDS+		= return (False,Nothing,Nothing)+	| wPtr wids/=0+		= return (False,Nothing,Nothing)+	| otherwise+		= return (True,Just (getDialogMetrics wsH),Just (WindowCreateControls (wids {wPtr=wptr})))+	where+		maybeWIDS = getWindowHandlesActiveWindow windows+		wids      = fromJust maybeWIDS+		(_,wsH,_) = getWindowHandlesWindow (toWID (0::OSWindowPtr)) windows++		getDialogMetrics :: WindowStateHandle ps -> [Int]+		getDialogMetrics (WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=wH})))+			= [-1,-1,w size,h size]+			where+				size  = whSize wH+		getDialogMetrics _+			= windoweventFatalError "getDialogMetrics" "placeholder not expected"++{-	ccWmKEYBOARD events are generated for windows/dialogues and keyboard sensitive+	controls.+	In this implementation windows/dialogues are ignored (p1==p2 in the OSEvent argument).+	The system also does not keep track of what GUI element has the keyboard input focus.+-}+filterKEYBOARD :: Context -> OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterKEYBOARD context _ (CrossCallInfo {p1=wptr,p2=cptr,p3=keycode,p4=state,p5=mods}) windows+	= let (found,wsH,_) = getWindowHandlesWindow (toWID wptr) windows+	  in+	  if   not found+	  then return (False,Nothing,Nothing)+	  else if   wptr==cptr			-- The keyboard action takes place in the window+	       then do+	          iocontext <- readIORef context+	          let inputTrack = ioContextGetInputTrack iocontext+		  let (deviceEvent,newInputTrack) = getWindowKeyboardEvent wsH inputTrack+		  let iocontext1 = ioContextSetInputTrack newInputTrack iocontext+		  writeIORef context iocontext1+		  return (True,Nothing,deviceEvent)+	       else return (True,Nothing,getControlKeyboardEvent wsH)+	where+		getControlKeyboardEvent :: WindowStateHandle ps -> Maybe DeviceEvent+		getControlKeyboardEvent (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH})))+			= accessWElementHandles (whItems wH)+			where				+				accessWElementHandles :: [WElementHandle ls ps] -> Maybe DeviceEvent+				accessWElementHandles (itemH:itemHs)+					= let maybe = accessWElementHandle itemH+					  in  if   isJust maybe+					      then maybe+					      else accessWElementHandles itemHs+					where+						accessWElementHandle :: WElementHandle ls ps -> Maybe DeviceEvent+						accessWElementHandle (WListLSHandle itemHs)+							= accessWElementHandles itemHs+						accessWElementHandle (WExtendLSHandle addLS itemHs)+							= accessWElementHandles itemHs+						accessWElementHandle (WChangeLSHandle newLS itemHs)+							= accessWElementHandles itemHs+						accessWElementHandle itemH@(WItemHandle {wItemNr=wItemNr,wItemAtts=wItemAtts})+							| cptr==wItemPtr itemH+								= if filter keystate+									then Just (ControlKeyboardAction+			                                                              (ControlKeyboardActionInfo+			                                                                  { ckWIDS          = wids+			                                                                  , ckItemNr        = wItemNr+			                                                                  , ckItemPtr       = cptr+			                                                                  , ckKeyboardState = keystate+			                                                                  }+			                                                          )   )+									else Nothing+							| otherwise = accessWElementHandles (wItems itemH)+							where+								(filter,_,_)  = getControlKeyboardAtt (snd (cselect isControlKeyboard (ControlKeyboard (const False) Unable undefined) wItemAtts))+				accessWElementHandles [] = Nothing+		getControlKeyboardEvent _ = windowaccessFatalError "getControlKeyboardEvent" "window placeholder not expected"+		++		getWindowKeyboardEvent :: WindowStateHandle ps -> Maybe InputTrack -> (Maybe DeviceEvent,Maybe InputTrack)+		getWindowKeyboardEvent wsH@(WindowStateHandle wids (Just (WindowLSHandle {wlsHandle=(WindowHandle {whKind=whKind,whWindowInfo=whWindowInfo,whAtts=whAtts})}))) inputTrack+		    | whKind==IsDialog = (Nothing,inputTrack)+		    | trackingKeyboard wptr 0 inputTrack =			-- Window is already handle Key(Repeat/Up)+			    if isDownKey then (Nothing,inputTrack)		-- Ignore all key down events+			    else (mb_event,if pressState==KeyUp then untrackKeyboard inputTrack else inputTrack)	-- Clear keyboard tracking+		    | isDownKey = (mb_event,trackKeyboard wptr 0 inputTrack)	-- Key down sets input track+		    | otherwise = (Nothing,inputTrack)+		    where+		    	mb_event =+		    		if filter keystate && selectState==Able +		    			then Just (WindowKeyboardAction (WindowKeyboardActionInfo {wkWIDS=wids,wkKeyboardState=keystate})) +		    			else Nothing+			pressState		= getKeyboardStateKeyState keystate+			isDownKey		= pressState==KeyDown False+			(filter,selectState,_)	= getWindowKeyboardAtt (snd (cselect isWindowKeyboard (WindowKeyboard (const False) Unable undefined) whAtts))+		getWindowKeyboardEvent _ _ = windoweventFatalError "getWindowKeyboardEvent" "placeholder not expected"++		keystate :: KeyboardState+		keystate+			| isJust maybeSpecial = SpecialKey (fromJust maybeSpecial) ks modifiers+			| otherwise           = CharKey (toEnum keycode) ks	-- toChar --> toEnum+			where+				modifiers       = toModifiers mods+				ks              = fromJust $ lookup state+							[(keyDOWN,  KeyDown False)+							,(keyREPEAT,KeyDown True)+							,(keyUP,    KeyUp)+							]+				maybeSpecial    = lookup keycode+							[(winBackSpKey,backSpaceKey)+							,(winBeginKey, beginKey)+							,(winDelKey,   deleteKey)+							,(winDownKey,  downKey)+							,(winEndKey,   endKey)+							,(winEscapeKey,escapeKey)+							,(winHelpKey,  helpKey)+							,(winLeftKey,  leftKey)+							,(winPgDownKey,pgDownKey)+							,(winPgUpKey,  pgUpKey)+							,(winReturnKey,enterKey)+							,(winRightKey, rightKey)+							,(winUpKey,    upKey)+							,(winF1Key,    f1Key)+							,(winF2Key,    f2Key)+							,(winF3Key,    f3Key)+							,(winF4Key,    f4Key)+							,(winF5Key,    f5Key)+							,(winF6Key,    f6Key)+							,(winF7Key,    f7Key)+							,(winF8Key,    f8Key)+							,(winF9Key,    f9Key)+							,(winF10Key,   f10Key)+							,(winF11Key,   f11Key)+							,(winF12Key,   f12Key)+							]++filterKILLFOCUS :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterKILLFOCUS _ (CrossCallInfo {p1=wPtr,p2=cPtr}) windows+	= let (found,wsH,windows1)	= getWindowHandlesWindow (toWID wPtr) windows+	  in+	    if not found+	    then return (False,Nothing,Nothing)+	    else let wids = getWindowStateHandleWIDS wsH+	         in case getControlKeyFocusItemNr False cPtr wsH of+	            	Nothing     -> return (True,Nothing,Nothing)+	            	Just itemNr -> return (True,Nothing,Just (ControlLooseKeyFocus (ControlKeyFocusInfo {ckfWIDS=wids,ckfItemNr=itemNr,ckfItemPtr=cPtr})))+++filterLOSTKEY :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterLOSTKEY _ (CrossCallInfo {p1=wPtr,p2=cPtr}) windows =+	let (found,wsH,windows1) = getWindowHandlesWindow (toWID wPtr) windows+	in+	  if not found || not (getWindowStateHandleSelect wsH)+	  then return (found,Nothing,Nothing)+	  else+	    let wids = getWindowStateHandleWIDS wsH+	    in+	      if wPtr==cPtr then	-- The window lost the keyboard input+		let info = WindowKeyboardActionInfo+			{ wkWIDS=wids+			, wkKeyboardState=KeyLost+			}+		    deviceEvent = if okWindowKeyLost wsH then Just (WindowKeyboardAction info) else Nothing+		in return (True,Nothing,deviceEvent)+	      else+		let (ok,itemNr)	= okControlItemNrsKeyLost cPtr wsH+		    info = ControlKeyboardActionInfo+		        { ckWIDS	  = wids+			, ckItemNr	  = itemNr+			, ckItemPtr	  = cPtr+			, ckKeyboardState = KeyLost+			}+		    deviceEvent	= if (ok && itemNr>0) then (Just (ControlKeyboardAction info)) else Nothing+		in return (True,Nothing,deviceEvent)+	where+		okWindowKeyLost :: WindowStateHandle ps -> Bool+		okWindowKeyLost (WindowStateHandle wids' (Just (WindowLSHandle {wlsHandle=(WindowHandle {whKind=whKind,whAtts=whAtts})})))+		    | whKind==IsDialog = False+		    | otherwise =+			 if filter KeyLost && selectState==Able+			 then True+			 else False+		    where+		       (filter,selectState,_) = getWindowKeyboardAtt (snd (cselect isWindowKeyboard (WindowKeyboard (const False) Unable undefined) whAtts))+		okWindowKeyLost _+			= windoweventFatalError "okWindowKeyLost" "placeholder not expected"++		okControlItemNrsKeyLost :: OSWindowPtr -> WindowStateHandle ps -> (Bool,Int)+		okControlItemNrsKeyLost itemPtr (WindowStateHandle wids' (Just (WindowLSHandle {wlsHandle=(WindowHandle {whItems=whItems})}))) =+		     fromJust (okControlsItemNrKeyLost True itemPtr whItems)+		     where+			okControlsItemNrKeyLost :: Bool -> OSWindowPtr -> [WElementHandle ls ps] -> Maybe (Bool,Int)+			okControlsItemNrKeyLost contextAble itemPtr (itemH:itemHs) =+			    case okControlItemNrKeyLost contextAble itemPtr itemH of+			      Just x -> Just x+			      Nothing -> okControlsItemNrKeyLost contextAble itemPtr itemHs+			    where+				okControlItemNrKeyLost :: Bool -> OSWindowPtr -> WElementHandle ls ps -> Maybe (Bool,Int)+				okControlItemNrKeyLost contextAble itemPtr itemH@(WItemHandle {wItemPtr=wItemPtr,wItemNr=wItemNr,wItemSelect=wItemSelect,wItemShow=wItemShow,wItemAtts=wItemAtts,wItems=wItems})+					| itemPtr /= wItemPtr =+						if wItemShow then okControlsItemNrKeyLost contextAble1 itemPtr wItems+						else Nothing+					| otherwise = Just (okKeyAtt,wItemNr)+					where+					  contextAble1= contextAble && wItemSelect+					  (filter,selectState,_) = getControlKeyboardAtt (snd (cselect isControlKeyboard (ControlKeyboard (const False) Unable undefined) wItemAtts))+					  okKeyAtt	= contextAble1 && enabled selectState && filter KeyLost++				okControlItemNrKeyLost contextAble itemPtr (WListLSHandle itemHs) =+					okControlsItemNrKeyLost contextAble itemPtr itemHs++				okControlItemNrKeyLost contextAble itemPtr (WExtendLSHandle _ itemHs) =+					okControlsItemNrKeyLost contextAble itemPtr itemHs++				okControlItemNrKeyLost contextAble itemPtr (WChangeLSHandle _ itemHs) =+					okControlsItemNrKeyLost contextAble itemPtr itemHs++			okControlsItemNrKeyLost _ _ [] = Nothing++		okControlItemNrsKeyLost _ _+			= windoweventFatalError "okControlItemNrsKeyLost" "placeholder not expected"+++filterLOSTMOUSE :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterLOSTMOUSE _ (CrossCallInfo {p1=wPtr,p2=cPtr}) windows+	| not found = return (False,Nothing,Nothing)+	| not able  = return (True, Nothing,Nothing)+	| wPtr==cPtr =	-- The window lost the mouse input		+	    let deviceEvent =+			if okWindowMouseLost wsH +			then (Just (WindowMouseAction (WindowMouseActionInfo {wmWIDS=wids,wmMouseState=MouseLost})))+			else Nothing+	    in return (True,Nothing,deviceEvent)+	| otherwise =		-- One of the window controls lost the mouse input+		let +			(ok,itemNr) = okControlItemNrsMouseLost cPtr wsH+			info = ControlMouseActionInfo+				{ cmWIDS	= wids+				, cmItemNr	= itemNr+				, cmItemPtr	= cPtr+				, cmMouseState	= MouseLost+				}+		     	deviceEvent = if ok && itemNr>0 then (Just (ControlMouseAction info)) else Nothing+		in return (True,Nothing,deviceEvent)+	where+		(found,wsH,windows1) = getWindowHandlesWindow (toWID wPtr) windows+		able		     = getWindowStateHandleSelect wsH+		wids		     = getWindowStateHandleWIDS wsH+	+		okWindowMouseLost :: WindowStateHandle ps -> Bool+		okWindowMouseLost (WindowStateHandle wids' (Just (WindowLSHandle {wlsHandle=(WindowHandle {whKind=whKind,whAtts=whAtts})})))+			| whKind==IsDialog = False+			| otherwise = okMouseAtt+			where+				(filter,selectState,_)	= getWindowMouseAtt (snd (cselect isWindowMouse (WindowMouse (const False) Unable undefined) whAtts))+				okMouseAtt		= filter MouseLost && selectState==Able+		okWindowMouseLost _ =+		    windoweventFatalError "okWindowMouseLost" "placeholder not expected"++		okControlItemNrsMouseLost :: OSWindowPtr -> WindowStateHandle ps -> (Bool,Int)+		okControlItemNrsMouseLost itemPtr (WindowStateHandle wids' (Just (WindowLSHandle {wlsHandle=(WindowHandle {whItems=whItems})}))) =+		    let (_,ok,itemNr) = okControlsItemNrMouseLost True itemPtr whItems+		    in (ok,itemNr)+		    where+			okControlsItemNrMouseLost :: Bool -> OSWindowPtr -> [WElementHandle ls ps] -> (Bool,Bool,Int)+			okControlsItemNrMouseLost contextAble itemPtr (itemH:itemHs) =+			    let (found,ok,itemNr) = okControlItemNrMouseLost contextAble itemPtr itemH+  			    in if found then (found,ok,itemNr)+			       else okControlsItemNrMouseLost contextAble itemPtr itemHs+			    where+				okControlItemNrMouseLost :: Bool -> OSWindowPtr -> WElementHandle ls ps -> (Bool,Bool,Int)+				okControlItemNrMouseLost contextAble itemPtr itemH@(WItemHandle {wItemPtr=wItemPtr,wItemNr=wItemNr,wItemSelect=wItemSelect,wItemShow=wItemShow,wItemAtts=wItemAtts,wItems=wItems})+					| itemPtr /= wItemPtr =+						if wItemShow+						then okControlsItemNrMouseLost contextAble1 itemPtr wItems							+						else (False,False,0)+					| otherwise = (True,okMouseAtt,wItemNr)+					where+						contextAble1= contextAble && wItemSelect+						(filter,selectState,_) = getControlMouseAtt (snd (cselect isControlMouse (ControlMouse (const False) Unable undefined) wItemAtts))+						okMouseAtt	= contextAble1 && enabled selectState && filter MouseLost++				okControlItemNrMouseLost contextAble itemPtr (WListLSHandle itemHs) =+					okControlsItemNrMouseLost contextAble itemPtr itemHs					++				okControlItemNrMouseLost contextAble itemPtr (WExtendLSHandle exLS itemHs) =+					okControlsItemNrMouseLost contextAble itemPtr itemHs++				okControlItemNrMouseLost contextAble itemPtr (WChangeLSHandle chLS itemHs) =+					okControlsItemNrMouseLost contextAble itemPtr itemHs++			okControlsItemNrMouseLost _ _ []+				= (False,False,0)++		okControlItemNrsMouseLost _ _+			= windoweventFatalError "okControlItemNrsMouseLost" "placeholder not expected"+++filterMOUSE :: Context -> OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterMOUSE context _ (CrossCallInfo {p1=wPtr,p2=cPtr,p3=action,p4=x,p5=y,p6=mods}) windows+	| not found = return (False,Nothing,Nothing)+	| not able  = return (True, Nothing,Nothing)+	| wPtr==cPtr =	-- The mouse action takes place in the window+	    do+	      	iocontext <- readIORef context+		let inputTrack = ioContextGetInputTrack iocontext+		let (ok,mouse,newInputTrack) = okWindowMouseState action (Point2{x=x,y=y}) wsH inputTrack+		let deviceEvent = if ok then (Just (WindowMouseAction (WindowMouseActionInfo {wmWIDS=wids,wmMouseState=mouse}))) else Nothing+		let iocontext1 = ioContextSetInputTrack newInputTrack iocontext+		writeIORef context iocontext1+	        return (True,Nothing,deviceEvent)++	| otherwise = do	 			-- The mouse action takes place in a control+		iocontext <- readIORef context+		let inputTrack = ioContextGetInputTrack iocontext+		let (ok,itemNr,mouse,newInputTrack) = okControlItemsNrMouseState wPtr cPtr action (Point2{x=x,y=y}) wsH inputTrack+		let iocontext1 = ioContextSetInputTrack newInputTrack iocontext+		writeIORef context iocontext1+		let info = ControlMouseActionInfo+				{ cmWIDS	= wids+				, cmItemNr	= itemNr+				, cmItemPtr	= cPtr+				, cmMouseState	= mouse+				}+		let deviceEvent	= if ok then Just (ControlMouseAction info) else Nothing		  +		return (True,Nothing,deviceEvent)+	where+		okWindowMouseState :: Int -> Point2 -> WindowStateHandle ps -> Maybe InputTrack+							   -> (Bool,MouseState,Maybe InputTrack)+		okWindowMouseState action eventPos (WindowStateHandle wids' (Just (WindowLSHandle {wlsHandle=(WindowHandle {whKind=whKind,whWindowInfo=windowInfo,whAtts=whAtts})}))) inputTrack+		    | whKind==IsDialog =+			  (False,undefined,inputTrack)+		    | trackingMouse wPtr 0 inputTrack =					-- Window is already handling Mouse(Drag/Up)+			  if isDownButton || buttonstate==ButtonStillUp 		-- Ignore all mouse down and mouse move events+			  then (False,undefined,inputTrack)+			  else if buttonstate==ButtonUp					-- Clear mouse tracking+			      then (okMouseAtt,mousestate,untrackMouse inputTrack)+			      else (okMouseAtt,mousestate,inputTrack)+		     | isDownButton =							-- Mouse down event sets input track+			  (okMouseAtt,mousestate,trackMouse wPtr 0 inputTrack)+		     | buttonstate `elem` [ButtonStillDown,ButtonUp]	=		-- Ignore all mouse drag and up events when not tracking+			  (False,undefined,inputTrack)+		     | otherwise =+			  (okMouseAtt,mousestate,inputTrack)+		     where+			origin			= windowOrigin windowInfo+			mousestate		= mouseState action (eventPos+origin)+			buttonstate		= getMouseStateButtonState mousestate+			isDownButton		= buttonstate `elem` [ButtonDown,ButtonDoubleDown,ButtonTripleDown]+			(filter,selectState,_)	= getWindowMouseAtt (snd (cselect isWindowMouse (WindowMouse (const False) Unable undefined) whAtts))+			okMouseAtt		= filter mousestate && selectState==Able+		okWindowMouseState _ _ _ _ =+		    windoweventFatalError "okWindowMouseState" "placeholder not expected"+			+			+		okControlItemsNrMouseState :: OSWindowPtr -> OSWindowPtr -> Int -> Point2 -> WindowStateHandle ps -> Maybe InputTrack+												   -> (Bool,Int,MouseState,Maybe InputTrack)+		okControlItemsNrMouseState wPtr itemPtr action eventPos (WindowStateHandle wids' (Just (WindowLSHandle {wlsHandle=(WindowHandle {whItems=whItems})}))) inputTrack =+	  	    let (_,ok,itemNr,itemPos,newInputTrack) = okControlsItemNrMouseState True wPtr itemPtr action eventPos whItems inputTrack+	  	    in (ok,itemNr,itemPos,newInputTrack)+   		    where+			okControlsItemNrMouseState :: Bool -> OSWindowPtr -> OSWindowPtr -> Int -> Point2 -> [WElementHandle ls ps] -> Maybe InputTrack+													   -> (Bool,Bool,Int,MouseState,Maybe InputTrack)+			okControlsItemNrMouseState contextAble wPtr itemPtr action eventPos (itemH:itemHs) inputTrack =+			    let res@(found,ok,itemNr,itemPos,newInputTrack) = okControlItemNrMouseState contextAble wPtr itemPtr action eventPos itemH inputTrack+			    in if found then res+			       else okControlsItemNrMouseState contextAble wPtr itemPtr action eventPos itemHs newInputTrack+			    where+				okControlItemNrMouseState :: Bool -> OSWindowPtr -> OSWindowPtr -> Int -> Point2 -> WElementHandle ls ps -> Maybe InputTrack+														   -> (Bool,Bool,Int,MouseState,Maybe InputTrack)+				okControlItemNrMouseState contextAble wPtr itemPtr action eventPos+										  itemH@(WItemHandle {wItemPtr=wItemPtr+										  		     ,wItemSelect=wItemSelect+										  		     ,wItemKind=wItemKind+										  		     ,wItemNr=wItemNr+										  		     ,wItemShow=wItemShow+										  		     ,wItemAtts=wItemAtts+										  		     ,wItems=wItems+										  		     ,wItemInfo=wItemInfo})+										  inputTrack+					| itemPtr /= wItemPtr =+						if wItemShow then okControlsItemNrMouseState contextAble1 wPtr itemPtr action eventPos wItems inputTrack+						else (False,False,0,undefined,inputTrack)+					| trackingMouse wPtr itemPtr inputTrack	=			-- Control is already handling Mouse(Drag/Up)+						if isDownButton || buttonstate==ButtonStillUp then	-- Ignore all mouse down and mouse move events+							(True,False,0,undefined,inputTrack)+						else +						   if buttonstate==ButtonUp then			-- Clear mouse tracking+							(True,okMouseAtt,wItemNr,mousestate,untrackMouse inputTrack)+						   else+							(True,okMouseAtt,wItemNr,mousestate,inputTrack)+					| isDownButton =										-- Mouse down event sets input track +						(True,okMouseAtt,wItemNr,mousestate,trackMouse wPtr itemPtr inputTrack)+					| buttonstate `elem` [ButtonStillDown,ButtonUp]	= -- Ignore all mouse drag and up events when not tracking+						(True,False,0,undefined,inputTrack)+					| otherwise =+						(True,okMouseAtt,wItemNr,mousestate,inputTrack)+					where+						contextAble1 = contextAble && wItemSelect+						(filter,selectState,_) = getControlMouseAtt (snd (cselect isControlMouse (ControlMouse (const False) Unable undefined) wItemAtts))+						okMouseAtt	= contextAble1 && enabled selectState && filter mousestate+						mousestate	= mouseState action (origin+eventPos)+						buttonstate	= getMouseStateButtonState mousestate+						isDownButton    = buttonstate `elem` [ButtonDown,ButtonDoubleDown,ButtonTripleDown]+						origin		= case wItemKind of+										IsCustomButtonControl	-> zero+										IsCustomControl		-> zero+										IsCompoundControl	-> compoundOrigin (getWItemCompoundInfo wItemInfo)+										_			-> windoweventFatalError "okControlItemsNrMouseState" "mouse event generated for unexpected control"++				okControlItemNrMouseState contextAble wPtr itemPtr action eventPos (WListLSHandle itemHs) inputTrack =+					okControlsItemNrMouseState contextAble wPtr itemPtr action eventPos itemHs inputTrack					++				okControlItemNrMouseState contextAble wPtr itemPtr action eventPos (WExtendLSHandle exLS itemHs) inputTrack =+					okControlsItemNrMouseState contextAble wPtr itemPtr action eventPos itemHs inputTrack					++				okControlItemNrMouseState contextAble wPtr itemPtr action eventPos (WChangeLSHandle chLS itemHs) inputTrack =+					okControlsItemNrMouseState contextAble wPtr itemPtr action eventPos itemHs inputTrack					++			okControlsItemNrMouseState _ _ _ _ _ [] inputTrack = (False,False,0,undefined,inputTrack)++		okControlItemsNrMouseState _ _ _ _ _ _+			= windoweventFatalError "okControlItemsNrMouseState" "placeholder not expected"+			+		(found,wsH,windows1)	= getWindowHandlesWindow (toWID wPtr) windows+		able			= getWindowStateHandleSelect wsH+		wids			= getWindowStateHandleWIDS wsH++		modifiers	= toModifiers mods+		nrDown		=+			if action == buttonDOWN       then 1 else+			if action == buttonDOUBLEDOWN then 2 else+			 				   3+		mouseState action pos =+			if action == buttonSTILLUP   then MouseMove pos modifiers else +			if action == buttonUP        then MouseUp   pos modifiers else +			if action == buttonSTILLDOWN then MouseDrag pos modifiers else +						          MouseDown pos modifiers nrDown+						     ++{-	The ccWmPAINT message is generated to update the indicated rectangle of the argument window. -}+filterPAINT :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterPAINT _ (CrossCallInfo {p1=wptr,p2=left,p3=top,p4=right,p5=bottom,p6=gc}) windows+	| not found+		= return (False,Nothing,Nothing)+	| otherwise+		= let wids 	  = getWindowStateHandleWIDS wsH+		      updRect     = fromTuple4 (left,top,right,bottom)+		      updateInfo  = UpdateInfo+		                       { updWIDS       = wids+		                       , updWindowArea = updRect+		                       , updControls   = []+		                       , updGContext   = if gc==0 then Nothing else Just (int2addr gc)+		                       }+		  in  return (True,Nothing,Just (WindowUpdate updateInfo))+	where+		(found,wsH,_)     = getWindowHandlesWindow (toWID wptr) windows+++filterSCROLLBARACTION :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterSCROLLBARACTION _ (CrossCallInfo {p1=wptr,p2=cPtr,p3=iBar,p4=action,p5=osThumb}) windows+  | not found = return (False,Nothing,Nothing)+  | not (getWindowStateHandleSelect wsH) = return (True,Nothing,Nothing)+  | otherwise =+	let wids = getWindowStateHandleWIDS wsH+	    sliderEvent = getSlidersEvent wids iBar osThumb cPtr wsH+	in return (True,Nothing,Just sliderEvent)+  where+     (found,wsH,windows1) = getWindowHandlesWindow (toWID wptr) windows++     getSlidersEvent :: WIDS -> Int -> Int -> OSWindowPtr -> WindowStateHandle ps -> DeviceEvent+     getSlidersEvent wids iBar osThumb itemPtr (WindowStateHandle wids' (Just (WindowLSHandle {wlsHandle=wH@(WindowHandle {whWindowInfo=windowInfo,whItems=itemHs,whSize=Size w h})})))+	 | wPtr wids == itemPtr =+	 	let isHorizontal		= iBar==sb_HORZ+		    info = WindowScrollActionInfo+		    	{ wsaWIDS	= wids+			, wsaSliderMove	= move min max view osThumb+			, wsaDirection	= if isHorizontal then Horizontal else Vertical+			}+		    domainRect	= windowDomain windowInfo+		    (min,max,view) = if isHorizontal then (rleft domainRect,rright domainRect, w)+				     else (rtop domainRect, rbottom domainRect, h)+		in WindowScrollAction info+	| otherwise =+		case getSlidersEvent wids iBar osThumb itemPtr itemHs of+		  Just sliderEvent -> sliderEvent+		  Nothing	   -> windoweventFatalError "getSlidersEvent" "SliderControl could not be located"+		where+		  getSlidersEvent :: WIDS -> Int -> Int -> OSWindowPtr -> [WElementHandle ls ps] -> Maybe DeviceEvent+		  getSlidersEvent wids iBar osThumb itemPtr (itemH:itemHs) =+		      case getSliderEvent wids iBar osThumb itemPtr itemH of+		         Just sliderEvent -> Just sliderEvent+		         Nothing 	  -> getSlidersEvent wids iBar osThumb itemPtr itemHs+		      where+			  getSliderEvent :: WIDS -> Int -> Int -> OSWindowPtr -> WElementHandle ls ps -> Maybe DeviceEvent+			  getSliderEvent wids iBar osThumb itemPtr itemH@(WItemHandle {wItemPtr=wItemPtr,wItemNr=wItemNr,wItemKind=wItemKind,wItemShow=wItemShow,wItems=itemHs,wItemInfo=wItemInfo,wItemSize=Size w h})+			      | itemPtr /= wItemPtr =+				      if wItemShow then getSlidersEvent wids iBar osThumb itemPtr itemHs+				      else Nothing+			      | wItemKind==IsCompoundControl =+				      let isHorizontal	= iBar==sb_HORZ+					  info = CompoundScrollActionInfo+					  	{ csaWIDS	= wids+						, csaItemNr	= wItemNr+						, csaItemPtr	= itemPtr+						, csaSliderMove	= move min max view osThumb+						, csaDirection	= if isHorizontal then Horizontal else Vertical+						}+					  compoundInfo	= getWItemCompoundInfo wItemInfo+					  domainRect		= compoundDomain compoundInfo+					  (min,max,view)	= if isHorizontal then (rleft domainRect,rright domainRect, w)+								  else (rtop domainRect, rbottom domainRect,h)+				      in Just (CompoundScrollAction info)+			      | otherwise =+				      let info = ControlSliderInfo+				      		{ cslWIDS	= wids+						, cslItemNr	= wItemNr+						, cslItemPtr	= itemPtr+						, cslSliderMove	= move (sliderMin sliderState) (sliderMax sliderState) 0 osThumb+						}+					  sliderInfo	= getWItemSliderInfo wItemInfo+					  sliderState	= sliderInfoState sliderInfo+				      in Just (ControlSliderAction info)++			  getSliderEvent wids iBar osThumb itemPtr (WListLSHandle itemHs) =+			      getSlidersEvent wids iBar osThumb itemPtr itemHs++			  getSliderEvent wids iBar osThumb itemPtr (WExtendLSHandle exLS itemHs) =+			      getSlidersEvent wids iBar osThumb itemPtr itemHs++			  getSliderEvent wids iBar osThumb itemPtr (WChangeLSHandle chLS itemHs) =+			      getSlidersEvent wids iBar osThumb itemPtr itemHs++		  getSlidersEvent _ _ _ _ []+			= Nothing++     getSlidersEvent _ _ _ _ _+		= windoweventFatalError "getSlidersEvent" "placeholder not expected"++     move :: Int -> Int -> Int -> Int -> SliderMove+     move min max view osThumb = fromJust maybe_move+       where+	  maybe_move = lookup action+	     [ (sb_LINEUP,	SliderDecSmall)+	     , (sb_LINEDOWN,	SliderIncSmall)+	     , (sb_PAGEUP,	SliderDecLarge)+	     , (sb_PAGEDOWN,	SliderIncLarge)+	     , (sb_THUMBPOSITION,	SliderThumb (fromOSscrollbarRange (min,max) osThumb))+	     , (sb_THUMBTRACK,	SliderThumb (fromOSscrollbarRange (min,max) osThumb))+	     , (sb_TOP,		SliderThumb min)+	     , (sb_BOTTOM,	SliderThumb (max-view))+	     , (sb_ENDSCROLL,	SliderThumb (fromOSscrollbarRange (min,max) osThumb))+	     ]++++filterSETFOCUS :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterSETFOCUS _ (CrossCallInfo {p1=wPtr,p2=cPtr}) windows+	= let (found,wsH,windows1) = getWindowHandlesWindow (toWID wPtr) windows+	  in if not found+	     then return (False,Nothing,Nothing)+	     else let wids = getWindowStateHandleWIDS wsH+		  in case getControlKeyFocusItemNr True cPtr wsH of+		  	Nothing     -> return (True,Nothing,Nothing)+		  	Just itemNr -> return (True,Nothing,Just (ControlGetKeyFocus (ControlKeyFocusInfo {ckfWIDS=wids,ckfItemNr=itemNr,ckfItemPtr=cPtr})))+++filterSIZE :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterSIZE wMetrics (CrossCallInfo {p1=wptr,p2=w,p3=h,p4=usersizing}) windows+	| not found+		= return (False,Nothing,Nothing)+	| getWindowStateHandleWindowKind wsH ==IsDialog		-- This alternative should never occur+		= windoweventFatalError "filterSIZE" "WindowSizeAction event generated for Dialog"+	| otherwise+		= let wids = getWindowStateHandleWIDS wsH+		      info = getWindowStateHandleSize wids w h (usersizing/=0) wsH+		  in  return (True,Nothing,Just (WindowSizeAction info))+	where+		(found,wsH,windows1) = getWindowHandlesWindow (toWID wptr) windows++		getWindowStateHandleSize :: WIDS -> Int -> Int -> Bool -> WindowStateHandle ps -> WindowSizeActionInfo+		getWindowStateHandleSize wids newW newH usersizing wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=wH})))+			= WindowSizeActionInfo+			      { wsWIDS=wids+			      , wsSize=Size {w=newW',h=newH'}+			      , wsUpdateAll=not usersizing+			      }			  +			where+				windowInfo = whWindowInfo wH+				domainRect = windowDomain windowInfo+				hasScrolls = (isJust (windowHScroll windowInfo),isJust (windowVScroll windowInfo))+				(visHScroll,visVScroll)+				           = osScrollbarsAreVisible wMetrics domainRect (toTuple (whSize wH)) hasScrolls+				newW'      = if visVScroll then (newW+osmVSliderWidth  wMetrics) else newW	-- Correct newW in case of visible vertical   scrollbar+				newH'      = if visHScroll then (newH+osmHSliderHeight wMetrics) else newH	-- Correct newH in case of visible horizontal scrollbar+		getWindowStateHandleSize _ _ _ _ _+			= windoweventFatalError "getWindowStateHandleSize" "placeholder not expected"+++filterSPECIALBUTTON :: OSWindowMetrics -> OSEvent -> WindowHandles ps -> IO (Bool,Maybe [Int],Maybe DeviceEvent)+filterSPECIALBUTTON _ (CrossCallInfo {p1=wPtr,p2=okOrCancel}) windows =+	let (found,wsH,windows1) = getWindowHandlesWindow (toWID wPtr) windows+	in if not found then return (False,Nothing,Nothing)+	   else let wids = getWindowStateHandleWIDS wsH+		    okId	= getWindowStateHandleDefaultId wsH+		    cancelId	= getWindowStateHandleCancelId  wsH+		    okOrCancelEvent =+			if okOrCancel == isOKBUTTON     then (if (isJust okId)     then (Just (WindowOK wids))     else Nothing) else+		  	if okOrCancel == isCANCELBUTTON then (if (isJust cancelId) then (Just (WindowCANCEL wids)) else Nothing) else+		  	           windoweventFatalError "filterOSEvent (ccWmSPECIALBUTTON)" "incorrect argument"+		in return (True,Nothing,okOrCancelEvent)+++toModifiers :: Int -> Modifiers+toModifiers i+	= Modifiers+		{ shiftDown   = shifton+		, optionDown  = alton+		, commandDown = ctrlon+		, controlDown = ctrlon+		, altDown     = alton+		}+	where+		shifton = (i1 .&. (fromIntegral shiftBIT)) /= 0+		alton   = (i1 .&. (fromIntegral altBIT))   /= 0+		ctrlon  = (i1 .&. (fromIntegral ctrlBIT))  /= 0+		i1      = fromIntegral i :: Int32+++getControlKeyFocusItemNr :: Bool -> OSWindowPtr -> WindowStateHandle ps -> Maybe Int+getControlKeyFocusItemNr activated cPtr wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=wH})))+	= getControlsKeyFocusItemNr' activated cPtr (whItems wH)+	where+		getControlsKeyFocusItemNr' :: Bool -> OSWindowPtr -> [WElementHandle ls ps] -> Maybe Int+		getControlsKeyFocusItemNr' activated cPtr [] = Nothing+		getControlsKeyFocusItemNr' activated cPtr (itemH:itemHs) =+			case getControlKeyFocusItemNr' activated cPtr itemH of+				Nothing 	-> getControlsKeyFocusItemNr' activated cPtr itemHs+				Just itemNr 	-> Just itemNr+			where+				getControlKeyFocusItemNr' :: Bool -> OSWindowPtr -> WElementHandle ls ps -> Maybe Int+				getControlKeyFocusItemNr' activated cPtr itemH@(WItemHandle {wItemPtr=wItemPtr,wItemNr=wItemNr,wItemKind=wItemKind,wItemSelect=wItemSelect,wItemAtts=wItemAtts,wItems=wItems})+					| cPtr==wItemPtr =+						if (wItemKind `elem` [IsCompoundControl,IsCustomControl,IsEditControl,IsPopUpControl]) &&+						   wItemSelect && (any reqAttribute wItemAtts)+						then Just wItemNr+						else Nothing+					| isRecursiveControl wItemKind = getControlsKeyFocusItemNr' activated cPtr wItems+					| otherwise = Nothing+					where+						reqAttribute =+							if activated then isControlActivate+							else isControlDeactivate++				getControlKeyFocusItemNr' activated cPtr (WListLSHandle itemHs)+					= getControlsKeyFocusItemNr' activated cPtr itemHs++				getControlKeyFocusItemNr' activated cPtr (WExtendLSHandle _ itemHs)+					= getControlsKeyFocusItemNr' activated cPtr itemHs++				getControlKeyFocusItemNr' activated cPtr (WChangeLSHandle _ itemHs)+					= getControlsKeyFocusItemNr' activated cPtr itemHs++getControlKeyFocusItemNr _ _ _+	= windoweventFatalError "getControlKeyFocusItemNr" "window placeholder not expected"+++{-	The following operations on InputTrack are ignored. -}+--	Access operations on InputTrack:++trackingMouse :: OSWindowPtr -> OSWindowPtr -> Maybe InputTrack -> Bool+trackingMouse wPtr cPtr (Just (InputTrack {itWindow=itWindow,itControl=itControl,itKind=InputTrackKind{itkMouse=itkMouse}}))+	= wPtr==itWindow && cPtr==itControl && itkMouse+trackingMouse _ _ _ = False++trackingKeyboard :: OSWindowPtr -> OSWindowPtr -> Maybe InputTrack -> Bool+trackingKeyboard wPtr cPtr (Just (InputTrack {itWindow=itWindow,itControl=itControl,itKind=InputTrackKind{itkKeyboard=itkKeyboard}}))+	= wPtr==itWindow && cPtr==itControl && itkKeyboard+trackingKeyboard _ _ Nothing = False++trackMouse :: OSWindowPtr -> OSWindowPtr -> Maybe InputTrack -> Maybe InputTrack+trackMouse wPtr cPtr (Just it@(InputTrack {itWindow=itWindow,itControl=itControl,itKind=itk}))+	| wPtr /= itWindow || cPtr /= itControl =+		windoweventFatalError "trackMouse" "incorrect window/control parameters"+	| otherwise = Just (it{itKind=itk{itkMouse=True}})+trackMouse wPtr cPtr nothing+	= Just (InputTrack {itWindow=wPtr,itControl=cPtr,itKind=InputTrackKind{itkMouse=True,itkKeyboard=False}})++untrackMouse :: Maybe InputTrack -> Maybe InputTrack+untrackMouse (Just it@(InputTrack {itKind=itk}))+	| itkKeyboard itk = Just (it{itKind=itk{itkMouse=False}})+	| otherwise       = Nothing+untrackMouse Nothing      = Nothing++untrackKeyboard :: Maybe InputTrack -> Maybe InputTrack+untrackKeyboard (Just it@(InputTrack {itKind=itk}))+	| itkMouse itk  = Just (it{itKind=itk{itkKeyboard=False}})+	| otherwise     = Nothing+untrackKeyboard Nothing = Nothing++trackKeyboard :: OSWindowPtr -> OSWindowPtr -> Maybe InputTrack -> Maybe InputTrack+trackKeyboard wPtr cPtr (Just it@(InputTrack {itWindow=itWindow,itControl=itControl,itKind=itk}))+	| wPtr /= itWindow || cPtr /= itControl =+		windoweventFatalError "trackKeyboard" "incorrect window/control parameters"+	| otherwise+		= Just (it{itKind=itk{itkKeyboard=True}})+trackKeyboard wPtr cPtr Nothing =+	Just (InputTrack {itWindow=wPtr,itControl=cPtr,itKind=InputTrackKind{itkMouse=False,itkKeyboard=True}})+
+ Graphics/UI/ObjectIO/Process/Device.hs view
@@ -0,0 +1,110 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  OS.ClCCall_12+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Process.Device (processFunctions) where+++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.StdProcessAttribute+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.Process.Toolbar+import Graphics.UI.ObjectIO.OS.DocumentInterface+import Graphics.UI.ObjectIO.OS.ProcessEvent+++processdeviceFatalError :: String -> String -> x+processdeviceFatalError rule error+	= dumpFatalError rule "ProcessDevice" error+++processFunctions :: DeviceFunctions ps+processFunctions+	= DeviceFunctions+		{ dDevice = ProcessDevice+		, dShow	  = return+		, dHide	  = return+		, dEvent  = processEvent+		, dDoIO   = processIO+		, dOpen   = processOpen+		, dClose  = processClose+		}++processOpen :: ps -> GUI ps ps+processOpen ps+	= do {+		hasProcess <- accIOEnv (ioStHasDevice ProcessDevice);+		if   hasProcess+		then return ps+		else +		do {+			appIOEnv (ioStSetDeviceFunctions processFunctions);+			osdinfo <- accIOEnv ioStGetOSDInfo;+			createOSDInfo osdinfo;+			return ps+		   }+	     }+	where+		createOSDInfo :: OSDInfo -> GUI ps ()+		createOSDInfo emptyOSDInfo+			| di==NDI = appIOEnv (ioStSetOSDInfo emptyOSDInfo)+			| di==MDI = do+				atts <- accIOEnv ioStGetProcessAttributes+				let acceptOpenFiles	= any isProcessOpenFiles atts+				let hasToolbarAtt	= any isProcessToolbar   atts+				osdinfo <- liftIO (osOpenMDI (not hasToolbarAtt) acceptOpenFiles)+				appIOEnv (ioStSetOSDInfo osdinfo)+				openToolbar+			| di==SDI = do+				atts <- accIOEnv ioStGetProcessAttributes+				let acceptOpenFiles = any isProcessOpenFiles atts					+				osdinfo <- liftIO (osOpenSDI acceptOpenFiles)+				appIOEnv (ioStSetOSDInfo osdinfo)+				openToolbar+			where+				di = getOSDInfoDocumentInterface emptyOSDInfo++processClose :: ps -> GUI ps ps+processClose ps+	= do {+		accIOEnv (ioStGetDevice ProcessDevice);+		appIOEnv (ioStRemoveDeviceFunctions ProcessDevice);+		return ps+	  }++processIO :: DeviceEvent -> ps -> GUI ps ps++{-	ProcessInitialise is the first event sent to an interactive process.+	This allows the system to evaluate its initialisation action. No further+	actions are required.+-}+processIO ProcessInitialise ps+	= return ps++processIO ProcessRequestClose ps+	= do {+		atts                 <- accIOEnv ioStGetProcessAttributes;+		let (hasCloseAtt,att) = cselect isProcessClose undefined atts+		in+		if   not hasCloseAtt+		then return ps+		else getProcessCloseFun att ps+	  }+processIO (ProcessRequestOpenFiles openFilesInfo) ps = do+	atts                 <- accIOEnv ioStGetProcessAttributes;+	let (hasFilesOpenAtt,att) = cselect isProcessOpenFiles undefined atts+	(if not hasFilesOpenAtt+	 then return ps+	 else getProcessOpenFilesFun att openFilesInfo ps)++processIO _ _+	= processdeviceFatalError "processIO" "unexpected DeviceEvent"
+ Graphics/UI/ObjectIO/Process/IOState.hs view
@@ -0,0 +1,610 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Process.IOState+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- IOState defines the GUI environment types and their access functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Process.IOState+	       ( Context, IOContext, IOSt, GUI, toGUI, appIOEnv, accIOEnv, liftIO, fromGUI+	       , throwGUI, catchGUI, noLS, noLS1+	       , InputTrack(..), InputTrackKind(..)+               , DeviceFunctions(..), dDevice, dEvent, EventFunction, dDoIO, DoIOFunction, dOpen, OpenFunction, dClose, CloseFunction+               , initialContext+               , emptyIOSt+               , ioStGetProcessAttributes, ioStSetProcessAttributes, Graphics.UI.ObjectIO.StdGUI.ProcessAttribute(..)+               , ioStGetOSDInfo, ioStSetOSDInfo +               , ioStGetInitIO, ioStSetInitIO, Graphics.UI.ObjectIO.StdIOCommon.IdFun+               , ioContextGetInputTrack, ioContextSetInputTrack, ioStGetInputTrack, ioStSetInputTrack+               , ioStClosed, ioStGetRuntimeState, ioStSetRuntimeState, RuntimeState(..)+               , ioStGetIOIsModal, ioStSetIOIsModal +               , ioStGetIdTable, ioStSetIdTable, Graphics.UI.ObjectIO.Id.IdTable               +               , ioStGetTimerTable, ioStSetTimerTable, Graphics.UI.ObjectIO.Timer.Table.TimerTable+               , ioContextGetTime, ioContextSetTime +               , ioStTakeEvent, ioStAppendEvents, ioStInsertEvents+               , ioStGetDocumentInterface, ioStGetOSDInfo, ioStSetOSDInfo, module Graphics.UI.ObjectIO.OS.DocumentInterface+               , ioStGetIOId, SystemId(..)+               , ioStGetMaxIONr, ioStSetMaxIONr, ioStNewMaxIONr               +               , ioStGetOSWindowMetrics, Graphics.UI.ObjectIO.OS.System.OSWindowMetrics(..)+               , ioStGetContext+               , DeviceEventInfo+               , PSt(..), ioStEmptyProcesses, ioStGetProcesses, ioStSetProcess, ioStRemoveProcess+               , ioStGetDeviceFunctions, ioStSetDeviceFunctions, ioStRemoveDeviceFunctions+               , ioStHasDevice, ioStGetDevices, ioStGetDevice, ioStRemoveDevice, ioStSetDevice               +               , ioContextTakeEvent, ioContextAppendEvents, ioContextInsertEvents+               , ioContextGetMaxIONr, ioContextSetMaxIONr, ioContextNewMaxIONr+               , ioStGetIdTable, ioStSetIdTable +               , ioContextGetIdTable, ioContextSetIdTable+               , ioContextGetTimerTable, ioContextSetTimerTable+               , ioContextEmptyProcesses, ioContextGetProcesses, ioContextSetProcess, ioContextRemoveProcess+               , module Graphics.UI.ObjectIO.Device.Types+               , module Graphics.UI.ObjectIO.Device.Events+               , module Graphics.UI.ObjectIO.Device.SystemState+               , liftContextIO+               ) where++++import Graphics.UI.ObjectIO.Device.Types+import Graphics.UI.ObjectIO.Device.Events+import Graphics.UI.ObjectIO.Device.SystemState+import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.StdGUI (ProcessAttribute(..))+import Graphics.UI.ObjectIO.StdIOCommon+import Graphics.UI.ObjectIO.SystemId+import Graphics.UI.ObjectIO.Timer.Table(TimerTable, initialTimerTable)+import Graphics.UI.ObjectIO.CommonDef(dumpFatalError)+import Graphics.UI.ObjectIO.OS.DocumentInterface+import Graphics.UI.ObjectIO.OS.Event+import Graphics.UI.ObjectIO.OS.System+import Graphics.UI.ObjectIO.OS.Time(osGetTime, OSTime)+import Graphics.UI.ObjectIO.OS.Types+import Control.Exception+import Data.IORef+import qualified Data.Map as Map+import GHC.Base(unsafeCoerce#)+++{-	The GUI monad is an IO monad extended with IOSt.+	Note: GUI can't be defined as newtype because it's abstract.+	      Putting newtype GUI in the hi-boot kills GHC.+-}++data	GUI ps a = GUI !(IOSt ps -> IO (a,IOSt ps))++instance Monad (GUI ps) where+	(>>=) envIOA to_envIOB+		= GUI (bind envIOA to_envIOB)+		where+			bind (GUI fA) to_envIOB ioState+				= fA ioState >>= (\(a,ioState)->case to_envIOB a of+				                            (GUI fB) -> fB ioState)+	+	(>>) envIOA envIOB+		= GUI (bind envIOA envIOB)+		where+			bind (GUI fA) envIOB ioState+				= fA ioState >>= (\(_,ioState)->case envIOB of+				                            (GUI fB) -> fB ioState)+	+	return a = GUI (\ioState -> return (a,ioState))+++instance  Functor (GUI ps) where+   fmap f x = x >>= (return . f)+++{-  Lift an action (ps -> GUI ps ps) to a GUIFun ls ps. -}+noLS :: (ps -> GUI ps ps) -> (ls,ps) -> GUI ps (ls,ps)  -- Lift action GUI ps to GUIFun ls ps+noLS action (ls,ps) = do { ps1 <- action ps; return (ls,ps1) }++{-  Lift an action (ps -> GUI ps ps) that requires x to a GUIFun ls ps that requires x. -}+noLS1 :: (x -> ps -> GUI ps ps) -> x -> (ls,ps) -> GUI ps (ls,ps)+noLS1 action x (ls,ps) = do { ps1 <- action x ps; return (ls,ps1) }++{- exception handling -}++throwGUI :: ErrorReport	-> a+throwGUI = throwDyn++catchGUI :: GUI ps x -> (ErrorReport -> GUI ps x) -> GUI ps x+catchGUI p1 p2 = toGUI (\ioState -> catchDyn (fromGUI p1 ioState) (\err -> fromGUI (p2 err) ioState))+++instance IOMonad (GUI ps) where+	liftIO m = GUI (\ioState->m>>=(\a->return (a,ioState)))++liftContextIO :: (Context -> IO a) -> ps -> GUI ps (a, ps)+liftContextIO action ps = toGUI (\ioSt -> do+	let context = ioStGetContext ioSt+	let id = ioStGetIOId ioSt+	modifyIORef context (ioContextSetProcess (PSt ps ioSt))+	r <- action context+	iocontext <- readIORef context+	let pcs = ioContextGetProcesses iocontext+	let (ps1, ioSt1) = getProcess id pcs+	return ((r,ps1), ioSt1))+	where+	    getProcess :: SystemId -> [PSt] -> (ps, IOSt ps)+	    getProcess id [] = dumpFatalError "liftContextIO" "IOState" "could not retrieve IOSt"+	    getProcess id ((PSt ps ioSt):pcs)+		| ioStGetIOId ioSt == id = unsafeCoerce# (ps, ioSt)+		| otherwise       = getProcess id pcs++{-	The following functions useful for easy composition of IOSt transition functions+	and coercing purposes.+	Since they expose the IOSt type, they are not part of the API.+-}+appIOEnv :: IdFun (IOSt ps) -> GUI ps ()+appIOEnv f = GUI (\env->return ((),f env))++accIOEnv :: (IOSt ps -> x) -> GUI ps x+accIOEnv f = GUI (\env->return (f env,env))++toGUI :: (IOSt ps -> IO (a,IOSt ps)) -> GUI ps a+toGUI fun = GUI fun++fromGUI :: GUI ps a -> IOSt ps -> IO (a,IOSt ps)+fromGUI (GUI fAction) = fAction+++{-	IOSt always had all the components to construct a context. These components+	are now being shared via a (IORef IOContext). So we define the IOContext type+	here instead of in Scheduler and have IOSt contain a (IORef IOContext).+-}+data PSt = forall ps . PSt ps (IOSt ps)++type	Context							-- A Context points to an IOContext+	= IORef IOContext+data	IOContext+	= IOContext+		{ ioevents          :: ![SchedulerEvent]	-- The event stream environment+		, ionr              :: !SystemId		-- The max SystemId of all processes		+		, ioidtable         :: !IdTable			-- The table of all bound Ids+		, ioostime	    :: !OSTime			-- The current OSTime+		, iotimertable	    :: !TimerTable		-- The table of all currently active timers+		, ioprocesses       :: ![PSt]			-- The list of all processes+		, ioismodal	    :: !(Maybe SystemId)	-- If a process has some modal windows, then Just id, otherwise Nothing+		, ioinputtrack 	    :: !(Maybe InputTrack)	-- The process is handling mouse/key input flags+		}+type	DeviceEventInfo						-- A DeviceEventInfo event+	=	( Device					-- The Device that accepted the DeviceEvent+		, DeviceEvent					-- The DeviceEvent to be handled+		)+data	IOSt ps+	= IOSt+		{ ioid              :: !SystemId		-- The Id of the process+		, ioinit            :: !(ps -> GUI ps ps)	-- The initialisation functions of the process+		, iodevicefuncs     :: ![DeviceFunctions  ps]	-- The currently active device functions+		, ioatts            :: ![ProcessAttribute ps]	-- The attributes of the process+		, iodevices         :: ![DeviceSystemState ps]	-- The GUI device states of the process+		, ioruntime         :: !RuntimeState		-- The runtime state of the process+		, ioosdinfo         :: !OSDInfo			-- The OS document interface information of the process+		, iooswmetrics      :: !OSWindowMetrics		-- The window metrics+		, iocontext         :: !Context			-- The shared context+		}++data RuntimeState +	= Running						-- The process is running+	| Blocked !SystemId					-- The process is blocked for the process with given id+	| Closed						-- The process is closed+	deriving (Eq)++data InputTrack+   = InputTrack							-- Input being tracked:+	{ itWindow	:: !OSWindowPtr				-- the parent window+	, itControl	:: !Int					-- zero if parent window, otherwise item nr of control (>0)+	, itKind	:: !InputTrackKind			-- the input kinds being tracked+	}+data InputTrackKind+   = InputTrackKind						-- Input source kinds:+	{ itkMouse	:: !Bool				-- mouse+	, itkKeyboard	:: !Bool				-- keyboard+	}++data	DeviceFunctions ps					-- The major device callback functions:+	= DeviceFunctions+		{ dDevice :: Device				-- The device kind+		, dShow	  :: ShowFunction  ps+		, dHide	  :: HideFunction  ps+		, dEvent  :: EventFunction ps			-- Map an SchedulerEvent to a DeviceEvent+		, dDoIO   :: DoIOFunction  ps			-- Handle a DeviceEvent for this device+		, dOpen   :: OpenFunction  ps			-- Open the initial device+		, dClose  :: CloseFunction ps			-- Close the device and its instances+		}++type	OpenFunction  ps = ps -> GUI ps ps+type	CloseFunction ps = ps -> GUI ps ps+type	ShowFunction  ps = ps -> GUI ps ps+type	HideFunction  ps = ps -> GUI ps ps+type	EventFunction ps = IOSt ps -> SchedulerEvent -> IO (Bool, Maybe DeviceEvent, SchedulerEvent)+type	DoIOFunction  ps = DeviceEvent -> ps -> GUI ps ps++++--	Creation of an initial context:++initialContext :: Maybe SystemId -> IO Context+initialContext modalId = do+	osTime <- osGetTime+	newIORef (IOContext+		      { ioevents          = []+		      , ionr              = initSystemId+		      , ioidtable         = Map.empty+		      , ioprocesses 	  = []+		      , ioismodal	  = modalId+		      , ioinputtrack      = Nothing+		      , iotimertable      = initialTimerTable+		      , ioostime	  = osTime+		      }+		  )+++--	Creation of an initial, empty IOSt:+++emptyIOSt :: SystemId -> DocumentInterface+				-> [ProcessAttribute ps] -> (ps -> GUI ps ps) -> Context -> IO (IOSt ps)++emptyIOSt ioId documentInterface processAtts initIO context+	= do {+		wMetrics <- osDefaultWindowMetrics;+		return IOSt+			  { ioid           = ioId+			  , iodevicefuncs  = []+			  , iodevices	   = []+			  , ioatts	   = processAtts+			  , ioruntime      = Running+			  , ioosdinfo	   = emptyOSDInfo documentInterface+  			  , iooswmetrics   = wMetrics+			  , iocontext      = context+			  , ioinit         = initIO+			  }+	  }++--	Access rules to the IOSt:+++--	Access rules to process attributes:++ioStGetProcessAttributes :: IOSt ps -> [ProcessAttribute ps]+ioStGetProcessAttributes ioState = ioatts ioState++ioStSetProcessAttributes :: [ProcessAttribute ps] -> IOSt ps -> IOSt ps+ioStSetProcessAttributes atts ioState = ioState {ioatts=atts}+++--	Access rules to the initial actions:++ioStGetInitIO :: IOSt ps -> ps -> GUI ps ps+ioStGetInitIO ioState = ioinit ioState+	+ioStSetInitIO :: (ps -> GUI ps ps) -> IOSt ps -> IOSt ps+ioStSetInitIO initIO ioState = ioState {ioinit=initIO}+++--	Access rules to InputTrack:++ioContextGetInputTrack :: IOContext -> Maybe InputTrack+ioContextGetInputTrack ioContext = ioinputtrack ioContext++ioContextSetInputTrack :: Maybe InputTrack -> IOContext -> IOContext+ioContextSetInputTrack inputtrack ioContext = ioContext{ioinputtrack=inputtrack}++ioStGetInputTrack :: GUI ps (Maybe InputTrack)+ioStGetInputTrack = accIOStContext ioContextGetInputTrack++ioStSetInputTrack :: Maybe InputTrack -> GUI ps ()+ioStSetInputTrack inputtrack = appIOStContext (ioContextSetInputTrack inputtrack)+++--	Access rules to RuntimeState:++ioStClosed :: IOSt ps -> Bool+ioStClosed ioState = ioruntime ioState == Closed++ioStGetRuntimeState :: IOSt ps -> RuntimeState+ioStGetRuntimeState ioState = ioruntime ioState++ioStSetRuntimeState :: RuntimeState -> IOSt ps -> IOSt ps+ioStSetRuntimeState runtime ioState = ioState {ioruntime=runtime}+++--	Access rules to IOIsModal:++ioStGetIOIsModal :: IOContext -> Maybe SystemId+ioStGetIOIsModal iocontext = ioismodal iocontext++ioStSetIOIsModal :: Maybe SystemId -> IOContext -> IOContext+ioStSetIOIsModal optId iocontext = iocontext{ioismodal=optId}+++--	Access rules to IdTable:++ioStGetIdTable :: GUI ps IdTable+ioStGetIdTable = accIOStContext ioContextGetIdTable++ioStSetIdTable :: IdTable -> GUI ps ()+ioStSetIdTable idTable = appIOStContext (ioContextSetIdTable idTable)+++--	Access rules to TimerTable:++ioStGetTimerTable :: GUI ps TimerTable+ioStGetTimerTable = accIOStContext ioContextGetTimerTable++ioStSetTimerTable :: TimerTable  -> GUI ps ()+ioStSetTimerTable iotimertable = appIOStContext (ioContextSetTimerTable iotimertable)+++--	Access rules to the OSEvents environment:++ioStTakeEvent :: GUI ps (Maybe SchedulerEvent)+ioStTakeEvent = updIOStContext ioContextTakeEvent++ioStAppendEvents :: [SchedulerEvent] -> GUI ps ()+ioStAppendEvents es = appIOStContext (ioContextAppendEvents es)++ioStInsertEvents :: [SchedulerEvent] -> GUI ps ()+ioStInsertEvents es = appIOStContext (ioContextInsertEvents es)+++--	Access rules to DocumentInterface:++ioStGetDocumentInterface :: IOSt ps -> DocumentInterface+ioStGetDocumentInterface ioState@(IOSt {ioosdinfo=ioosdinfo}) = getOSDInfoDocumentInterface ioosdinfo+++--	Access rules to OSDInfo:++ioStGetOSDInfo :: IOSt ps -> OSDInfo+ioStGetOSDInfo ioState@(IOSt {ioosdinfo=ioosdinfo}) = ioosdinfo++ioStSetOSDInfo :: OSDInfo -> IOSt ps -> IOSt ps+ioStSetOSDInfo osdInfo ioState = ioState {ioosdinfo=osdInfo}+++--	Access to the SystemId of the IOSt:++ioStGetIOId :: IOSt ps -> SystemId+ioStGetIOId ioState = ioid ioState+++--	Access to the max SystemId of the IOSt:++ioStGetMaxIONr :: GUI ps SystemId+ioStGetMaxIONr = accIOStContext ioContextGetMaxIONr++ioStSetMaxIONr :: SystemId -> GUI ps ()+ioStSetMaxIONr maxId = appIOStContext (ioContextSetMaxIONr maxId)++ioStNewMaxIONr :: GUI ps SystemId+ioStNewMaxIONr = updIOStContext ioContextNewMaxIONr+++--	Access to the OSWindowMetrics of the IOSt:++ioStGetOSWindowMetrics :: IOSt ps -> OSWindowMetrics+ioStGetOSWindowMetrics ioState = iooswmetrics ioState+++--	Access rules to the ProcessEventHandlers:++ioStEmptyProcesses :: GUI ps Bool+ioStEmptyProcesses = accIOStContext ioContextEmptyProcesses++ioStGetProcesses :: GUI ps [PSt]+ioStGetProcesses = accIOStContext ioContextGetProcesses++ioStSetProcess :: PSt -> GUI ps ()+ioStSetProcess p = appIOStContext (ioContextSetProcess p)++ioStRemoveProcess :: SystemId -> GUI ps ()+ioStRemoveProcess ioId = appIOStContext (ioContextRemoveProcess ioId)+++--	Access to the Context of the IOSt:++ioStGetContext :: IOSt ps -> Context+ioStGetContext ioState = iocontext ioState++accIOStContext :: (IOContext -> x) -> GUI ps x+accIOStContext fun = GUI (\ioSt -> do+    iocontext <- readIORef (ioStGetContext ioSt)+    return (fun iocontext,ioSt))++appIOStContext :: (IOContext -> IOContext) -> GUI ps ()+appIOStContext fun = GUI (\ioSt -> do+    modifyIORef (ioStGetContext ioSt) fun+    return ((), ioSt))+    +updIOStContext :: (IOContext -> (a,IOContext)) -> GUI ps a+updIOStContext fun = GUI (\ioSt -> do+	iocontext <- readIORef (ioStGetContext ioSt)+	let (r, iocontext1) = fun iocontext+	writeIORef (ioStGetContext ioSt) iocontext1+	return (r,ioSt))+++--	Access to the DeviceFunctions:++ioStGetDeviceFunctions :: IOSt ps -> [DeviceFunctions ps]+ioStGetDeviceFunctions ioState = iodevicefuncs ioState++ioStSetDeviceFunctions :: DeviceFunctions ps -> IOSt ps -> IOSt ps+ioStSetDeviceFunctions funcs ioState+	= ioState {iodevicefuncs=setdevicefunctions (priorityDevice (dDevice funcs)) (dDevice funcs) funcs (iodevicefuncs ioState)}+	where+		setdevicefunctions :: Int -> Device -> DeviceFunctions ps -> [DeviceFunctions ps] -> [DeviceFunctions ps]+		setdevicefunctions p device funcs fs@(dfunc:dfuncs)+			| device==dDevice dfunc+				= funcs:dfuncs+			| p>priorityDevice (dDevice dfunc)+				= funcs:fs+			| otherwise+				= dfunc:setdevicefunctions p device funcs dfuncs+		setdevicefunctions _ _ funcs _+			= [funcs]++ioStRemoveDeviceFunctions :: Device -> IOSt ps -> IOSt ps+ioStRemoveDeviceFunctions device ioState+	= ioState {iodevicefuncs=removedevicefunctions device (iodevicefuncs ioState)}+	where+		removedevicefunctions :: Device -> [DeviceFunctions ps] -> [DeviceFunctions ps]+		removedevicefunctions device (dfunc:dfuncs)+			| device==dDevice dfunc+				= dfuncs+			| otherwise+				= dfunc:removedevicefunctions device dfuncs+		removedevicefunctions _ empty+			= empty++--	Access to the DeviceSystemStates:++ioStHasDevice :: Device -> IOSt ps -> Bool+ioStHasDevice d ioState+	= devicesHaveDevice d (iodevices ioState)+	where+		devicesHaveDevice :: Device -> [DeviceSystemState ps] -> Bool+		devicesHaveDevice d (dState:dStates) = toDevice dState==d || devicesHaveDevice d dStates+		devicesHaveDevice _ _                = False++ioStGetDevices :: IOSt ps -> [Device]+ioStGetDevices ioState = map toDevice (iodevices ioState)++ioStGetDevice :: Device -> IOSt ps -> (Bool,DeviceSystemState ps)+ioStGetDevice d ioState = devicesGetDevice d (iodevices ioState)+	where+		devicesGetDevice :: Device -> [DeviceSystemState ps] -> (Bool,DeviceSystemState ps)+		devicesGetDevice d (dState:dStates)+			| toDevice dState==d 	= (True,dState)+			| otherwise 		= devicesGetDevice d dStates				  +		devicesGetDevice _ [] = (False,undefined)++ioStRemoveDevice :: Device -> IOSt ps -> IOSt ps+ioStRemoveDevice d ioState+	= ioState {iodevices=devicesRemoveDevice d (iodevices ioState)}+	where+		devicesRemoveDevice :: Device -> [DeviceSystemState ps] -> [DeviceSystemState ps]+		devicesRemoveDevice d (dState:dStates)+			| toDevice dState==d = dStates+			| otherwise          = dState:devicesRemoveDevice d dStates+		devicesRemoveDevice _ dStates+			= dStates++ioStSetDevice :: DeviceSystemState ps -> IOSt ps -> IOSt ps+ioStSetDevice d ioState+	= let+		device = toDevice d+		ds     = devicesSetDevice (priorityDevice device) device d (iodevices ioState)+	  in	ioState {iodevices=ds}+	where+		devicesSetDevice :: Int -> Device -> DeviceSystemState ps -> [DeviceSystemState ps] -> [DeviceSystemState ps]+		devicesSetDevice p device dState2 ds@(dState1:dStates)+			| device1==device+				= dState2:dStates+			| p>priorityDevice device1+				= dState2:ds+			| otherwise+				= dState1:devicesSetDevice p device dState2 dStates+			where+				device1 = toDevice dState1+		devicesSetDevice _ _ dState _+			= [dState]+++--	Access to IOContext:++--	Access rules to the OSEvents environment:++ioContextTakeEvent :: IOContext -> (Maybe SchedulerEvent, IOContext)+ioContextTakeEvent iocontext =+	case ioevents iocontext of+		[] 	-> (Nothing,iocontext)+		(e:es) 	-> (Just e ,iocontext{ioevents=es})++ioContextAppendEvents :: [SchedulerEvent] -> IOContext -> IOContext+ioContextAppendEvents es iocontext = iocontext {ioevents=ioevents iocontext ++ es}++ioContextInsertEvents :: [SchedulerEvent] -> IOContext -> IOContext+ioContextInsertEvents es iocontext = iocontext {ioevents=es ++ ioevents iocontext}+++--	Access to the max SystemId of IOContext:++ioContextGetMaxIONr :: IOContext -> SystemId+ioContextGetMaxIONr iocontext = ionr iocontext++ioContextSetMaxIONr :: SystemId -> IOContext -> IOContext+ioContextSetMaxIONr maxId iocontext = iocontext {ionr=maxId}++ioContextNewMaxIONr :: IOContext -> (SystemId,IOContext)+ioContextNewMaxIONr iocontext+	= let (maxId1,newMaxId) = incrSystemId (ionr iocontext)+	  in  (newMaxId,iocontext {ionr=maxId1})+++--	Access to the context time:++ioContextGetTime :: IOContext -> OSTime+ioContextGetTime iocontext = ioostime iocontext++ioContextSetTime :: OSTime -> IOContext -> IOContext+ioContextSetTime osTime iocontext = iocontext {ioostime=osTime}++	+--	Access rules to IdTable:++ioContextGetIdTable :: IOContext -> IdTable+ioContextGetIdTable iocontext = ioidtable iocontext++ioContextSetIdTable :: IdTable -> IOContext -> IOContext+ioContextSetIdTable idTable iocontext+	= iocontext {ioidtable=idTable}+++--	Access rules to TimerTable:++ioContextGetTimerTable :: IOContext -> TimerTable+ioContextGetTimerTable iocontext = iotimertable iocontext++ioContextSetTimerTable :: TimerTable -> IOContext -> IOContext+ioContextSetTimerTable iotimertable iocontext+	= iocontext {iotimertable=iotimertable}	+++--	Access rules to the ProcessEventHandlers:++ioContextEmptyProcesses :: IOContext -> Bool+ioContextEmptyProcesses iocontext = null (ioprocesses iocontext)++ioContextGetProcesses :: IOContext -> [PSt]+ioContextGetProcesses iocontext = ioprocesses iocontext++ioContextSetProcess :: PSt -> IOContext -> IOContext+ioContextSetProcess theP ioContext@(IOContext {ioprocesses=ioprocesses}) =+	ioContext {ioprocesses=setProcess theP ioprocesses}+	where+		setProcess :: PSt -> [PSt] -> [PSt]+		setProcess theP@(PSt _ theIOSt) (p@(PSt _ ioSt):ps)+			| ioid ioSt == ioid theIOSt = if ioStClosed theIOSt then ps else theP : ps+			| otherwise		    = p : setProcess theP ps+		setProcess theP@(PSt _ theIOSt) [] = if ioStClosed theIOSt then [] else [theP]++ioContextRemoveProcess :: SystemId -> IOContext -> IOContext+ioContextRemoveProcess ioId ioContext@(IOContext {ioprocesses=ioprocesses}) =+	ioContext {ioprocesses=removeProcess ioId ioprocesses}+	where+		removeProcess :: SystemId -> [PSt] -> [PSt]+		removeProcess ioId (p@(PSt _ ioSt):ps)+			| ioid ioSt == ioId 	= ps+			| otherwise	    	= p : removeProcess ioId ps+		removeProcess _ []  = []
+ Graphics/UI/ObjectIO/Process/Scheduler.hs view
@@ -0,0 +1,238 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Process.Scheduler+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Scheduler contains the process creation, termination, and handling functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Process.Scheduler+		( Context+		, initContext+		, handleEvents+		, handleContextOSEvent+		, addInteractiveProcess+		, closeContext+		, quitProcess+		) where+++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.StdProcessDef+import Graphics.UI.ObjectIO.Timer.Table(getTimeIntervalFromTimerTable)+import Graphics.UI.ObjectIO.OS.Event+import Graphics.UI.ObjectIO.OS.ClCrossCall_12 (osInitToolbox, osCloseToolbox)+import Data.IORef+++schedulerFatalError :: String -> String -> x+schedulerFatalError rule message+	= dumpFatalError rule "Process.Scheduler" message+++--	Access functions on RuntimeState:++rsIsClosed :: RuntimeState -> Bool+rsIsClosed Closed = True+rsIsClosed _      = False+++--	Starting an interactive process.++initContext :: [ProcessAttribute ps] -> ProcessInit ps -> ps -> DocumentInterface -> IO (Maybe Context)+initContext pAtts initIO ps xDI+	= do {+		initOK <- osInitToolbox;							-- initialise toolbox+		if   initOK									-- toolbox correctly initialised+		then do {+			context  <- initialContext Nothing;					-- initialise context+			context1 <- createInitialProcess pAtts initIO ps xDI context;	-- fork the initial interactive process+			return (Just context1)+		     }+		else return Nothing;		+	  }+++--	Handling events until termination of all interactive processes.++handleEvents :: Context -> IO ()+handleEvents context+	= osHandleEvents+		terminate+		getosevent+		getsleeptime+		handlecontext+	where+		terminate :: IO Bool+		terminate = do+			iocontext <- readIORef context+			return (ioContextEmptyProcesses iocontext)+		+		getosevent :: IO (Maybe SchedulerEvent)+		getosevent = do+			iocontext <- readIORef context+			let (event, iocontext1) = ioContextTakeEvent iocontext+			writeIORef context iocontext1+			return event+			  +		getsleeptime :: IO Int+		getsleeptime = do+			iocontext <- readIORef context+			let tt = ioContextGetTimerTable iocontext+			let maybe_sleep	= getTimeIntervalFromTimerTable tt+			let sleep = maybe osLongSleep id maybe_sleep+			return sleep+			+		handlecontext = handleContextOSEvent context++--	Closing a final context. ++closeContext :: Context -> IO ()+closeContext context = do+	iocontext <- readIORef context;+	(if ioContextEmptyProcesses iocontext then return ()+	 else schedulerFatalError "closeContext" "not a final Context")+	osCloseToolbox+	return ()+++handleContextOSEvent :: Context -> SchedulerEvent -> IO [Int]+handleContextOSEvent context schedulerEvent = do+	iocontext <- readIORef context+	let processes = ioContextGetProcesses iocontext+	schedulerEvent1 <- letProcessesFilterEvent context schedulerEvent processes+	let replyToOS = case schedulerEvent1 of+		(ScheduleOSEvent  _ reply) -> reply+		_ 			   -> []+	return replyToOS+	where+		letProcessesFilterEvent :: Context -> SchedulerEvent -> [PSt] -> IO SchedulerEvent+		letProcessesFilterEvent context schedulerEvent [] = return schedulerEvent+		letProcessesFilterEvent context schedulerEvent (p@(PSt st ioSt) : ps) +			| ioStClosed ioSt = letProcessesFilterEvent context schedulerEvent ps+			| otherwise = do+				(ok,maybeDeviceEvent,schedulerEvent1) <- processEventFilter ioSt schedulerEvent+				(if   not ok+				 then letProcessesFilterEvent context schedulerEvent1 ps+				 else case maybeDeviceEvent of+				 	Nothing -> return schedulerEvent1+				      	Just (device, deviceEvent) -> do				      		+				      		p <- handleEventForProcess device deviceEvent p+				      		modifyIORef context (ioContextSetProcess p)+				          	return schedulerEvent1)+++handleEventForProcess :: Device -> DeviceEvent -> PSt -> IO PSt+handleEventForProcess device schedulerEvent (PSt ps ioState)+	= do {+		(ps1,ioState2) <- fromGUI (initIO ps) ioState1;+		if   ioStClosed ioState2+		then return (PSt ps1 ioState2)+		else let deviceFunctions = ioStGetDeviceFunctions ioState2+			 (found,df)      = cselect (\df -> dDevice df == device) undefined deviceFunctions+		     in  +			 if   not found+			 then schedulerFatalError "ioProcess" "could not find Device to handle DeviceEvent"+			 else do+				(ps2,ioState3) <- fromGUI (catchGUI (dDoIO df schedulerEvent ps1) handleErrorReport) ioState2+				return (PSt ps2 ioState3)+	  }+	where+		initIO   = ioStGetInitIO ioState+		ioState1 = ioStSetInitIO (return) ioState+++createInitialProcess :: [ProcessAttribute ps] -> ProcessInit ps -> ps -> DocumentInterface -> Context -> IO Context+createInitialProcess pAtts initIO ps xDI context = do+    iocontext <- readIORef context+    let (ioId,iocontext1) = ioContextNewMaxIONr iocontext+    newIOSt   <- emptyIOSt ioId xDI pAtts initIO context;+    let p = PSt ps newIOSt+    let iocontext2 = ioContextSetProcess p iocontext1+    writeIORef context iocontext2+    p <- handleEventForProcess ProcessDevice ProcessInitialise p	-- Make sure the interactive process gets started+    modifyIORef context (ioContextSetProcess p)+    return context+++addInteractiveProcess :: [ProcessAttribute ps'] -> ProcessInit ps' -> ps' -> DocumentInterface -> GUI ps ()+addInteractiveProcess pAtts initIO ps' xDI = do+    ioId      <- ioStNewMaxIONr+    context   <- accIOEnv ioStGetContext+    newIOSt   <- liftIO (emptyIOSt ioId xDI pAtts initIO context)+    let p = PSt ps' newIOSt+    liftIO (modifyIORef context (ioContextSetProcess p))+    p <- liftIO (handleEventForProcess ProcessDevice ProcessInitialise p)+    liftIO (modifyIORef context (ioContextSetProcess p))+++{-	processEventFilter passes the current Device dEvent DeviceFunctions to the+	argument SchedulerEvent to determine if this event should be handled by this+	process.+-}+	+processEventFilter :: IOSt ps -> SchedulerEvent -> IO (Bool,Maybe DeviceEventInfo,SchedulerEvent)+processEventFilter ioState schedulerEvent+    | ioStClosed ioState = return (False,Nothing,schedulerEvent)+    | otherwise 	 = filterEventForDevices eventFunctions schedulerEvent ioState+    where        +        eventFunctions             = [(dDevice df,dEvent df) | df <- ioStGetDeviceFunctions ioState]++        filterEventForDevices :: [(Device,EventFunction ps)] -> SchedulerEvent -> IOSt ps+                              -> IO (Bool,Maybe DeviceEventInfo,SchedulerEvent)+        filterEventForDevices ((device,mapDeviceEvent):mapDeviceEvents) schedulerEvent ioState+                = do {+                    (forThisDevice,okDeviceEvent,schedulerEvent1) <- mapDeviceEvent ioState schedulerEvent;+                    if   not forThisDevice+                    then filterEventForDevices mapDeviceEvents schedulerEvent1 ioState+                    else return ( forThisDevice+                                , case okDeviceEvent of+                                       Just deviceEvent -> Just (device,deviceEvent)+                                       nothing          -> Nothing+                                , schedulerEvent1+                                )+                  }+        filterEventForDevices _ schedulerEvent _+            = return (False,Nothing,schedulerEvent)+++{-	Quit this interactive process.+	Quitting a process involves the following:+	- Set the RuntimeState to Closed (quitProcess is the only function that does this)+	- Close all devices+	- Remove the process from the Context+-}+quitProcess :: ps -> GUI ps ps+quitProcess ps+	= do {+		rs <- accIOEnv ioStGetRuntimeState;+		if   rsIsClosed rs+		then return ps+		else do {+		             deviceFunctions <- accIOEnv ioStGetDeviceFunctions;+		             ps1 <- seqListM [dClose df | df<-deviceFunctions] ps;+			     osdInfo <- accIOEnv ioStGetOSDInfo;+			     liftIO (osCloseOSDInfo osdInfo);+		             appIOEnv (ioStSetRuntimeState Closed);+		             +		             -- This part is new: remove the process from the context+		             accIOEnv ioStGetIOId >>= ioStRemoveProcess;+		             return ps1+		        }+	     }+	where+		seqListM :: [ps -> GUI ps ps] -> ps -> GUI ps ps+		seqListM (m:ms) ps+			= m ps >>= (\ps -> seqListM ms ps)+		seqListM _ ps+			= return ps+
+ Graphics/UI/ObjectIO/Process/Toolbar.hs view
@@ -0,0 +1,102 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Process.Toolbar+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Process.Toolbar(openToolbar) where+++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.Window.SDISize+import Graphics.UI.ObjectIO.StdGUI+import Graphics.UI.ObjectIO.StdProcessAttribute+import Graphics.UI.ObjectIO.StdBitmap(getBitmapSize)+import Graphics.UI.ObjectIO.OS.Bitmap+import Graphics.UI.ObjectIO.OS.DocumentInterface+import Graphics.UI.ObjectIO.OS.ToolBar+import Graphics.UI.ObjectIO.OS.Types+++toolbarFatalError :: String -> String -> a+toolbarFatalError function error = dumpFatalError function "Toolbar" error++checkToolbarFatalError :: Bool -> String -> String -> GUI ps ()+checkToolbarFatalError False function error = return ()+checkToolbarFatalError True  function error = dumpFatalError function "Toolbar" error+++openToolbar :: GUI ps ()+openToolbar = do+	osdInfo <- accIOEnv ioStGetOSDInfo+	let di = getOSDInfoDocumentInterface osdInfo+	(if di == NDI+	 then return ()+	 else do+		atts <- accIOEnv ioStGetProcessAttributes+		let (hasToolbarAtt,toolbarAtt) = cselect isProcessToolbar undefined atts+		let toolbar = getProcessToolbarAtt toolbarAtt+		(if not hasToolbarAtt+		 then return ()+		 else (if di==SDI then openSDIToolbar else openMDIToolbar) toolbar osdInfo))+	where+		openSDIToolbar :: [ToolbarItem ps] -> OSDInfo -> GUI ps ()+		openSDIToolbar items osdInfo = do+			checkToolbarFatalError (isJust osToolbar) "openSDIToolbar" "toolbar already present"+			(oldSize,_) <- getSDIWindowSize		+			(tbPtr,tbHeight) <- liftIO (osCreateToolbar False osFrame (toTuple reqSize))+			checkToolbarFatalError (tbPtr==osNoWindowPtr) "openSDIToolbar" "toolbar could not be created"+			liftIO (foldrM (openToolbarItem tbPtr) 1 items)+			let ostoolbar = OSToolbar{toolbarPtr=tbPtr,toolbarHeight=tbHeight}+			let osinfo1   = osinfo{osToolbar=Just ostoolbar}			+			appIOEnv (ioStSetOSDInfo (setOSDInfoOSInfo osinfo1 osdInfo))+			resizeSDIWindow osFrame oldSize oldSize{h=(h oldSize)-tbHeight}+			where+				reqSize	= getBitmapsSize items+				osinfo	= case (getOSDInfoOSInfo osdInfo) of+						Just info -> info+						Nothing   -> toolbarFatalError "openSDIToolbar" "could not retrieve OSInfo from OSDInfo"+				OSInfo{osFrame=osFrame,osToolbar=osToolbar} = osinfo+	+		openMDIToolbar :: [ToolbarItem ps] -> OSDInfo -> GUI ps ()+		openMDIToolbar items osdInfo = do+			checkToolbarFatalError (isJust osToolbar) "openMDIToolbar" "toolbar already present"+			(tbPtr,tbHeight) <- liftIO (osCreateToolbar True osFrame (toTuple reqSize))+			checkToolbarFatalError (tbPtr == osNoWindowPtr) "openMDIToolbar" "toolbar could not be created"+			liftIO (foldrM (openToolbarItem tbPtr) 1 items)+			let ostoolbar = OSToolbar{toolbarPtr=tbPtr,toolbarHeight=tbHeight}+			let osinfo1 = osinfo{osToolbar=Just ostoolbar}+			appIOEnv (ioStSetOSDInfo (setOSDInfoOSInfo osinfo1 osdInfo))+			where+				reqSize	= getBitmapsSize items+				osinfo	= case (getOSDInfoOSInfo osdInfo) of+						Just info -> info+						Nothing   -> toolbarFatalError "openMDIToolbar" "could not retrieve OSInfo from OSDInfo"+				OSInfo{osFrame=osFrame,osToolbar=osToolbar} = osinfo++		openToolbarItem	:: OSToolbarHandle -> ToolbarItem ps -> Int -> IO Int+		openToolbarItem tbPtr (ToolbarItem bitmap tooltip _) index = do+			osCreateBitmapToolbarItem tbPtr bitmap index+			return (index+1)+		openToolbarItem tbPtr ToolbarSeparator index = do+			osCreateToolbarSeparator tbPtr+			return index++getBitmapsSize :: [ToolbarItem ps] -> Size+getBitmapsSize items =+	foldr maxBitmapSize (Size {w=osDefaultToolbarHeight,h=osDefaultToolbarHeight}) items+	where+		maxBitmapSize :: (ToolbarItem ps) -> Size -> Size+		maxBitmapSize item size = Size{w=max (w itemsize) (w size),h=max (h itemsize) (h size)}+			where+				itemsize = case item of+					ToolbarItem bitmap _ _	-> getBitmapSize bitmap+					_			-> zero
+ Graphics/UI/ObjectIO/Receiver/Access.hs view
@@ -0,0 +1,58 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Receiver.Access+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--	+-- Receiver.Access contains ReceiverHandle access.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Receiver.Access ( newReceiverHandle, newReceiver2Handle ) where+++import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.Receiver.DefAccess+import Graphics.UI.ObjectIO.Receiver.Handle+import Graphics.UI.ObjectIO.Process.IOState(liftIO)+import Data.IORef+++newReceiver2Handle :: R2Id m r -> SelectState -> Receiver2Function m r ls ps -> ReceiverHandle ls ps+newReceiver2Handle rid select f+	= ReceiverHandle+		{ rId        = r2IdtoId   rid+		, rSelect    = select+		, rFun       = receiverFunction+		}+	where+		input  = getR2IdIn  rid+		output = getR2IdOut rid++		receiverFunction ls_ps = do+			msg <- liftIO (readIORef input)+			liftIO (writeIORef input undefined)+			(resp, ls_ps) <- f msg ls_ps+			liftIO (writeIORef output resp)+			return ls_ps++newReceiverHandle :: RId m -> SelectState -> ReceiverFunction m ls ps -> ReceiverHandle ls ps+newReceiverHandle rid select f+	= ReceiverHandle+		{ rId        = rIdtoId   rid+		, rSelect    = select+		, rFun       = receiverFunction+		}+	where+		inChan  = getRIdIn  rid++		receiverFunction ls_ps = do+			(msg:msgs) <- liftIO (readIORef inChan)+			liftIO (writeIORef inChan msgs)+			ls_ps <- f msg ls_ps+			return ls_ps
+ Graphics/UI/ObjectIO/Receiver/DefAccess.hs view
@@ -0,0 +1,85 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Receiver.DefAccess+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--	+-- Access functions to ReceiverDefinitions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Receiver.DefAccess+		( receiverDefAttributes		, receiver2DefAttributes+		, receiverDefRId		, receiver2DefR2Id+		, receiverDefSelectState	, receiver2DefSelectState+		, receiverDefFunction		, receiver2DefFunction+		, receiverDefSetAbility		, receiver2DefSetAbility+		, receiverDefSetFunction	, receiver2DefSetFunction+		, module Graphics.UI.ObjectIO.StdReceiverDef+		) where++++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.StdReceiverAttribute+import Graphics.UI.ObjectIO.StdReceiverDef+++-- Receiver++receiverDefAttributes :: Receiver m ls ps -> [ReceiverAttribute ls ps]+receiverDefAttributes (Receiver _ _ atts) = atts++receiverDefRId :: Receiver m ls ps -> RId m+receiverDefRId (Receiver rid _ _) = rid++receiverDefSelectState :: Receiver m ls ps -> SelectState+receiverDefSelectState (Receiver _ _ atts) = getSelectState atts++receiverDefFunction :: Receiver m ls ps -> ReceiverFunction m ls ps+receiverDefFunction (Receiver _ f _) = f++receiverDefSetAbility :: SelectState -> Receiver m ls ps -> Receiver m ls ps+receiverDefSetAbility ability (Receiver rid f atts) = Receiver rid f (setSelectState ability atts)+	+receiverDefSetFunction :: ReceiverFunction m ls ps -> Receiver m ls ps -> Receiver m ls ps+receiverDefSetFunction f (Receiver rid _ atts) = Receiver rid f atts+++-- Receiver2++receiver2DefAttributes :: Receiver2 m r ls ps -> [ReceiverAttribute ls ps]+receiver2DefAttributes (Receiver2 _ _ atts) = atts++receiver2DefR2Id :: Receiver2 m r ls ps -> R2Id m r+receiver2DefR2Id (Receiver2 rid _ _) = rid++receiver2DefSelectState :: Receiver2 m r ls ps -> SelectState+receiver2DefSelectState (Receiver2 _ _ atts) = getSelectState atts++receiver2DefFunction :: Receiver2 m r ls ps -> Receiver2Function m r ls ps+receiver2DefFunction (Receiver2 _ f _) = f++receiver2DefSetAbility :: SelectState -> Receiver2 m r ls ps -> Receiver2 m r ls ps+receiver2DefSetAbility ability (Receiver2 rid f atts) = Receiver2 rid f (setSelectState ability atts)++receiver2DefSetFunction :: Receiver2Function m r ls ps -> Receiver2 m r ls ps -> Receiver2 m r ls ps+receiver2DefSetFunction f (Receiver2 rid _ atts) = Receiver2 rid f atts++++setSelectState :: SelectState -> [ReceiverAttribute ls ps] -> [ReceiverAttribute ls ps]+setSelectState ability atts+	= snd (creplace isReceiverSelectState (ReceiverSelectState ability) atts)++getSelectState :: [ReceiverAttribute ls ps] -> SelectState+getSelectState atts+	= getReceiverSelectStateAtt selectAtt+	where+		(_,selectAtt) = cselect isReceiverSelectState defSelect atts+		defSelect     = ReceiverSelectState Able
+ Graphics/UI/ObjectIO/Receiver/Device.hs view
@@ -0,0 +1,121 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Receiver.Device+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--	+-- Receiver.Device defines the receiver device event handlers.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Receiver.Device (receiverFunctions) where++++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.Receiver.Handle+import Graphics.UI.ObjectIO.OS.ReceiverEvent+import System.IO(fixIO)+import qualified Data.Map as Map++receiverdeviceFatalError :: String -> String -> x+receiverdeviceFatalError rule error+	= dumpFatalError rule "ReceiverDevice" error++receiverFunctions :: DeviceFunctions ps+receiverFunctions+	= DeviceFunctions+		{ dDevice = ReceiverDevice+		, dShow	  = return+		, dHide	  = return+		, dEvent  = receiverEvent+		, dDoIO   = receiverIO+		, dOpen   = receiverOpen+		, dClose  = receiverClose+		}++receiverOpen :: ps -> GUI ps ps+receiverOpen ps+	= do {+		hasReceiver <- accIOEnv (ioStHasDevice ReceiverDevice);+		if   hasReceiver+		then return ps+		else do {+			appIOEnv (ioStSetDevice (ReceiverSystemState (ReceiverHandles {rReceivers=[]})));+			appIOEnv (ioStSetDeviceFunctions receiverFunctions);+			return ps+		     }+	  }++receiverClose :: ps -> GUI ps ps+receiverClose ps+	= do {+		(found,rDevice) <- accIOEnv (ioStGetDevice ReceiverDevice);+		if   not found+		then return ps+		else +		let  rHs  = rReceivers $ receiverSystemStateGetReceiverHandles rDevice+		     rIds = map (\(ReceiverStateHandle _ rH) -> rId rH) rHs+		in+		do {+			idtable <- ioStGetIdTable;+			ioStSetIdTable (foldr Map.delete idtable rIds);+			appIOEnv (ioStRemoveDevice ReceiverDevice);+			appIOEnv (ioStRemoveDeviceFunctions ReceiverDevice);+			return ps+		}+	  }++{-	The receiver handles one message event:+	- ASyncMessage:+		this is a request to handle the first asynchronous message available in the+		asynchronous message queue. Globally the size of the asynchronous message queue+		has already been decreased.+	The QASyncMessage has become superfluous as it is replaced by Channel operations.+	The SyncMessage is currently ignored as synchronous message passing is not yet implemented.+-}+receiverIO :: DeviceEvent -> ps -> GUI ps ps+receiverIO deviceEvent ps+	= do {+		(found,rDevice) <- accIOEnv (ioStGetDevice ReceiverDevice);+		if   not found		-- This condition should not occur: dDoIO function should be applied only iff dEvent filters message+		then receiverdeviceFatalError "receiverIO" "could not retrieve ReceiverSystemState from IOSt"+		else +		let  rsHs = rReceivers $ receiverSystemStateGetReceiverHandles rDevice+		in   receiverIO deviceEvent rsHs ps+	  }+	where+		receiverIO :: DeviceEvent -> [ReceiverStateHandle ps] -> ps -> GUI ps ps+		+		receiverIO (ReceiverEvent rId) rsHs ps = do+			it <- ioStGetIdTable+			let Just idParent = Map.lookup rId it+			let dummy           = receiverdeviceFatalError "receiverIO (ReceiverEvent (ASyncMessage _))" "receiver could not be found"+			let (_,rsH,rsHs1)   = remove (identifyReceiverStateHandle (idpId idParent)) dummy rsHs+			toGUI (letReceiverDoIO rsH rsHs1 ps)+			where						+				letReceiverDoIO :: ReceiverStateHandle ps -> [ReceiverStateHandle ps] -> ps -> IOSt ps -> IO (ps,IOSt ps)+				letReceiverDoIO (ReceiverStateHandle ls rH@(ReceiverHandle {rFun=rFun})) rsHs ps ioState+					= do {+						r   <- fixIO (\st -> fromGUI (rFun (ls,ps))+									     (ioStSetDevice +										 (ReceiverSystemState+										     (ReceiverHandles +											 {rReceivers=rsHs ++ [ReceiverStateHandle (fst (fst st)) rH]}))+										 ioState));+						let ((_,ps1),ioState1) = r+						in  return (ps1,ioState1)+					  }++		receiverIO _ _ _ = receiverdeviceFatalError "receiverIO" "device event passed receiver event filter without handling"+++identifyReceiverStateHandle :: Id -> ReceiverStateHandle ps -> Bool+identifyReceiverStateHandle id (ReceiverStateHandle _ (ReceiverHandle {rId=rId})) = id==rId
+ Graphics/UI/ObjectIO/Receiver/Handle.hs view
@@ -0,0 +1,46 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Receiver.Handle+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--	+-- Receiver.Handle contains the internal data structures that represent the +-- state of receivers. +--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Receiver.Handle where+++import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.StdReceiverDef+++data	ReceiverHandles ps+ =	ReceiverHandles+ 		{ rReceivers :: [ReceiverStateHandle ps]+		}+data	ReceiverStateHandle ps+ =	forall ls .+	ReceiverStateHandle +		ls					-- The local state of the receiver+		(ReceiverHandle ls ps)			-- The receiver handle++data	ReceiverHandle ls ps+ =	ReceiverHandle+		{ rId           :: Id			-- The id of the receiver+		, rSelect       :: SelectState		-- The current SelectState of the receiver+		, rFun          :: GUIFun ls ps+		}+++receiverIdentified :: Id -> ReceiverHandle ls ps -> Bool+receiverIdentified id rH = id==rId rH++receiverSetSelectState :: SelectState -> ReceiverStateHandle ps -> ReceiverStateHandle ps+receiverSetSelectState select rsH@(ReceiverStateHandle ls rH) = ReceiverStateHandle ls (rH {rSelect=select})
+ Graphics/UI/ObjectIO/Relayout.hs view
@@ -0,0 +1,318 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Relayout+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Relayout where+++import	Graphics.UI.ObjectIO.CommonDef+import  Graphics.UI.ObjectIO.Window.Handle+import  Graphics.UI.ObjectIO.Window.Access(getCompoundContentRect, getCompoundHScrollRect, getCompoundVScrollRect)+import  Graphics.UI.ObjectIO.StdPicture(Look, toRegion, accClipPicture)+import	Graphics.UI.ObjectIO.OS.Rgn+import  Graphics.UI.ObjectIO.OS.Window+import  Graphics.UI.ObjectIO.OS.Picture(Draw(..), defaultPen, +		  getPictOrigin, setPictOrigin, getPictPen, setPictPen,+		  pictGetClipRgn, pictSetClipRgn, pictAndClipRgn, doDraw)+import  Graphics.UI.ObjectIO.OS.Cutil_12(addr2int, nullPtr)+import  Control.Monad(when, unless)+++data RelayoutItem+   = RelayoutItem+   	{ rliItemKind	:: !ControlKind		-- The control kind+	, rliItemPtr	:: !OSWindowPtr		-- The ptr to the item+	, rliItemPos	:: !Point2		-- The exact position of the item+	, rliItemSize	:: !Size		-- The exact size of the item+	, rliItemSelect	:: !Bool		-- The item is Able (True) or Unable (False)+	, rliItemShow	:: !Bool		-- The item is visible (True) or invisible (False)+	, rliItemInfo	:: CompoundInfo		-- If the control kind is IsCompoundControl: its CompoundInfo; otherwise undefined+	, rliItemLook	:: LookInfo		-- If the control kind is IsCustom(Button)Control: its LookInfo; otherwise undefined+	, rliItems	:: ![RelayoutItem]	-- If the control kind is Is(Compound/Layout)Control: its elements; otherwise: []+	}++relayoutFatalError :: String -> String -> x+relayoutFatalError function error+	= dumpFatalError function "relayout" error+++{-	relayoutItems resizes and moves changed items.+		The two Rect   arguments are the window frames in which the elements reside.+		The two Point2 arguments are the positions of the parent window/compound.+		The OSWindowPtr is the parent window/dialog.+		The first  RelayoutItem list contains the elements at their original location and size.+		The second RelayoutItem list contains the elements at their new location and size.+	Assumptions: +		* The two lists contain elements that are identical except for size and position+		* (Radio/Check)Controls are flattened and have rliItemKind Is(Radio/Check)Control+		* The ClipStates of CompoundControls are valid.+	This version uses the HDC of the parent window in order to suppress calls to initpicture.+		Regions are used to clip sibling controls.+		In addition, two regions (validRegion,invalidRegion) are maintained that administrate whether part of the window requires+		update after relayout. This is done as follows:+			* initially validRegion and invalidRegion are empty.+			* for each relayoutitem: if its oldFrame<>newFrame then it adds newFrame to validRegion, and oldFrame to invalidRegion+			* the area to be updated equals validRegion - invalidRegion (so if its empty, then no update is required)+	relayoutItems returns the update region. +-}+++relayoutItems :: OSWindowMetrics -> Rect -> Rect -> Point2 -> Point2 -> OSWindowPtr -> [RelayoutItem] -> [RelayoutItem] -> IO OSRgnHandle+relayoutItems wMetrics oldFrame newFrame oldParentPos newParentPos wPtr oldHs newHs = do+    clipRgn <- osNewRectRgn newFrame+    validRgn <- osNewRectRgn zero+    invalidRgn <- osNewRectRgn zero+    osPict <- osGrabWindowPictContext wPtr+    ((clipRgn,validRgn,invalidRgn), _, _, _) <-+    		doDraw zero defaultPen True osNoRgn osPict False (accClipPicture (toRegion (rectToRectangle newFrame))+			(relayoutItems' wPtr wMetrics newArea (oldFrame,oldParentPos,oldHs)+				(newFrame,newParentPos,newHs)+				(clipRgn,validRgn,invalidRgn)))+    osReleaseWindowPictContext wPtr osPict+    updRgn <- osDiffRgn	invalidRgn validRgn+    mapM_ osDisposeRgn [clipRgn,validRgn,invalidRgn]+    return updRgn+    where+	newArea				= subtractRects newFrame oldFrame+	+	relayoutItems' :: OSWindowPtr -> OSWindowMetrics -> [Rect] -> (Rect,Point2,[RelayoutItem]) -> (Rect,Point2,[RelayoutItem]) +			-> (OSRgnHandle,OSRgnHandle,OSRgnHandle) -> Draw (OSRgnHandle,OSRgnHandle,OSRgnHandle)+	relayoutItems' wPtr wMetrics newArea (oldFrame,oldParentPos,(oldH:oldHs)) (newFrame,newParentPos,(newH:newHs)) rgnHs = do+	    rgnHs1 <- relayoutItem wPtr wMetrics newArea (oldFrame,oldParentPos,oldH)  (newFrame,newParentPos,newH)  rgnHs+	    rgnHs2 <- relayoutItems' wPtr wMetrics newArea (oldFrame,oldParentPos,oldHs) (newFrame,newParentPos,newHs) rgnHs1+	    return rgnHs2+	    where+		relayoutItem :: OSWindowPtr -> OSWindowMetrics -> [Rect] -> (Rect,Point2,RelayoutItem) -> (Rect,Point2,RelayoutItem) ->+						(OSRgnHandle,OSRgnHandle,OSRgnHandle) -> Draw (OSRgnHandle,OSRgnHandle,OSRgnHandle)+		relayoutItem wPtr wMetrics newArea old@(_,_,RelayoutItem{rliItemKind=k1}) new@(_,_,RelayoutItem{rliItemKind=k2}) rgnHs+			| k1 /= k2		= relayoutFatalError "relayoutItem" "mismatching RelayoutItems"		+			| otherwise		= relayout wPtr wMetrics newArea k1 old new rgnHs+			where+			    {-	relayout assumes that the two RelayoutItem arguments +				    have the same ControlKind (fourth argument) and differ only in size or position or both.+			    -}+			    relayout :: OSWindowPtr -> OSWindowMetrics -> [Rect] -> ControlKind -> (Rect,Point2,RelayoutItem) -> (Rect,Point2,RelayoutItem) ->+						    (OSRgnHandle,OSRgnHandle,OSRgnHandle) -> Draw (OSRgnHandle,OSRgnHandle,OSRgnHandle)++			    relayout wPtr wMetrics newArea IsCompoundControl (oldFrame,oldParentPos,old) (newFrame,newParentPos,new)+					    (clipRgn,validRgn,invalidRgn) = do+				liftIO (sizeF >> moveF)+				updF+				liftIO updScrollbars		-- update scrollbars AFTER moving/sizing/updating+				(clipRgn,validRgn,invalidRgn) <- relayoutItems' wPtr wMetrics newArea1 (oldFrame1,oldPos,rliItems old)+											(newFrame1,newPos,rliItems new) (clipRgn,validRgn,invalidRgn)+				(if rliItemShow new then do+				   (validRgn1,invalidRgn1) <- liftIO (checkUpdateRegions oldFrame1 newFrame1 (validRgn,invalidRgn))+				   clipRgn1 <- liftIO (subtractRectFromRgn (intersectRects newFrame newCompoundRect) clipRgn)+				   return (clipRgn1,validRgn1,invalidRgn1)+				 else+				   return (clipRgn,validRgn,invalidRgn))				+				 where+				    sameSize = oldSize==newSize+				    samePos	 = osCompoundMovesControls && oldPos-oldParentPos==newPos-newParentPos || oldPos==newPos+				    sizeF	 = unless sameSize+					    (osSetCompoundSize wPtr newParentPos' itemPtr newPos' newSize' True)+				    moveF	 = unless (samePos && all isEmptyRect (map (intersectRects newFrame1) newArea))+					    (osSetCompoundPos  wPtr newParentPos' itemPtr newPos' newSize' True)+				    updScrollbars = unless (sameSize && samePos && all isEmptyRect (concat (map (\area->[intersectRects hRect' area,intersectRects vRect' area]) newArea)))+					    ( (setCompoundScroll (fst hasScrolls) wMetrics itemPtr True  newHThumbSize (x oldOrigin) (x newOrigin) hRect) >>+					      (setCompoundScroll (snd hasScrolls) wMetrics itemPtr False newVThumbSize (y oldOrigin) (y newOrigin) vRect)+					    )+				    updF = unless (sameSize && oldPos==newPos && oldFrame1==newFrame1 || isEmptyRect newFrame1 || not (rliItemShow new))+					    (updateCustomControl wPtr clipRgn newFrame1 new)+				    newParentPos'	= toTuple newParentPos+				    itemPtr		= rliItemPtr new+				    newSize		= rliItemSize new+				    newSize'		= toTuple newSize+				    oldSize		= rliItemSize old+				    newPos		= rliItemPos new+				    newPos'		= toTuple newPos+				    oldPos		= rliItemPos old+				    newInfo		= rliItemInfo new+				    oldInfo		= rliItemInfo old +				    newOrigin		= compoundOrigin newInfo+				    oldOrigin		= compoundOrigin oldInfo+				    newDomainRect	= compoundDomain newInfo+				    oldDomainRect	= compoundDomain oldInfo+				    newCompoundRect	= posSizeToRect newPos newSize+				    oldCompoundRect	= posSizeToRect oldPos oldSize+				    newFrame1		= intersectRects newFrame newContentRect+				    oldFrame1		= intersectRects oldFrame oldContentRect+				    newArea1		= subtractRects newFrame1 oldFrame1+				    hasScrolls		= (isJust (compoundHScroll newInfo),isJust (compoundVScroll newInfo))+				    newVisScrolls	= osScrollbarsAreVisible wMetrics newDomainRect newSize' hasScrolls+				    oldVisScrolls	= osScrollbarsAreVisible wMetrics oldDomainRect (toTuple oldSize) hasScrolls+				    newHThumbSize	= ((w newSize)-(if snd newVisScrolls then osmVSliderWidth  wMetrics else 0)+1)+				    newVThumbSize	= ((h newSize)-(if fst newVisScrolls then osmHSliderHeight wMetrics else 0)+1)+				    oldContentRect	= getCompoundContentRect wMetrics oldVisScrolls oldCompoundRect+				    newContentRect	= getCompoundContentRect wMetrics newVisScrolls newCompoundRect+				    hRect		= getCompoundHScrollRect wMetrics newVisScrolls (sizeToRect newSize)+				    hRect'		= addVector (toVector newPos) hRect+				    vRect		= getCompoundVScrollRect wMetrics newVisScrolls (sizeToRect newSize)+				    vRect'		= addVector (toVector newPos) vRect++				    setCompoundScroll :: Bool -> OSWindowMetrics -> OSWindowPtr -> Bool -> Int -> Int -> Int -> Rect -> IO ()+				    setCompoundScroll hasScroll wMetrics compoundPtr isHorizontal size old new (Rect {rright=right,rbottom=bottom})+					    | not hasScroll	= return ()+					    | otherwise = do+						    osSetCompoundSliderThumbSize wMetrics compoundPtr isHorizontal size (right,bottom) (old==new)+						    when (old /= new) (osSetCompoundSliderThumb wMetrics compoundPtr isHorizontal new (right,bottom) True)++			    relayout wPtr wMetrics newArea IsLayoutControl (oldFrame,oldParentPos,old) (newFrame,newParentPos,new) rgnHs =+				    relayoutItems' wPtr wMetrics newArea (oldFrame1,oldParentPos,rliItems old) (newFrame1,newParentPos,rliItems new) rgnHs				    +				    where+				      newSize	= rliItemSize new+				      oldSize	= rliItemSize old+				      newPos	= rliItemPos  new+				      oldPos	= rliItemPos  old+				      newLayoutRect	= posSizeToRect newPos newSize+				      oldLayoutRect	= posSizeToRect oldPos oldSize+				      newFrame1	= intersectRects newFrame newLayoutRect+				      oldFrame1	= intersectRects oldFrame oldLayoutRect++			    relayout wPtr wMetrics newArea controlKind (oldFrame,oldParentPos,old) (newFrame,newParentPos,new) (clipRgn,validRgn,invalidRgn) = do+				    liftIO (sizeF >> moveF)+				    updF+				    (if rliItemShow new then do+					    (validRgn,invalidRgn) <- liftIO (checkUpdateRegions oldFrame1 newFrame1 (validRgn,invalidRgn))+					    clipRgn <- liftIO (subtractRectFromRgn newFrame1 clipRgn)+					    return (clipRgn,validRgn,invalidRgn)+				     else return (clipRgn,validRgn,invalidRgn))				    +				    where+					sameSize	= oldSize==newSize+					samePos		= osCompoundMovesControls && oldPos-oldParentPos==newPos-newParentPos || oldPos==newPos+					sizeF		= unless sameSize+					    			(setSize wPtr newParentPos' itemPtr newPos' newSize' (not redraw))+					moveF		= unless (samePos && all isEmptyRect (map (intersectRects newFrame1) newArea))+					    			(setPos  wPtr newParentPos' itemPtr newPos' (toTuple oldSize) (not redraw))+					updF		= unless (not redraw || sameSize && oldPos==newPos && newFrame1==oldFrame1 || isEmptyRect newFrame1 || not (rliItemShow new))+					    			(updateCustomControl wPtr clipRgn newFrame1 new)+					newParentPos'	= toTuple newParentPos+					itemPtr		= rliItemPtr new+					newPos		= rliItemPos new+					newPos'		= toTuple newPos+					oldPos		= rliItemPos  old+					newSize		= rliItemSize new+					newSize'	= toTuple newSize+					oldSize		= rliItemSize old				    +					oldFrame1	= intersectRects oldFrame (posSizeToRect oldPos oldSize)+					newFrame1	= intersectRects newFrame (posSizeToRect newPos newSize)+					(setPos,setSize,redraw) = case controlKind of+						    IsRadioControl		-> (osSetRadioControlPos,		\_ _ _ _ _ _ -> return (),	False)+						    IsCheckControl		-> (osSetCheckControlPos,		\_ _ _ _ _ _ -> return (),	False)+						    IsPopUpControl		-> (osSetPopUpControlPos,		osSetPopUpControlSize,		False)+						    IsListBoxControl		-> (osSetListBoxControlPos,		osSetListBoxControlSize,	False)+						    IsSliderControl		-> (osSetSliderControlPos,		osSetSliderControlSize,		False)+						    IsTextControl		-> (osSetTextControlPos,		osSetTextControlSize,		False)+						    IsEditControl		-> (osSetEditControlPos,		osSetEditControlSize,		False)+						    IsButtonControl		-> (osSetButtonControlPos,		osSetButtonControlSize,		False)+						    IsCustomButtonControl	-> (osSetCustomButtonControlPos,	osSetCustomButtonControlSize,	True)+						    IsCustomControl		-> (osSetCustomControlPos,		osSetCustomControlSize,		True)+						    IsReceiverControl 		-> (\_ _ _ _ _ _ -> return (),		\_ _ _ _ _ _ -> return (),	False)+						    _			-> relayoutFatalError "relayout" "unexpected ControlKind alternative"+			+	relayoutItems' _ _ _ (_,_,[]) (_,_,[]) rgnHs = return rgnHs+	relayoutItems' _ _ _ _ _ _+		= relayoutFatalError "relayoutItems'" "mismatching RelayoutItems"+	+	checkUpdateRegions :: Rect -> Rect -> (OSRgnHandle,OSRgnHandle) -> IO (OSRgnHandle,OSRgnHandle)+	checkUpdateRegions oldFrame newFrame rgnHs@(validRgn,invalidRgn)+		| oldFrame==newFrame = return rgnHs+		| otherwise = do+		    newFrameRgn <- osNewRectRgn newFrame+		    oldFrameRgn <- osNewRectRgn oldFrame+		    okNewRgn <- osDiffRgn  newFrameRgn invalidRgn			-- PA++++		    newValidRgn <- osUnionRgn okNewRgn validRgn				-- PA: okNewRgn <-- newFrameRgn+		    newInvalidRgn <- osUnionRgn oldFrameRgn invalidRgn+		    mapM_ osDisposeRgn [validRgn,invalidRgn,newFrameRgn,oldFrameRgn,okNewRgn]	-- PA: okNewRgn added+		    return (newValidRgn,newInvalidRgn)+	+	subtractRectFromRgn :: Rect -> OSRgnHandle -> IO OSRgnHandle+	subtractRectFromRgn rect rgn+		| isEmptyRect rect = return rgn+		| otherwise = do+		    rectRgn <- osNewRectRgn rect+		    diffRgn <- osDiffRgn rgn rectRgn+		    osDisposeRgn rectRgn+		    osDisposeRgn rgn+		    return diffRgn+	+	--	updateCustomControl assumes that the item is visible.+	updateCustomControl :: OSWindowPtr -> OSRgnHandle -> Rect -> RelayoutItem -> Draw ()+	updateCustomControl parentPtr clipRgn contentRect itemH@(RelayoutItem{rliItemKind=IsCustomButtonControl}) = do		+		curOrigin <- getPictOrigin+		curPen <- getPictPen+		setPictOrigin (zero-itemPos)+		setPictPen lookPen+		clipOSPicture clipRgn contentRect (lookFun selectState updState)+		setPictPen curPen+		setPictOrigin curOrigin+		return ()+		where+		  selectState		= if rliItemSelect itemH then Able else Unable+		  itemPos		= rliItemPos itemH		  +		  cFrame		= sizeToRectangle (rliItemSize itemH)+		  updState		= UpdateState{oldFrame=cFrame,newFrame=cFrame,updArea=[cFrame]}+		  LookInfo{lookFun=lookFun,lookPen=lookPen} = rliItemLook itemH+	+	updateCustomControl parentPtr clipRgn contentRect itemH@(RelayoutItem{rliItemKind=IsCustomControl}) = do+		curOrigin <- getPictOrigin+		curPen <- getPictPen+		setPictOrigin (zero-itemPos)+		setPictPen lookPen+		clipOSPicture clipRgn contentRect (lookFun selectState updState)+		setPictPen curPen+		setPictOrigin curOrigin+		return ()+		where+		  selectState		= if rliItemSelect itemH then Able else Unable+		  itemPos		= rliItemPos itemH		  +		  cFrame		= sizeToRectangle (rliItemSize itemH)+		  updState		= UpdateState{oldFrame=cFrame,newFrame=cFrame,updArea=[cFrame]}+		  LookInfo{lookFun=lookFun,lookPen=lookPen} = rliItemLook itemH+	+	updateCustomControl parentPtr clipRgn' contentRect itemH@(RelayoutItem{rliItemKind=IsCompoundControl}) = do+		curOrigin <- getPictOrigin+		curPen <- getPictPen+		setPictOrigin (origin-itemPos)+		setPictPen lookPen+		clip <- liftIO (osSectRgn clipRgn' (clipRgn clipInfo)) -- PA++++		clipOSPicture clip clipRect (lookFun selectState updState)+		liftIO (osDisposeRgn clip)				-- PA++++		setPictPen curPen+		setPictOrigin curOrigin+		return ()+		where+		  selectState		= if rliItemSelect itemH then Able else Unable+		  itemSize		= rliItemSize itemH+		  itemPos		= rliItemPos itemH+		  info			= rliItemInfo itemH		  +		  visScrolls		= osScrollbarsAreVisible wMetrics domainRect (toTuple itemSize) hasScrolls+		  cFrameRect		= getCompoundContentRect wMetrics visScrolls (posSizeToRect origin itemSize)+		  cFrame		= rectToRectangle cFrameRect+		  compLookInfo		= compoundLookInfo info		  +		  clipInfo		= compoundClip compLookInfo+		  updState		= UpdateState{oldFrame=cFrame,newFrame=cFrame,updArea=[cFrame]}+		  cRect			= addVector (toVector (itemPos-origin)) cFrameRect+		  clipRect		= intersectRects contentRect cRect+		  LookInfo{lookFun=lookFun,lookPen=lookPen} = compoundLook compLookInfo+		  (origin,domainRect,hasScrolls) = (compoundOrigin info,compoundDomain info,(isJust (compoundHScroll info),isJust (compoundVScroll info)))++	clipOSPicture :: OSRgnHandle -> Rect -> Draw () -> Draw ()+	clipOSPicture newClipRgn rect drawf = do+		rectRgn <- liftIO (osNewRectRgn rect)+		curClipRgn <- pictGetClipRgn+		(if curClipRgn==nullPtr then pictSetClipRgn else pictAndClipRgn) rectRgn+		when (newClipRgn /= nullPtr) (pictAndClipRgn newClipRgn)+		drawf+		pictSetClipRgn curClipRgn+		liftIO (when (curClipRgn /= nullPtr) (osDisposeRgn curClipRgn) >> osDisposeRgn rectRgn)
+ Graphics/UI/ObjectIO/StdBitmap.hs view
@@ -0,0 +1,61 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdBitmap+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Interface functions for drawing bitmaps.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdBitmap where++import	Graphics.UI.ObjectIO.OS.Bitmap+import	Graphics.UI.ObjectIO.OS.Picture+import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.StdPicture++-- | An abstract type which represent the bitmap. There is instance of 'Drawables' class+type Bitmap = OSBitmap++-- | creates a bitmap from the given file name+openBitmap :: IOMonad m => FilePath -> m (Maybe Bitmap)+openBitmap name = liftIO (osReadBitmap name)++-- | Warning: Allways dispose of the bitmap when it is no longer needed+disposeBitmap :: IOMonad m => Bitmap -> m ()+disposeBitmap bmp = liftIO (osDisposeBitmap bmp)++-- | returns the current bitmap size+getBitmapSize :: Bitmap -> Size+getBitmapSize bitmap = fromTuple (osGetBitmapSize bitmap)	++-- | resizes the bitmap. The resizing of the bitmap affects only the data that is in the memory. The visual effect will appear when the bitmap is displayed+resizeBitmap :: Size -> Bitmap -> Bitmap+resizeBitmap size@(Size {w=w,h=h}) bitmap+	| w<0 || h<0 = error "resizeBitmap" "StdBitmap" "a Size record with negative components was passed"+	| otherwise  = osResizeBitmap (w,h) bitmap++instance Drawables Bitmap where+	draw bitmap = do		+		  penPos <- getPenPos+		  origin <- getPictOrigin+		  osDrawBitmap bitmap (toTuple penPos) (toTuple origin)+	+	drawAt pos bitmap = do+		origin <- getPictOrigin+		osDrawBitmap bitmap (toTuple pos) (toTuple origin)		+	+	undraw bitmap =+		unfill (Box {box_w=w,box_h=h})+		where+			(w,h)	= osGetBitmapSize bitmap+	+	undrawAt pos bitmap =+		unfillAt pos (Box {box_w=w,box_h=h})+		where+			(w,h)	= osGetBitmapSize bitmap
+ Graphics/UI/ObjectIO/StdClipboard.hs view
@@ -0,0 +1,82 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdClipboard+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdClipboard specifies all functions on the clipboard.+-- The current clipboard implementation supports only string data type.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdClipboard+		( ClipboardItem+		, Clipboard(..)+		, setClipboard+		, getClipboard+		) where++import	Data.Maybe+import	Graphics.UI.ObjectIO.OS.Clipboard+import	Graphics.UI.ObjectIO.CommonDef(dumpFatalError, remove)+import	Graphics.UI.ObjectIO.Process.IOState(GUI(..), liftIO)+++stdClipboardFatalError :: String -> String -> x+stdClipboardFatalError function error+	= dumpFatalError function "StdClipboard" error+++--	The clipboard item type:++data ClipboardItem+	= ClipboardString String		-- Support for strings+--	| ClipboardPict	Handle			-- Support for pictures (PA: not supported yet)++class Clipboard item where+	toClipboard	:: item			-> ClipboardItem+	fromClipboard	:: ClipboardItem	-> Maybe item++instance Clipboard String where+	toClipboard string = ClipboardString string+	fromClipboard (ClipboardString string) = Just string+	+++--	Reading and writing the value of the selection to the clipboard:++setClipboard :: [ClipboardItem] -> GUI ps ()+setClipboard clipItems = liftIO (mapM_ clipboardItemToScrap singleItems)+    where+	singleItems = removeDuplicateClipItems clipItems++	removeDuplicateClipItems :: [ClipboardItem] -> [ClipboardItem]+	removeDuplicateClipItems (item:items) =+	    let (_,_,items1)	= remove (eqClipboardType item) undefined items+	    in (item:removeDuplicateClipItems items1)+	    where+		eqClipboardType :: ClipboardItem -> ClipboardItem -> Bool+		eqClipboardType (ClipboardString _) item	= case item of+			(ClipboardString _)	-> True+			_			-> False+	removeDuplicateClipItems [] = []++	clipboardItemToScrap :: ClipboardItem -> IO ()+	clipboardItemToScrap (ClipboardString text) = osSetClipboardText text++getClipboard :: GUI ps [ClipboardItem]+getClipboard = do+    contents <- liftIO (osGetClipboardContent)+    let contents1 = filter ((==) osClipboardText) contents+    liftIO (mapM scrapToClipboardItem contents1)+    where+	scrapToClipboardItem :: Int -> IO ClipboardItem+	scrapToClipboardItem clipType+		| clipType == osClipboardText = do+			text <- osGetClipboardText+		 	return (ClipboardString text)+		| otherwise = stdClipboardFatalError "getClipboard" ("unimplemented clipboard content of type: " ++ show clipType)
+ Graphics/UI/ObjectIO/StdControl.hs view
@@ -0,0 +1,958 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdControl+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdControl specifies all control operations.+-- Object I\/O library supports various kinds of built-in controls which+-- can be placed inside windows and dialogs. In order to define his\/her+-- own type controls, the user should give an instance of Controls class+-- (see "Graphics.UI.ObjectIO.StdWindow")+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdControl+		( +		-- * Function declarations+		+		-- ** Common+		  getParentWindowId, controlSize+		, openControls, closeControls, closeAllControls,+		+		-- ** Show\/Hide controls.+		  showControl, showControls+		, hideControl, hideControls+		, getControlShowStates, getControlShowState,+		+		-- ** Enabling\/Disabling of controls.+		  enableControl,  enableControls+		, disableControl, disableControls+		, getControlSelectStates, getControlSelectState, +		+		-- ** Control layout+		  getControlLayouts, getControlLayout,+		+		-- ** Get\/Change the text of (Text\/Edit\/Button)Control.+		  setControlText, setControlTexts+		, getControlText, getControlTexts, +		+		-- ** Drawing in CustomControl, CustomButtonControl and CompoundControl+		  drawInControl, updateControl+		, setControlLooks, setControlLook+		, getControlLooks, getControlLook,+		+		-- ** Positioning and resizing of controls+		  setControlPos, getControlViewSize, getControlViewSizes+		, getControlOuterSizes, getControlOuterSize+		, getControlMinimumSizes, getControlMinimumSize+		, getControlResizes, getControlResize,++		-- ** Selection controls (The functions are applicable to +		-- PopUpControl, ListBoxControl, CheckControl and RadioControl)+		  getControlItems, getControlItem+		, selectControlItem+		, getControlSelections, getControlSelection+		, markControlItems, unmarkControlItems, setControlsMarkState+		, getControlMarks, getControlMark,+		+		-- ** Compound control specific functions.+		  getControlViewFrames, getControlViewFrame, moveControlViewFrame+		, getControlViewDomains, getControlViewDomain, setControlViewDomain+		, getControlScrollFunction, getControlScrollFunctions, setControlScrollFunction+		, openCompoundControls,+		+		-- ** Edit control specific functions.+		  setEditControlCursor+		, getControlNrLines, getControlNrLine,+		+		-- ** PopUp control specific functions.+		  openPopUpControlItems, closePopUpControlItems,+		  +		-- ** ListBox control specific functions.+		  openListBoxControlItems, closeListBoxControlItems,+		+		-- ** Slider control specific functions.+		  setSliderState, setSliderStates+		, setSliderThumb, setSliderThumbs+		, getSliderDirection, getSliderDirections+		, getSliderState, getSliderStates, +		+		-- * A visible modules+		  module Graphics.UI.ObjectIO.StdControlDef+		, module Graphics.UI.ObjectIO.StdControlClass+		) where++++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Control.Access+import Graphics.UI.ObjectIO.Control.Internal+import Graphics.UI.ObjectIO.Control.Layout+import Graphics.UI.ObjectIO.Control.Validate(disjointControlIds, controlIdsAreConsistent, getWElementControlIds)+import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.StdControlDef+import Graphics.UI.ObjectIO.StdControlClass+import Graphics.UI.ObjectIO.Window.Access+import Graphics.UI.ObjectIO.Window.Update(updateWindow)+import Graphics.UI.ObjectIO.Window.ClipState (forceValidWindowClipState)+import Graphics.UI.ObjectIO.Window.Controls+import Graphics.UI.ObjectIO.OS.System+import Graphics.UI.ObjectIO.OS.Window(osScrollbarsAreVisible)+import Graphics.UI.ObjectIO.OS.Picture(Draw)+import Control.Monad(unless)+import qualified Data.Map as Map+++stdControlFatalError :: String -> String -> x+stdControlFatalError function error+	= dumpFatalError function "StdControl" error++--	The function isOkControlId can be used to filter out the proper IdParent records.+isOkControlId :: SystemId -> (x,Maybe IdParent) -> (Bool,(x,Id))+isOkControlId ioId (x,Just (IdParent {idpIOId=idpIOId,idpDevice=idpDevice,idpId=idpId})) =+	(ioId==idpIOId && idpDevice==WindowDevice,(x,idpId))+isOkControlId _ _ =+	(False,undefined)++-- | getParentWindowId returns id of parent window of control with specified Id.+getParentWindowId :: Id -> GUI ps (Maybe Id)+getParentWindowId id = do+	idtable <- ioStGetIdTable+	ioId <- accIOEnv ioStGetIOId+	let maybeParent = Map.lookup id idtable+	let (valid,(_,parentId)) = isOkControlId ioId ((),maybeParent)+	return (if valid then Just parentId else Nothing)++getParentWindowIds :: (a -> Id) -> [a] -> GUI ps [(a, Id)]+getParentWindowIds getId xs = do+	idtable <- ioStGetIdTable+	ioId <- accIOEnv ioStGetIOId+	let parentIds  = map (flip Map.lookup idtable . getId) xs+	return (filterMap (isOkControlId ioId) (zip xs parentIds))+++mapWindow :: Id -> (forall ls . OSWindowMetrics -> WIDS -> WindowHandle ls ps -> x -> IO (WindowHandle ls ps, x)) -> x -> GUI ps x+mapWindow windowId f x = do+	(found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice);+	(if   not found+	 then stdControlFatalError "mapWindow" "WindowSystemState could not be retrieved from IOSt"+	 else +		let+			windows              = windowSystemStateGetWindowHandles wDevice+			(found,wsH,windows1) = getWindowHandlesWindow (toWID windowId) windows+		in if not found then throwGUI ErrorUnknownObject+		   else do+				wMetrics <- accIOEnv ioStGetOSWindowMetrics+				(wsH1, x1) <- liftIO (ff f wMetrics wsH x)+				let windows2 = setWindowHandlesWindow wsH1 windows1+				appIOEnv (ioStSetDevice (WindowSystemState windows2))+				return x1)+	where+		ff :: (forall ls . OSWindowMetrics -> WIDS -> WindowHandle ls ps -> x -> IO (WindowHandle ls ps, x)) -> OSWindowMetrics -> WindowStateHandle ps -> x -> IO (WindowStateHandle ps, x)+	  	ff f wMetrics (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) x = do+	  		(wH1,x1) <- f wMetrics wids wH x+	  		return (WindowStateHandle wids (Just wlsH{wlsHandle=wH1}),x1)+++-- | giving horizontal and vertical margins and item spaces, controlSize function  +-- calculates the size of the given control.+controlSize :: (Controls cdef) => cdef ls ps -> Bool -> Maybe (Int,Int) -> Maybe (Int,Int) -> Maybe (Int,Int) -> GUI ps Size+controlSize cdef isWindow hMargins vMargins itemSpaces+	= do {+		cs       <- controlToHandles cdef;+		wMetrics <- accIOEnv ioStGetOSWindowMetrics;+		let+			itemHs      = map controlStateToWElementHandle cs+			hMargins'   = case hMargins of+					Just (left,right) -> (max 0 left,max 0 right)+					_                 -> if isWindow then (0,0) else (osmHorMargin wMetrics,osmHorMargin wMetrics)+			vMargins'   = case vMargins of+					Just (top,bottom) -> (max 0 top,max 0 bottom)+					_                 -> if isWindow then (0,0) else (osmVerMargin wMetrics,osmVerMargin wMetrics)+			itemSpaces' = case itemSpaces of+					Just (hor,vert)   -> (max 0 hor,max 0 vert)+					_                 -> (osmHorItemSpace wMetrics,osmVerItemSpace wMetrics)+			domain      = viewDomainRange {corner1=zero}+		in liftIO (calcControlsSize wMetrics hMargins' vMargins' itemSpaces' zero zero [(domain,zero)] itemHs)+	  }+++-- | Controls can be dynamically added to an existing window with openControls function.+openControls :: Controls cdef => Id -> ls -> cdef ls ps -> GUI ps ()+openControls wId ls newControls = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then throwGUI ErrorUnknownObject+	 else let+		windows = windowSystemStateGetWindowHandles wDevice+		(found,wsH,windows1) = getWindowHandlesWindow (toWID wId) windows+	      in if not found then throwGUI ErrorUnknownObject+	         else do+			cs <- controlToHandles newControls+			let newItemHs = map controlStateToWElementHandle cs+	  		let currentIds = getWindowStateHandleIds wsH+	  		(if not (disjointControlIds currentIds newItemHs) then throwGUI ErrorIdsInUse+			 else do				+				it <- ioStGetIdTable+				ioId <- accIOEnv ioStGetIOId+				(case controlIdsAreConsistent ioId wId newItemHs it of+					Nothing -> throwGUI ErrorIdsInUse+					Just it -> do+						ioStSetIdTable it+						wMetrics <- accIOEnv ioStGetOSWindowMetrics+						wsH <- liftIO (opencontrols wMetrics ls newItemHs wsH)+						appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+						return ())))+++---	getWindowStateHandleIds returns all Ids of the controls in this window.+-- 	This function is used by open(Compound)Controls.+getWindowStateHandleIds :: WindowStateHandle ps -> [Id]+getWindowStateHandleIds (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) =+	getWElementControlIds (whItems wH)+getWindowStateHandleIds _ = stdControlFatalError "getWindowStateHandleIds" "unexpected window placeholder argument"++-- | openCompoundControls adds controls to the indicated CompoundControl+openCompoundControls :: Controls cdef => Id -> ls -> cdef ls ps -> GUI ps ()+openCompoundControls cId ls newControls = do+	maybeId <- getParentWindowId cId+	(case maybeId of+		Nothing  -> throwGUI ErrorUnknownObject+		Just wId -> do+			(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+			unless found (throwGUI ErrorUnknownObject)+			(let+				windows = windowSystemStateGetWindowHandles wDevice+				(found,wsH,windows1) = getWindowHandlesWindow (toWID wId) windows+			 in+				if not found then throwGUI ErrorUnknownObject+				else do+					cs <- controlToHandles newControls+					let newItemHs = map controlStateToWElementHandle cs+					let currentIds = getWindowStateHandleIds wsH+					(if not (disjointControlIds currentIds newItemHs) then throwGUI ErrorIdsInUse+					 else do+						it <- ioStGetIdTable+						ioId <- accIOEnv ioStGetIOId+						(case controlIdsAreConsistent ioId wId newItemHs it of+							Nothing -> throwGUI ErrorIdsInUse+							Just it -> do+								ioStSetIdTable it+								osdInfo <- accIOEnv ioStGetOSDInfo+								wMetrics <- accIOEnv ioStGetOSWindowMetrics+								(ok,wsH) <- liftIO (opencompoundcontrols osdInfo wMetrics cId ls newItemHs wsH)+								appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+								(if ok then return () else throwGUI ErrorUnknownObject)))))+++-- | The openPopUpControlItems function adds new items to the PopUpControl.+openPopUpControlItems :: Id -> Index -> [PopUpControlItem ps ps] -> GUI ps ()+openPopUpControlItems popUpId index [] = return ()+openPopUpControlItems popUpId index items = do+	maybeId	<- getParentWindowId popUpId+	(case maybeId of+		Nothing  -> return ()		+		Just wId -> do+			(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+			(if not found then return ()+			 else+				let+					wHs	= windowSystemStateGetWindowHandles wDevice+					(found,wsH,wHs1) = getWindowHandlesWindow (toWID wId) wHs+				in+					if not found+					then return ()+					else do		+							wsH <- liftIO (openpopupcontrolitems popUpId index items wsH)+							appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH wHs1)))))+	where+		openpopupcontrolitems :: Id -> Index -> [PopUpControlItem ps ps] -> WindowStateHandle ps -> IO (WindowStateHandle ps)+		openpopupcontrolitems popUpId index items (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) = do+			wH <- openpopupitems popUpId index items (wPtr wids) wH+			return (WindowStateHandle wids (Just wlsH{wlsHandle=wH}))+		openpopupcontrolitems _ _ _ _ =+			stdControlFatalError "openPopUpControlItems" "unexpected window placeholder argument"++-- | The openListBoxControlItems function adds new items to the ListBoxControl.+openListBoxControlItems :: Id -> Index -> [ListBoxControlItem ps ps] -> GUI ps ()+openListBoxControlItems lboxId index [] = return ()+openListBoxControlItems lboxId index items = do+	maybeId	<- getParentWindowId lboxId+	(case maybeId of+		Nothing  -> return ()		+		Just wId -> do+			(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+			(if not found then return ()+			 else+				let+					wHs	= windowSystemStateGetWindowHandles wDevice+					(found,wsH,wHs1) = getWindowHandlesWindow (toWID wId) wHs+				in+					if not found+					then return ()+					else do		+							wsH <- liftIO (openlistboxcontrolitems lboxId index items wsH)+							appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH wHs1)))))+	where+		openlistboxcontrolitems :: Id -> Index -> [ListBoxControlItem ps ps] -> WindowStateHandle ps -> IO (WindowStateHandle ps)+		openlistboxcontrolitems lboxId index items (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) = do+			wH <- openlistboxitems lboxId index items (wPtr wids) wH+			return (WindowStateHandle wids (Just wlsH{wlsHandle=wH}))+		openlistboxcontrolitems _ _ _ _ =+			stdControlFatalError "openListBoxControlItems" "unexpected window placeholder argument"++-- | The closeControls function closes the specified controls in the indicated window.+closeControls :: Id -> [Id] -> Bool -> GUI ps ()+closeControls wId ids relayout = do+	(found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else let+		windows = windowSystemStateGetWindowHandles wDevice+		(found,wsH,windows1) = getWindowHandlesWindow (toWID wId) windows+	      in+	     	if not found then return ()+		else do+			wMetrics <- accIOEnv ioStGetOSWindowMetrics+			(freeIds,disposeFun,wsH) <- liftIO (closecontrols wMetrics ids relayout wsH)+			it <- ioStGetIdTable			+			ioStSetIdTable (foldr Map.delete it (freeIds))+			f <- accIOEnv ioStGetInitIO+			appIOEnv (ioStSetInitIO (\ps -> f ps >>= \ps -> liftIO disposeFun >> return ps))+			appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1))))+++-- The closeAllControls function closes all controls in the indicated window.+closeAllControls :: Id -> GUI ps ()+closeAllControls wId = do+	(found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else+		let+			wHs	= windowSystemStateGetWindowHandles wDevice+			(found,wsH,wHs1) = getWindowHandlesWindow (toWID wId) wHs+		in+			if not found then return ()+			else do+				(freeIds,disposeFun,wsH) <- liftIO (closeallcontrols wsH)				+				it <- ioStGetIdTable+				ioStSetIdTable (foldr Map.delete it freeIds)+				f <- accIOEnv ioStGetInitIO+				appIOEnv (ioStSetInitIO (\ps -> f ps >>= \ps -> liftIO disposeFun >> return ps))+				appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH wHs1))))+++-- | The closePopUpControlItems function deletes a string with specified index from the list box of the popup control.+closePopUpControlItems :: Id -> [Index] -> GUI ps ()+closePopUpControlItems popUpId [] = return ()+closePopUpControlItems popUpId indexs = do+	maybeId <- getParentWindowId popUpId+	(case maybeId of+		Nothing  -> return ()+		Just wId -> do+			(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+			(if not found then return ()+			 else+				let+					wHs	= windowSystemStateGetWindowHandles wDevice+					(found,wsH,wHs1) = getWindowHandlesWindow (toWID wId) wHs+				in+					if not found+					then return ()+					else do+						wsH <- liftIO (closepopupcontrolitems popUpId indexs wsH)+						appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH wHs1)))))+	where+		closepopupcontrolitems :: Id -> [Index] -> WindowStateHandle ps -> IO (WindowStateHandle ps)+		closepopupcontrolitems popUpId indexs wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) = do+			wH <- closepopupitems popUpId indexs (wPtr wids) wH+			return (WindowStateHandle wids (Just wlsH{wlsHandle=wH}))+		closepopupcontrolitems _ _ _ = do+			stdControlFatalError "closePopUpControlItems" "unexpected window placeholder argument"+			+-- | The closeListBoxControlItems function deletes a string with specified index from the control.+closeListBoxControlItems :: Id -> [Index] -> GUI ps ()+closeListBoxControlItems lboxId [] = return ()+closeListBoxControlItems lboxId indexs = do+	maybeId <- getParentWindowId lboxId+	(case maybeId of+		Nothing  -> return ()+		Just wId -> do+			(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+			(if not found then return ()+			 else+				let+					wHs	= windowSystemStateGetWindowHandles wDevice+					(found,wsH,wHs1) = getWindowHandlesWindow (toWID wId) wHs+				in+					if not found+					then return ()+					else do+						wsH <- liftIO (closelistboxcontrolitems lboxId indexs wsH)+						appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH wHs1)))))+	where+		closelistboxcontrolitems :: Id -> [Index] -> WindowStateHandle ps -> IO (WindowStateHandle ps)+		closelistboxcontrolitems lboxId indexs wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) = do+			wH <- closelistboxitems lboxId indexs (wPtr wids) wH+			return (WindowStateHandle wids (Just wlsH{wlsHandle=wH}))+		closelistboxcontrolitems _ _ _ = do+			stdControlFatalError "closeListBoxControlItems" "unexpected window placeholder argument"+++-- | The setControlPos function changes the position of the specified control. +-- It is relative to the upper-left corner of the parent window\'s client area.+setControlPos :: Id -> [(Id,ItemPos)] -> GUI ps Bool+setControlPos wId newPoss = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return False+	 else+		let+			wHs		 = windowSystemStateGetWindowHandles wDevice+			(found,wsH,wHs1) = getWindowHandlesWindow (toWID wId) wHs+		in if not found then return False+		   else do+				wMetrics <- accIOEnv ioStGetOSWindowMetrics+				(ok,wsH) <- liftIO (setcontrolpositions wMetrics newPoss wsH)+				let wHs2 = setWindowHandlesWindow wsH wHs1+				appIOEnv (ioStSetDevice (WindowSystemState wHs2))+				return ok)+++--	Show/Hide controls.++-- | displays a given set of controls+showControls :: [Id] -> GUI ps ()+showControls = setControlsShowState True++-- | displays a control in its most recent size and position.+showControl :: Id -> GUI ps ()+showControl id = showControls [id]++-- | hides a given set of controls+hideControls :: [Id] -> GUI ps ()+hideControls = setControlsShowState False++-- | hides the control and activates another control+hideControl :: Id -> GUI ps ()+hideControl id = hideControls [id]++setControlsShowState :: Bool -> [Id] -> GUI ps ()+setControlsShowState show ids = do+	cIds_wIds <- getParentWindowIds id ids+	sequence_ [mapWindow wId (setControlsShowState cIds) () | (cIds,wId)<-gather cIds_wIds]+	where+		setControlsShowState :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> x -> IO (WindowHandle ls ps, x)+		setControlsShowState ids wMetrics wids wH s = do+			wH <- setcontrolsshowstate ids show wMetrics wids wH+			wH <- forceValidWindowClipState wMetrics True (wPtr wids) wH			+			return (wH, s)++--	Enabling/Disabling of controls.++-- | enables set of controls+enableControls :: [Id] -> GUI ps ()+enableControls ids = do+	cIds_wIds <- getParentWindowIds id ids+	sequence_ [mapWindow wId (enableControls cIds) () | (cIds,wId)<-gather cIds_wIds]+	where+		enableControls :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> x -> IO (WindowHandle ls ps, x)+		enableControls ids wMetrics wids wH s = do+			wH <- enablecontrols ids False wMetrics (wPtr wids) wH+			return (wH, s)++-- | The enableControl function enables mouse and keyboard input to the specified control.+-- When input is enabled, the control receives all input.+enableControl :: Id -> GUI ps ()+enableControl id = enableControls [id]++-- | disables set of controls+disableControls :: [Id] -> GUI ps ()+disableControls ids = do+	cIds_wIds <- getParentWindowIds id ids+	sequence_ [mapWindow wId (disableControls cIds) () | (cIds,wId)<-gather cIds_wIds]+	where+		disableControls :: [Id] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> x -> IO (WindowHandle ls ps, x)+		disableControls ids wMetrics wids wH s = do+			wH <- disablecontrols ids False wMetrics (wPtr wids) wH+			return (wH, s)++-- | The disableControl function disables mouse and keyboard input to the specified control.+-- When input is disabled, the control does not receive input such as mouse clicks and key presses.+disableControl :: Id -> GUI ps ()+disableControl id = disableControls [id]+++--	Marking/Unmarking of selection controls.++-- | The items with specified indices becomes set on.+markControlItems :: Id -> [Index] -> GUI ps ()+markControlItems cId indexs = setControlsMarkState Mark cId indexs++-- | The items with specified indices becomes set off.+unmarkControlItems :: Id -> [Index] -> GUI ps ()+unmarkControlItems cId indexs = setControlsMarkState NoMark cId indexs++-- | Sets or resets the mark state of a selection control.+setControlsMarkState :: MarkState -> Id -> [Index] -> GUI ps ()+setControlsMarkState mark cId [] = return ()+setControlsMarkState mark cId indexs = do	+	maybeId <- getParentWindowId cId+	(case maybeId of+		Nothing  -> return ()+		Just wId -> mapWindow wId (setControlsMarkState mark cId indexs) ())+	where+		setControlsMarkState :: MarkState -> Id -> [Index] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> x -> IO (WindowHandle ls ps, x)+		setControlsMarkState mark id indexs wMetrics wids wH s = do+			wH <- setcontrolsmarkstate id mark indexs wMetrics (wPtr wids) wH+			return (wH,s)+++-- | The selectControlItem function selects a string in the selection control.+-- Any previous selection in the control is removed.+selectControlItem :: Id -> Index -> GUI ps ()+selectControlItem cId index = do+	maybeId <- getParentWindowId cId+	(case maybeId of+		Nothing  -> return ()+		Just wId -> mapWindow wId (selectControlItem cId index) ())+	where+		selectControlItem :: Id -> Index -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> x -> IO (WindowHandle ls ps, x)+		selectControlItem id index wMetrics wids wH s = do+			wH <- selectcontrolitem id index wMetrics (wPtr wids) wH+			return (wH,s)++-- | moves the 'ViewFrame' of the CompoundControl in the direction of the given vector.+moveControlViewFrame :: Id -> Vector2 -> GUI ps ()+moveControlViewFrame cId v = do+	maybeId <- getParentWindowId cId+	(case maybeId of+		Nothing  -> return ()+		Just wId -> mapWindow wId (moveControlViewFrame cId v) ())+	where+		moveControlViewFrame :: Id -> Vector2 -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> x -> IO (WindowHandle ls ps, x)+		moveControlViewFrame id v wMetrics wids wH s = do+			wH <- movecontrolviewframe id v wMetrics wids wH		+			return (wH, s)++--	Set a new view domain of a CompoundControl.++setControlViewDomain :: Id -> ViewDomain -> GUI ps ()+setControlViewDomain cId newDomain = do+	maybeId <- getParentWindowId cId+	(case maybeId of+		Nothing  -> return ()+		Just wId -> mapWindow wId (setControlViewDomain cId newDomain) ())+	where+		setControlViewDomain :: Id -> ViewDomain -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> x -> IO (WindowHandle ls ps, x)+		setControlViewDomain id newDomain wMetrics wids wH s = do+			wH <- setcontrolviewdomain id newDomain wMetrics wids wH+			return (wH, s)++-- | Sets a new scroll function of the CompoundControl.+setControlScrollFunction :: Id -> Direction -> ScrollFunction -> GUI ps ()+setControlScrollFunction cId direction scrollFun = do+	maybeId <- getParentWindowId cId+	(case maybeId of+		Nothing  -> return ()+		Just wId -> mapWindow wId (setControlScrollFunction cId direction scrollFun) ())+	where+		setControlScrollFunction :: Id -> Direction -> ScrollFunction -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> x -> IO (WindowHandle ls ps, x)+		setControlScrollFunction id direction scrollFun wMetrics wids wH s = do+			wH <- setcontrolscrollfun id direction scrollFun wH+			return (wH, s)+++--	Change the text of (Text/Edit/Button)Control.++-- | Works like 'setControlText' but for set of controls+setControlTexts :: [(Id,String)] -> GUI ps ()+setControlTexts cid_texts = do+	cid_texts_wIds <- getParentWindowIds fst cid_texts+	sequence_ [mapWindow wId (setControlTexts' cid_texts) () | (cid_texts,wId)<-gather cid_texts_wIds]+	where+		setControlTexts' :: [(Id,String)] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> s -> IO (WindowHandle ls ps, s)+		setControlTexts' texts wMetrics wids wH s = do+			wH1 <- setcontroltexts texts wMetrics (wPtr wids) wH+			return (wH1, s)++-- | If the specified Id is an Id of Text, Edit of Button control, the text (caption) of the control is changed.+setControlText :: Id -> String -> GUI ps ()+setControlText id text = setControlTexts [(id,text)]+++-- | Set the cursor position of an EditControl.+setEditControlCursor :: Id -> Int -> GUI ps ()+setEditControlCursor cId pos = do+	maybeParent <- getParentWindowId cId+	(case maybeParent of+		Nothing  -> return ()+		Just wId -> mapWindow wId (setEditControlCursor cId pos) ())+	where+		setEditControlCursor :: Id -> Int -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> s -> IO (WindowHandle ls ps, s)+		setEditControlCursor id pos wMetrics wids wH s = do+			wH <- seteditcontrolcursor id pos wMetrics (wPtr wids) wH+			return (wH, s)+++-- | change the 'Look' of the corresponding set of controls but redraw only if the first boolean parameter is 'True'+setControlLooks :: [(Id,Bool,(Bool,Look))] -> GUI ps ()+setControlLooks cid_looks = do		+	cid_looks_wIds <- getParentWindowIds (\(x,y,z) -> x) cid_looks+	sequence_ [mapWindow wId (setControlLooks cid_looks) () |	(cid_looks,wId)<-gather cid_looks_wIds]+	where+		setControlLooks :: [(Id,Bool,(Bool,Look))] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> s -> IO (WindowHandle ls ps, s)+		setControlLooks looks wMetrics wids wH s = do+			wH <- setcontrolslook looks wMetrics (wPtr wids) wH+			return (wH, s)++-- | change the 'Look' of the corresponding control but redraw only if the first boolean parameter is 'True'+setControlLook :: Id -> Bool -> (Bool,Look) -> GUI ps ()+setControlLook id redraw newlook = setControlLooks [(id,redraw,newlook)]++-- | changes the 'SliderState' and redraws the settings of the SliderControls.+setSliderStates :: [(Id,IdFun SliderState)] -> GUI ps ()+setSliderStates cid_fs = do		+	cid_fs_wIds <- getParentWindowIds fst cid_fs+	sequence_ [mapWindow wId (setSliderStates cid_fs) () | (cid_fs,wId)<-gather cid_fs_wIds]+	where+		setSliderStates :: [(Id,IdFun SliderState)] -> OSWindowMetrics -> WIDS -> WindowHandle ls ps -> s -> IO (WindowHandle ls ps, s)+		setSliderStates id_fs wMetrics wids wH s = do+			wH <- setsliderstates id_fs wMetrics (wPtr wids) wH+			return (wH, s)++-- | changes the 'SliderState' and redraws the settings of the SliderControls.+setSliderState :: Id -> IdFun SliderState -> GUI ps ()+setSliderState id fun = setSliderStates [(id,fun)]+++-- | changes the thumb value of the 'SliderState' for each SliderControl from the given set.+setSliderThumbs :: [(Id,Int)] -> GUI ps ()+setSliderThumbs cid_thumbs =+	setSliderStates (map (\(cid,thumb)->(cid,\state->state{sliderThumb=thumb})) cid_thumbs)++-- | changes the thumb value of the 'SliderState' of SliderControl.+setSliderThumb :: Id -> Int -> GUI ps ()+setSliderThumb id thumb = setSliderThumbs [(id,thumb)]+++--	Draw in a {Custom(Button)|Compound}Control.++-- | direct draw in control+drawInControl :: Id -> Draw x -> GUI ps (Maybe x)+drawInControl cId drawfun = do+	maybeParent <- getParentWindowId cId+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(case maybeParent of		+		Just wId | found ->+			let+				windows 	= windowSystemStateGetWindowHandles wDevice+				(_,wsH,windows1)= getWindowHandlesWindow (toWID wId) windows+				wids 		= getWindowStateHandleWIDS wsH+			in do+				wMetrics <- accIOEnv ioStGetOSWindowMetrics+				(maybe_result,wsH) <- liftIO (drawInControl cId drawfun wMetrics (wPtr wids) wsH)+				let windows2 = setWindowHandlesWindow wsH windows1+				appIOEnv (ioStSetDevice (WindowSystemState windows2))+				return maybe_result+		_  -> return Nothing)+	where+		drawInControl :: Id -> Draw x -> OSWindowMetrics -> OSWindowPtr -> WindowStateHandle ps -> IO (Maybe x,WindowStateHandle ps)+		drawInControl controlId drawfun wMetrics wPtr (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) = do+			(maybe_result,wH) <- drawincontrol controlId drawfun wMetrics wPtr wH+			return (maybe_result,WindowStateHandle wids (Just wlsH{wlsHandle=wH}))+		drawInControl _ _ _ _ _ = stdControlFatalError "drawInControl" "unexpected window placeholder argument"++--	Update a selection of a (Compound/Custom(Button))Control:++-- | The updateControl function updates the view frame of the specified control.+updateControl :: Id -> Maybe ViewFrame -> GUI ps ()+updateControl cId maybeViewFrame = do+	maybeParent <- getParentWindowId cId+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(case maybeParent of+		Just wId | found ->+			let+				windows 	= windowSystemStateGetWindowHandles wDevice+				(_,wsH,windows1)= getWindowHandlesWindow (toWID wId) windows+				wKind 		= getWindowStateHandleWindowKind wsH+			in+				if wKind /= IsWindow+				then appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+				else do+					wMetrics <- accIOEnv ioStGetOSWindowMetrics+					wsH <- liftIO (updateControlBackground wMetrics wKind cId maybeViewFrame wsH)+					appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+		Nothing -> return ())+	where+		updateControlBackground :: OSWindowMetrics -> WindowKind -> Id -> Maybe ViewFrame -> WindowStateHandle ps -> IO (WindowStateHandle ps)+		updateControlBackground wMetrics wKind cId maybeViewFrame wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH@(WindowHandle {whSize=whSize,whItems=itemHs})}))) = do+			let (Just updInfo) = getWElementHandlesUpdateInfo wMetrics cId contentRect itemHs+			wH <- updateWindow wMetrics updInfo wH+			return (WindowStateHandle wids (Just wlsH{wlsHandle=wH}))+			where+				info = whWindowInfo wH+				(domainRect,hasScrolls)	= case wKind of+					IsWindow -> (windowDomain info,(isJust (windowHScroll info),isJust (windowVScroll info)))+					_        -> (sizeToRect whSize,(False,False))+				visScrolls	= osScrollbarsAreVisible wMetrics domainRect (toTuple whSize) hasScrolls+				contentRect	= getWindowContentRect wMetrics visScrolls (sizeToRect whSize)++				getWElementHandlesUpdateInfo :: OSWindowMetrics -> Id -> Rect -> [WElementHandle ls ps] -> Maybe UpdateInfo+				getWElementHandlesUpdateInfo wMetrics cId clipRect [] = Nothing+				getWElementHandlesUpdateInfo wMetrics cId clipRect (itemH:itemHs) =+					let res = getWElementHandleUpdateInfo wMetrics cId clipRect itemH+					in  if isJust res then res+					    else getWElementHandlesUpdateInfo wMetrics cId clipRect itemHs+					where+						getWElementHandleUpdateInfo :: OSWindowMetrics -> Id -> Rect -> WElementHandle ls ps -> Maybe UpdateInfo+						getWElementHandleUpdateInfo wMetrics cId clipRect itemH@(WItemHandle {wItemKind=itemKind,wItemPos=itemPos,wItemSize=itemSize})+							| wItemId itemH /= Just cId =+								if not (isRecursiveControl itemKind) then Nothing+								else getWElementHandlesUpdateInfo wMetrics cId visRect (wItems itemH)+							| itemKind `elem` [IsCompoundControl,IsCustomControl,IsCustomButtonControl] = Just updInfo+							| otherwise = Nothing+							where+								itemRect	= posSizeToRect itemPos itemSize+								itemInfo	= wItemInfo itemH+								compoundInfo	= getWItemCompoundInfo itemInfo+								origin		= if itemKind==IsCompoundControl+										  then compoundOrigin compoundInfo+										  else zero+								domain		= compoundDomain compoundInfo+								hasScrolls	= (isJust (compoundHScroll compoundInfo),isJust (compoundVScroll compoundInfo))+								visScrolls	= osScrollbarsAreVisible wMetrics domain (toTuple itemSize) hasScrolls+								contentRect	= if itemKind==IsCompoundControl+										  then getCompoundContentRect wMetrics visScrolls itemRect+										  else itemRect+								visRect		= intersectRects contentRect clipRect+								updArea		= case maybeViewFrame of+									Nothing	  -> visRect+									Just rect -> intersectRects (rectangleToRect (addVector (toVector itemPos)+																(subVector (toVector origin) rect)+														     )+												    ) visRect+								updInfo	= UpdateInfo+									{ updWIDS 	= wids+									, updWindowArea	= zero+									, updControls	= [ControlUpdateInfo+												{ cuItemNr	= wItemNr itemH+												, cuItemPtr	= wItemPtr itemH+												, cuArea		= updArea+												}]+									, updGContext	= Nothing+									}+						getWElementHandleUpdateInfo wMetrics cId clipRect (WListLSHandle itemHs) =+							getWElementHandlesUpdateInfo wMetrics cId clipRect itemHs++						getWElementHandleUpdateInfo wMetrics cId clipRect (WExtendLSHandle exLS itemHs) =+							getWElementHandlesUpdateInfo wMetrics cId clipRect itemHs++						getWElementHandleUpdateInfo wMetrics cId clipRect (WChangeLSHandle chLS itemHs) =+							getWElementHandlesUpdateInfo wMetrics cId clipRect itemHs++		updateControlBackground _ _ _ _ _ = stdControlFatalError "updateControl" "unexpected window placeholder argument"+++getControlLayouts :: [Id] -> GUI ps [(Bool,(Maybe ItemPos,Vector2))]+getControlLayouts ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getcontrolslayouts ids)) [(id,False,(Nothing,zero)) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)++getControlLayout :: Id -> GUI ps (Bool,(Maybe ItemPos,Vector2))+getControlLayout id = fmap head (getControlLayouts [id])++-- | returns a list of control dimensions from list of controls ids+getControlViewSizes :: [Id] -> GUI ps [(Bool,Size)]+getControlViewSizes ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getcontrolsviewsizes ids)) [(id,False,zero) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)++-- | The getControlViewSize function retrieves the dimensions of a control\'s client area+getControlViewSize :: Id -> GUI ps (Bool,Size)+getControlViewSize id = fmap head (getControlViewSizes [id])++-- | returns a list of control outer dimensions from list of controls ids+getControlOuterSizes :: [Id] -> GUI ps [(Bool,Size)]+getControlOuterSizes ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getcontrolsoutersizes ids)) [(id,False,zero) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)	++-- | The getControlOuterSize function retrieves the dimensions of the bounding rectangle of the specified control. +getControlOuterSize :: Id -> GUI ps (Bool,Size)+getControlOuterSize id = fmap head (getControlOuterSizes [id])++-- | returns a list of select state from list of controls ids+getControlSelectStates :: [Id] -> GUI ps [(Bool,SelectState)]+getControlSelectStates ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getcontrolsselects ids)) [(id,False,Able) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)++-- | returns current select state of given control+getControlSelectState :: Id -> GUI ps (Bool,SelectState)+getControlSelectState id = fmap head (getControlSelectStates [id])++-- | returns a list of currents show states from list of control ids+getControlShowStates :: [Id] -> GUI ps [(Bool,Bool)]+getControlShowStates ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getcontrolsshowstates ids)) [(id,False,False) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)++-- | returns current show state of the control+getControlShowState :: Id -> GUI ps (Bool,Bool)+getControlShowState id = fmap head (getControlShowStates [id])++--	Access operations on Windows:++-- | Works like getControlText but for set of controls.+getControlTexts :: [Id] -> GUI ps [(Bool,Maybe String)]+getControlTexts ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getcontrolstexts ids)) [(id,False,Nothing) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)++-- | If the specified Id is an Id of Text, Edit or Button control,+-- the text (caption) of the control is returned. +getControlText :: Id -> GUI ps (Bool,Maybe String)+getControlText id = fmap head (getControlTexts [id])++-- | The getControlNrLines function returns the number of lines for each EditControl from specified list of ids.+getControlNrLines :: [Id] -> GUI ps [(Bool,Maybe NrLines)]+getControlNrLines ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getcontrolsnrlines ids)) [(id,False,Nothing) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)++-- | The getControlNrLine function returns the number of lines that can be seen+-- (on the screen at the moment) for a given control.+getControlNrLine :: Id -> GUI ps (Bool,Maybe NrLines)+getControlNrLine id = fmap head (getControlNrLines [id])++-- | returns current controls 'Look'+getControlLooks :: [Id] -> GUI ps [(Bool,Maybe (Bool,Look))]+getControlLooks ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getcontrolslooks ids)) [(id,False,Nothing) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)++-- | returns current controls 'Look'+getControlLook :: Id -> GUI ps (Bool,Maybe (Bool,Look))+getControlLook id = fmap head (getControlLooks [id])++-- | returns the minimal valid size when resizing+getControlMinimumSizes :: [Id] -> GUI ps [(Bool,Maybe Size)]+getControlMinimumSizes ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getcontrolsminsizes ids)) [(id,False,Nothing) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)++-- | returns the minimal valid size when resizing+getControlMinimumSize :: Id -> GUI ps (Bool,Maybe Size)+getControlMinimumSize id = fmap head (getControlMinimumSizes [id])++-- | Works like 'getControlResizes' but for set of controls+getControlResizes :: [Id] -> GUI ps [(Bool,Maybe ControlResizeFunction)]+getControlResizes ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getcontrolsresizes ids)) [(id,False,Nothing) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)++-- | returns the control resizing function. When the parent window of a given control is resized,+-- then the control can be resized if it has a resize function.+getControlResize :: Id -> GUI ps (Bool,Maybe ControlResizeFunction)+getControlResize id = fmap head (getControlResizes [id])++-- | Call this member function to determine which item is selected, for each selection control in the list.+getControlSelections :: [Id] -> GUI ps [(Bool,Maybe Index)]+getControlSelections ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getcontrolsselections ids)) [(id,False,Nothing) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)+	+-- | Call this member function to determine which item in the selection control is selected.+getControlSelection :: Id -> GUI ps (Bool,Maybe Index)+getControlSelection id = fmap head (getControlSelections [id])++-- | The getControlItems function returns the list of control items.+getControlItems :: [Id] -> GUI ps [(Bool,Maybe [String])]+getControlItems ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getcontrolitems ids)) [(id,False,Nothing) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)+	+-- | returns the list of items for a given control+getControlItem :: Id -> GUI ps (Bool,Maybe [String])+getControlItem id = fmap head (getControlItems [id])++-- | Works like 'getControlMark' but for set of selection controls+getControlMarks :: [Id] -> GUI ps [(Bool,Maybe [Index])]+getControlMarks ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getcontrolsmarks ids)) [(id,False,Nothing) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)++-- | returns a the list of indices which indicates currently selected items+getControlMark :: Id -> GUI ps (Bool,Maybe [Index])+getControlMark id = fmap head (getControlMarks [id])++-- | gets the sliders directions.+getSliderDirections :: [Id] -> GUI ps [(Bool,Maybe Direction)]+getSliderDirections ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getslidersdirections ids)) [(id,False,Nothing) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)++-- | gets the slider direction i. e. 'Horizontal' or 'Vertical'.+getSliderDirection :: Id -> GUI ps (Bool,Maybe Direction)+getSliderDirection id = fmap head (getSliderDirections [id])++-- | gets a current 'SliderState's+getSliderStates :: [Id] -> GUI ps [(Bool,Maybe SliderState)]+getSliderStates ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getslidersstates ids)) [(id,False,Nothing) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)++-- | gets a current 'SliderState'+getSliderState :: Id -> GUI ps (Bool,Maybe SliderState)+getSliderState id = fmap head (getSliderStates [id])++-- | returns a list of 'ViewFrame's from list of control ids+getControlViewFrames :: [Id] -> GUI ps [(Bool,Maybe ViewFrame)]+getControlViewFrames ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getcontrolsframes ids)) [(id,False,Nothing) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)++-- | If the specified Id is an Id of Compound control, the current 'ViewFrame' of the control is returned.+getControlViewFrame :: Id -> GUI ps (Bool,Maybe ViewFrame)+getControlViewFrame id = fmap head (getControlViewFrames [id])++getControlViewDomains :: [Id] -> GUI ps [(Bool,Maybe ViewDomain)]+getControlViewDomains ids = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getcontrolsdomains ids)) [(id,False,Nothing) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)++getControlViewDomain :: Id -> GUI ps (Bool,Maybe ViewDomain)+getControlViewDomain id = fmap head (getControlViewDomains [id])++-- | Works like 'setControlText' but for set of controls+getControlScrollFunctions :: [Id] -> GUI ps [(Bool,Maybe ((Direction,Maybe ScrollFunction),(Direction,Maybe ScrollFunction)))]+getControlScrollFunctions ids  = do+	cid_pids <- getParentWindowIds id ids+	tbl <- foldrM (\(ids, wId) -> mapWindow wId (getscrollfunctions ids)) [(id,False,Nothing) | (id,pid)<-cid_pids] (gather cid_pids)+	return (map snd3thd3 tbl)++-- | getControlScrollFunction(s) yields the 'ScrollFunction's of the indicated CompoundControl.+-- If the given control is not a CompoundControl, then Nothing is returned.+getControlScrollFunction :: Id -> GUI ps (Bool,Maybe ((Direction,Maybe ScrollFunction),(Direction,Maybe ScrollFunction)))+getControlScrollFunction id = fmap head (getControlScrollFunctions [id])
+ Graphics/UI/ObjectIO/StdControlAttribute.hs view
@@ -0,0 +1,288 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdControlAttribute+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdControlAttribute specifies which ControlAttributes are valid for each+-- of the standard controls.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdControlAttribute+		( module Graphics.UI.ObjectIO.StdControlAttribute+		, module Graphics.UI.ObjectIO.StdControlDef+		) where++++import Graphics.UI.ObjectIO.StdControlDef+import Graphics.UI.ObjectIO.StdPicture(PenAttribute(..), Look)++++isValidButtonControlAttribute :: ControlAttribute ls ps -> Bool+isValidButtonControlAttribute (ControlFunction     _) = True+isValidButtonControlAttribute (ControlHide	    ) = True+isValidButtonControlAttribute (ControlId           _) = True+isValidButtonControlAttribute (ControlModsFunction _) = True+isValidButtonControlAttribute (ControlPos          _) = True+isValidButtonControlAttribute (ControlSelectState  _) = True+isValidButtonControlAttribute (ControlWidth        _) = True+isValidButtonControlAttribute _                       = False++isValidCheckControlAttribute :: ControlAttribute ls ps -> Bool+isValidCheckControlAttribute (ControlHide	  ) = True+isValidCheckControlAttribute (ControlId          _) = True+isValidCheckControlAttribute (ControlPos         _) = True+isValidCheckControlAttribute (ControlSelectState _) = True+isValidCheckControlAttribute (ControlTip         _) = True+isValidCheckControlAttribute _			    = False++isValidCompoundControlAttribute :: (ControlAttribute ls ps) -> Bool+isValidCompoundControlAttribute (ControlFunction     _)	= False+isValidCompoundControlAttribute (ControlModsFunction _)	= False+isValidCompoundControlAttribute _			= True++isValidEditControlAttribute :: ControlAttribute ls ps -> Bool+isValidEditControlAttribute (ControlActivate    _)  = True+isValidEditControlAttribute (ControlDeactivate  _)  = True+isValidEditControlAttribute (ControlHide	 )  = True+isValidEditControlAttribute (ControlId          _)  = True+isValidEditControlAttribute (ControlKeyboard _ _ _) = True+isValidEditControlAttribute (ControlPos         _)  = True+isValidEditControlAttribute (ControlResize      _)  = True+isValidEditControlAttribute (ControlSelectState _)  = True+isValidEditControlAttribute (ControlTip         _)  = True+isValidEditControlAttribute _                       = False++isValidLayoutControlAttribute :: ControlAttribute ls ps -> Bool+isValidLayoutControlAttribute (ControlHide	   ) = True+isValidLayoutControlAttribute (ControlHMargin   _ _) = True+isValidLayoutControlAttribute (ControlId          _) = True+isValidLayoutControlAttribute (ControlItemSpace _ _) = True+isValidLayoutControlAttribute (ControlMinimumSize _) = True+isValidLayoutControlAttribute (ControlOuterSize   _) = True+isValidLayoutControlAttribute (ControlPos         _) = True+isValidLayoutControlAttribute (ControlResize      _) = True+isValidLayoutControlAttribute (ControlSelectState _) = True+isValidLayoutControlAttribute (ControlViewSize    _) = True+isValidLayoutControlAttribute (ControlVMargin   _ _) = True+isValidLayoutControlAttribute _			     = False++isValidPopUpControlAttribute :: ControlAttribute ls ps -> Bool+isValidPopUpControlAttribute (ControlActivate    _) = True+isValidPopUpControlAttribute (ControlDeactivate  _) = True+isValidPopUpControlAttribute (ControlHide	  ) = True+isValidPopUpControlAttribute (ControlId          _) = True+isValidPopUpControlAttribute (ControlPos         _) = True+isValidPopUpControlAttribute (ControlSelectState _) = True+isValidPopUpControlAttribute (ControlTip         _) = True+isValidPopUpControlAttribute (ControlWidth	 _) = True+isValidPopUpControlAttribute _			    = False++isValidRadioControlAttribute :: ControlAttribute ls ps -> Bool+isValidRadioControlAttribute (ControlHide	  ) = True+isValidRadioControlAttribute (ControlId          _) = True+isValidRadioControlAttribute (ControlPos         _) = True+isValidRadioControlAttribute (ControlSelectState _) = True+isValidRadioControlAttribute (ControlTip         _) = True+isValidRadioControlAttribute _			    = False++isValidSliderControlAttribute :: ControlAttribute ls ps -> Bool+isValidSliderControlAttribute (ControlHide	   ) = True+isValidSliderControlAttribute (ControlId          _) = True+isValidSliderControlAttribute (ControlPos         _) = True+isValidSliderControlAttribute (ControlResize      _) = True+isValidSliderControlAttribute (ControlSelectState _) = True+isValidSliderControlAttribute (ControlTip         _) = True+isValidSliderControlAttribute _			     = False++isValidTextControlAttribute :: ControlAttribute ls ps -> Bool+isValidTextControlAttribute (ControlId    _) = True+isValidTextControlAttribute (ControlPos   _) = True+isValidTextControlAttribute (ControlWidth _) = True+isValidTextControlAttribute _                = False+++isControlActivate 	:: ControlAttribute ls ps -> Bool+isControlActivate 	(ControlActivate _) 	= True+isControlActivate 	_			= False++isControlDeactivate 	:: ControlAttribute ls ps -> Bool+isControlDeactivate 	(ControlDeactivate _) = True+isControlDeactivate 	_			  = False+++isControlFunction 	:: ControlAttribute ls ps -> Bool+isControlFunction 	(ControlFunction _)   = True+isControlFunction 	_                     = False++isControlHide 		:: ControlAttribute ls ps -> Bool+isControlHide 		ControlHide		= True+isControlHide 		_				= False++isControlHMargin 	:: ControlAttribute ls ps -> Bool+isControlHMargin 	(ControlHMargin _ _)	= True+isControlHMargin 	_			= False++isControlHScroll 	:: ControlAttribute ls ps -> Bool+isControlHScroll 	(ControlHScroll _)	= True+isControlHScroll 	_			= False++isControlId 		:: ControlAttribute ls ps -> Bool+isControlId 		(ControlId _)         	= True+isControlId 		_                     	= False++isControlItemSpace 	:: ControlAttribute ls ps -> Bool+isControlItemSpace 	(ControlItemSpace _ _) 	= True+isControlItemSpace 	_			= False++isControlKeyboard 	:: ControlAttribute ls ps -> Bool+isControlKeyboard 	(ControlKeyboard _ _ _) = True+isControlKeyboard 	_                       = False++isControlLook		:: ControlAttribute ls ps -> Bool+isControlLook		(ControlLook _ _)	= True+isControlLook		_			= False++isControlMinimumSize	:: ControlAttribute ls ps -> Bool+isControlMinimumSize	(ControlMinimumSize _)	= True+isControlMinimumSize	_			= False++isControlModsFunction 	:: ControlAttribute ls ps -> Bool+isControlModsFunction 	(ControlModsFunction _) = True+isControlModsFunction 	_                       = False++isControlMouse 		:: ControlAttribute ls ps -> Bool+isControlMouse 		(ControlMouse _ _ _)	= True+isControlMouse 		_			= False++isControlOrigin 	:: ControlAttribute ls ps -> Bool+isControlOrigin 	(ControlOrigin _)	= True+isControlOrigin		_			= False++isControlOuterSize 	:: ControlAttribute ls ps -> Bool+isControlOuterSize 	(ControlOuterSize _)	= True+isControlOuterSize 	_			= False++isControlPen 		:: ControlAttribute ls ps -> Bool+isControlPen 		(ControlPen _)		= True+isControlPen 		_			= False++isControlPos 		:: ControlAttribute ls ps -> Bool+isControlPos 		(ControlPos _)   	= True+isControlPos 		_                	= False++isControlResize		:: ControlAttribute ls ps -> Bool+isControlResize		(ControlResize _)	= True+isControlResize		_			= False++isControlSelectState	:: ControlAttribute ls ps -> Bool+isControlSelectState	(ControlSelectState _)	= True+isControlSelectState	_						= False++isControlTip		:: ControlAttribute ls ps -> Bool+isControlTip		(ControlTip _)		= True+isControlTip		_			= False++isControlViewDomain	:: ControlAttribute ls ps -> Bool+isControlViewDomain	(ControlViewDomain _)	= True+isControlViewDomain	_			= False++isControlViewSize	:: ControlAttribute ls ps -> Bool+isControlViewSize	(ControlViewSize _)	= True+isControlViewSize	_			= False++isControlVMargin	:: ControlAttribute ls ps -> Bool+isControlVMargin	(ControlVMargin _ _)	= True+isControlVMargin	_			= False++isControlVScroll	:: ControlAttribute ls ps -> Bool+isControlVScroll	(ControlVScroll _)	= True+isControlVScroll	_			= False++isControlWidth    	:: ControlAttribute ls ps -> Bool+isControlWidth    	(ControlWidth _)        = True+isControlWidth    	_                       = False++isControlDoubleBuffered :: ControlAttribute ls ps -> Bool+isControlDoubleBuffered ControlDoubleBuffered = True+isControlDoubleBuffered _                     = False++getControlActivateFun :: ControlAttribute ls ps -> GUIFun ls ps+getControlActivateFun (ControlActivate f) = f++getControlDeactivateFun :: ControlAttribute ls ps -> GUIFun ls ps+getControlDeactivateFun (ControlDeactivate f) = f++getControlFun :: ControlAttribute ls ps -> GUIFun ls ps+getControlFun (ControlFunction f) = f++getControlHMarginAtt :: ControlAttribute ls ps -> (Int,Int)+getControlHMarginAtt (ControlHMargin left right) = (left,right)++getControlHScrollFun :: ControlAttribute ls ps -> ScrollFunction+getControlHScrollFun (ControlHScroll f) = f++getControlIdAtt :: ControlAttribute ls ps -> Id+getControlIdAtt (ControlId id) = id++getControlItemSpaceAtt :: ControlAttribute ls ps -> (Int,Int)+getControlItemSpaceAtt (ControlItemSpace hspace vspace) = (hspace,vspace)++getControlKeyboardAtt :: ControlAttribute ls ps -> (KeyboardStateFilter,SelectState,KeyboardFunction ls ps)+getControlKeyboardAtt (ControlKeyboard filter s f) = (filter,s,f)++getControlLookAtt :: ControlAttribute ls ps -> (Bool,Look)+getControlLookAtt (ControlLook systemLook f) = (systemLook,f)++getControlMinimumSizeAtt :: ControlAttribute ls ps -> Size+getControlMinimumSizeAtt (ControlMinimumSize size) = size++getControlModsFun :: ControlAttribute ls ps -> ModifiersFunction ls ps+getControlModsFun (ControlModsFunction f) = f++getControlMouseAtt :: ControlAttribute ls ps -> (MouseStateFilter,SelectState,MouseFunction ls ps)+getControlMouseAtt (ControlMouse filter s f) = (filter,s,f)++getControlOriginAtt :: ControlAttribute ls ps -> Point2+getControlOriginAtt (ControlOrigin p) = p++getControlOuterSizeAtt :: ControlAttribute ls ps -> Size+getControlOuterSizeAtt (ControlOuterSize size) = size++getControlPenAtt :: ControlAttribute ls ps -> [PenAttribute]+getControlPenAtt (ControlPen atts) = atts++getControlPosAtt :: ControlAttribute ls ps -> ItemPos+getControlPosAtt (ControlPos itemPos) = itemPos++getControlResizeFun :: ControlAttribute ls ps -> ControlResizeFunction+getControlResizeFun (ControlResize f) = f++getControlSelectStateAtt :: ControlAttribute ls ps -> SelectState+getControlSelectStateAtt (ControlSelectState s) = s++getControlTipAtt :: ControlAttribute ls ps -> String+getControlTipAtt (ControlTip tip) = tip++getControlViewDomainAtt :: ControlAttribute ls ps -> ViewDomain+getControlViewDomainAtt (ControlViewDomain pd) = pd++getControlViewSizeAtt :: ControlAttribute ls ps -> Size+getControlViewSizeAtt (ControlViewSize size) = size++getControlVMarginAtt :: ControlAttribute ls ps -> (Int,Int)+getControlVMarginAtt (ControlVMargin top bottom) = (top,bottom)++getControlVScrollFun :: ControlAttribute ls ps -> ScrollFunction+getControlVScrollFun (ControlVScroll f) = f++getControlWidthAtt :: ControlAttribute ls ps -> ControlWidth+getControlWidthAtt (ControlWidth w) = w+
+ Graphics/UI/ObjectIO/StdControlClass.hs view
@@ -0,0 +1,680 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdControlClass+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdControlClass define the standard set of controls instances.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdControlClass (Controls(..), Graphics.UI.ObjectIO.Window.Handle.ControlState) where+++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.StdControlAttribute+import Graphics.UI.ObjectIO.Window.Handle+import Graphics.UI.ObjectIO.Window.Validate(validateViewDomain)+import Graphics.UI.ObjectIO.Control.Validate+import Graphics.UI.ObjectIO.StdIOCommon+import Graphics.UI.ObjectIO.StdPicture(stdUnfillUpdAreaLook)+import Graphics.UI.ObjectIO.OS.Font+import Graphics.UI.ObjectIO.OS.Types+import Graphics.UI.ObjectIO.OS.Window+import Graphics.UI.ObjectIO.OS.Picture(setPenAttribute, defaultPen)+import Graphics.UI.ObjectIO.OS.Rgn(osNoRgn)+import Data.List(find)+++-- | For every user defined control we must have instance of Controls class.+-- There is also instances for 'AddLS', 'NewLS', 'ListLS', 'NilLS' and 'TupLS' data types.+-- Controls can be combined with ':+:' and 'ListLS' constructors. With 'AddLS' and 'NewLS'+-- we can extend or change the local state of a given group of controls. 'NilLS' specifies empty control.++class Controls cdef where+	controlToHandles :: cdef ls ps -> GUI ps [ControlState ls ps]+	-- ^ controlToHandles translates control definition to internal representation++instance (Controls c) => Controls (AddLS c) where+	controlToHandles (AddLS addLS addDef)+		= do {+			cs <- controlToHandles addDef;+			return [wElementHandleToControlState+				(WExtendLSHandle addLS (map controlStateToWElementHandle cs))+			       ]+		     }++instance (Controls c) => Controls (NewLS c) where+	controlToHandles (NewLS newLS newDef)+		= do {+			cs <- controlToHandles newDef;+			return [wElementHandleToControlState+				(WChangeLSHandle newLS (map controlStateToWElementHandle cs))+			       ]+		      }++instance (Controls c) => Controls (ListLS c) where+	controlToHandles (ListLS cDefs)+		= do {+			css <- sequence (map controlToHandles cDefs);+			return [wElementHandleToControlState (WListLSHandle (map controlStateToWElementHandle (concat css)))]+		     }++instance Controls NilLS where+	controlToHandles NilLS+		= return []+++instance (Controls c1,Controls c2) => Controls (TupLS c1 c2) where+	controlToHandles (c1 :+: c2)+		= do {+			cs1 <- controlToHandles c1;+			cs2 <- controlToHandles c2;+			return (cs1 ++ cs2)+		     }++instance Controls ButtonControl where+	controlToHandles (ButtonControl textLine atts)+		= do {+			wMetrics <- accIOEnv ioStGetOSWindowMetrics;+			size     <- liftIO (getButtonSize wMetrics textLine cWidth);+			return+				[wElementHandleToControlState+					(WItemHandle+						{ wItemId         = getIdAttribute atts+						, wItemNr         = 0+						, wItemKind       = IsButtonControl+						, wItemShow	  = not (any isControlHide atts)+						, wItemSelect	  = getSelectStateAttribute atts+						, wItemInfo       = WButtonInfo (ButtonInfo {buttonInfoText=textLine})+						, wItemAtts       = filter (not . redundantAttribute) atts+						, wItems	  = []+						, wItemVirtual	  = False+						, wItemPos        = zero+						, wItemSize       = size+						, wItemPtr        = osNoWindowPtr+						, wItemLayoutInfo = undefined+						})+				]+		  }+		where+			cWidth = getControlWidthAttribute atts++			getButtonSize :: OSWindowMetrics -> String -> Maybe ControlWidth -> IO Size+			getButtonSize wMetrics _ (Just (PixelWidth reqW))+				= return (Size {w=wOK,h=hOK})+				where+					wOK = max (osGetButtonControlMinWidth wMetrics) reqW+					hOK = osGetButtonControlHeight wMetrics+			getButtonSize wMetrics _ (Just (TextWidth wtext))+				= do {+					width <- getDialogFontTextWidth wMetrics wtext;+					let wOK = max (osGetButtonControlMinWidth wMetrics) width+					in  return (Size {w=wOK,h=hOK})+				  }+				where+					hOK = osGetButtonControlHeight wMetrics+			getButtonSize wMetrics _ (Just (ContentWidth wtext))+				= do {+					(width,hOK) <- osGetButtonControlSize wMetrics wtext;+					let wOK = max (osGetButtonControlMinWidth wMetrics) width+					in  return (Size {w=wOK,h=hOK})+				  }+			getButtonSize wMetrics text Nothing+				= do {+					(width,hOK) <- osGetButtonControlSize wMetrics text;+					let wOK = max (osGetButtonControlMinWidth wMetrics) width+					in  return (Size {w=wOK,h=hOK})+				  }++++instance Controls CheckControl where+	controlToHandles (CheckControl items layout atts)+		= do {+			wMetrics <- accIOEnv ioStGetOSWindowMetrics;+			infoItems <- liftIO (mapM (checkItemToInfo wMetrics) items);+			return	[wElementHandleToControlState+					(WItemHandle+						{	wItemId		= getIdAttribute atts+						,	wItemNr		= 0+						,	wItemKind	= IsCheckControl+						,	wItemShow	= not (any isControlHide atts)+						,	wItemSelect	= getSelectStateAttribute atts+						,	wItemInfo	= WCheckInfo (CheckInfo+										{	checkItems = infoItems+										,	checkLayout= validateLayout (length items) layout+										})+						,	wItemAtts	= filter (not . redundantAttribute) atts+						,	wItems		= []+						,	wItemVirtual	= False+						,	wItemPos	= zero+						,	wItemSize	= zero+						,	wItemPtr	= osNoWindowPtr+						,	wItemLayoutInfo	= undefined+						})+				]+		  }+		where+			checkItemToInfo :: OSWindowMetrics -> CheckControlItem ps (ls,ps) -> IO (CheckItemInfo ls ps)+			checkItemToInfo wMetrics (text,Just (PixelWidth reqW),mark,f) =+				let+					wOK				= max (osGetCheckControlItemMinWidth wMetrics) reqW+					hOK				= osGetCheckControlItemHeight wMetrics+				in+					return (CheckItemInfo {checkItem=(text,wOK,mark,f)+								,checkItemSize=Size{w=wOK,h=hOK}+								,checkItemPos=zero+								,checkItemPtr=osNoWindowPtr})++			checkItemToInfo wMetrics (text,Just (TextWidth wtext),mark,f) = do+				w <- getDialogFontTextWidth wMetrics wtext+				let wOK	= max (osGetCheckControlItemMinWidth wMetrics) w+				    hOK	= osGetCheckControlItemHeight wMetrics+				return (CheckItemInfo{checkItem=(text,wOK,mark,f)+							,checkItemSize=Size{w=wOK,h=hOK}+							,checkItemPos=zero+							,checkItemPtr=osNoWindowPtr})+			checkItemToInfo wMetrics (text,Just (ContentWidth wtext),mark,f) = do+				(w,hOK) <- osGetCheckControlItemSize wMetrics wtext+				let wOK = max (osGetCheckControlItemMinWidth wMetrics) w+				return (CheckItemInfo{checkItem=(text,wOK,mark,f)+							,checkItemSize=Size{w=wOK,h=hOK}+							,checkItemPos=zero+							,checkItemPtr=osNoWindowPtr})+			checkItemToInfo wMetrics (text,Nothing,mark,f) = do+				(w,hOK) <- osGetCheckControlItemSize wMetrics text+				let wOK	= max (osGetCheckControlItemMinWidth wMetrics) w+				return (CheckItemInfo{checkItem=(text,wOK,mark,f)+							,checkItemSize=Size{w=wOK,h=hOK}+							,checkItemPos=zero+							,checkItemPtr=osNoWindowPtr})++instance Controls c => Controls (CompoundControl c) where+	controlToHandles (CompoundControl controls atts)+		= do {+			cs <-  controlToHandles controls;+			return [wElementHandleToControlState+				(WItemHandle+				{ wItemId	= getIdAttribute atts+				, wItemNr	= 0+				, wItemKind	= IsCompoundControl+				, wItemShow	= isNothing (find isControlHide atts)+				, wItemSelect	= getSelectStateAttribute atts+				, wItemInfo	= WCompoundInfo (CompoundInfo+							{ compoundDomain   = rectangleToRect domain+							, compoundOrigin   = origin+							, compoundHScroll  = hScrollInfo+							, compoundVScroll  = vScrollInfo+							, compoundLookInfo = CompoundLookInfo+								{ compoundLook= LookInfo+									{ lookFun = lookFun+									, lookPen = pen+									, lookSysUpdate = sysLook+									}+								, compoundClip=ClipState{clipRgn=osNoRgn,clipOk=False}+								}+							})+				, wItemAtts	= filter (not . redundantAttribute) atts+				, wItems	= map controlStateToWElementHandle cs+				, wItemVirtual	= False+				, wItemPos	= zero+				, wItemSize	= zero+				, wItemPtr	= osNoWindowPtr+				, wItemLayoutInfo	= undefined+				})+			]+		}+		where+			(_,lookAtt)			= cselect isControlLook (ControlLook True stdUnfillUpdAreaLook) atts+			(sysLook,lookFun)		= getControlLookAtt lookAtt+			defaultDomain			= ControlViewDomain viewDomainRange{corner1=zero}+			(_,domainAtt)			= cselect isControlViewDomain defaultDomain atts+			domain				= validateViewDomain (getControlViewDomainAtt domainAtt)+			(_,originAtt)			= cselect isControlOrigin (ControlOrigin (corner1 domain)) atts+			origin				= validateOrigin domain (getControlOriginAtt originAtt)+			pen				= getInitialPen atts+			hScrollInfo = case find isControlHScroll atts of +				Just hScrollAtt -> Just ScrollInfo+							{ scrollFunction = getControlHScrollFun hScrollAtt+							, scrollItemPos	 = zero+							, scrollItemSize = zero+							, scrollItemPtr	 = osNoWindowPtr+							}+				Nothing		-> Nothing+			vScrollInfo = case find isControlVScroll atts of+				Just vScrollAtt -> Just ScrollInfo+							{ scrollFunction = getControlVScrollFun vScrollAtt+							, scrollItemPos	 = zero+							, scrollItemSize = zero+							, scrollItemPtr	 = osNoWindowPtr+							}+				Nothing		-> Nothing+++instance Controls CustomButtonControl where+	controlToHandles (CustomButtonControl (Size {w=w,h=h}) controlLook atts) = do+		let size = Size{w=max 0 w,h=max 0 h}+		return [wElementHandleToControlState+			(WItemHandle+			{ wItemId		= getIdAttribute atts+			, wItemNr		= 0+			, wItemKind		= IsCustomButtonControl+			, wItemShow		= not (any isControlHide atts)+			, wItemSelect		= getSelectStateAttribute atts+			, wItemInfo		= WCustomButtonInfo (CustomButtonInfo {cButtonInfoLook=LookInfo{lookFun=controlLook,lookPen=getInitialPen atts,lookSysUpdate=True}})+			, wItemAtts		= filter (not . redundantAttribute) atts+			, wItems		= []+			, wItemVirtual		= False+			, wItemPos		= zero+			, wItemSize		= size+			, wItemPtr		= osNoWindowPtr+			, wItemLayoutInfo	= undefined+			})+		       ]++instance Controls CustomControl where+	controlToHandles (CustomControl (Size {w=w,h=h}) controlLook atts) = do+		let size = Size {w=max 0 w,h=max 0 h}+		return [wElementHandleToControlState+			(WItemHandle+			{ wItemId		= getIdAttribute atts+			, wItemNr		= 0+			, wItemKind		= IsCustomControl+			, wItemShow		= not (any isControlHide atts)+			, wItemSelect		= getSelectStateAttribute atts+			, wItemInfo		= WCustomInfo (CustomInfo {customInfoLook=LookInfo{lookFun=controlLook,lookPen=getInitialPen atts,lookSysUpdate=True}})+			, wItemAtts		= filter (not . redundantAttribute) atts+			, wItems		= []+			, wItemVirtual		= False+			, wItemPos		= zero+			, wItemSize		= size+			, wItemPtr		= osNoWindowPtr+			, wItemLayoutInfo	= undefined+			})+		       ]++instance Controls EditControl where+	controlToHandles (EditControl textLine cWidth nrLines atts)+		= do {+			wMetrics <- accIOEnv ioStGetOSWindowMetrics;+			size     <- liftIO (getEditSize wMetrics nrLines cWidth);+			return+				[wElementHandleToControlState+					(WItemHandle+						{ wItemId         = getIdAttribute atts+						, wItemNr         = 0+						, wItemKind       = IsEditControl+						, wItemShow	  = not (any isControlHide atts)+						, wItemSelect	  = getSelectStateAttribute atts+						, wItemInfo       = WEditInfo (EditInfo+							                  { editInfoText    = textLine+							                  , editInfoWidth   = w size+							                  , editInfoNrLines = nrLines+							                  })+						, wItemAtts       = filter (not . redundantAttribute) atts+						, wItems	  = []+						, wItemVirtual	  = False+						, wItemPos        = zero+						, wItemSize       = size+						, wItemPtr        = osNoWindowPtr+						, wItemLayoutInfo = undefined+						})+				]+		  }+		where+			getEditSize :: OSWindowMetrics -> Int -> ControlWidth -> IO Size+			getEditSize wMetrics nrLines (PixelWidth reqW)+				= do {+					(width,hOK) <- osGetEditControlSize wMetrics reqW nrLines;+					let wOK = max (osGetEditControlMinWidth wMetrics) width+					in  return (Size {w=wOK,h=hOK})+				  }+			getEditSize wMetrics nrLines (TextWidth wtext)+				= do {+					width        <- getDialogFontTextWidth wMetrics wtext;+					(width1,hOK) <- osGetEditControlSize wMetrics width nrLines;+					let wOK = max (osGetEditControlMinWidth wMetrics) width1+					in  return (Size {w=wOK,h=hOK})+				  }+			getEditSize wMetrics nrLines (ContentWidth wtext)+				= do {+					width        <- getDialogFontTextWidth wMetrics (wtext++"mm");+					(width1,hOK) <- osGetEditControlSize wMetrics width nrLines;+					let wOK = max (osGetEditControlMinWidth wMetrics) width1+					in  return (Size {w=wOK,h=hOK})+				  }++instance (Controls c) => Controls (LayoutControl c) where+	controlToHandles (LayoutControl controls atts)+		= do {+			cs <- controlToHandles controls;+			return [wElementHandleToControlState+				(WItemHandle+				{	wItemId		= getIdAttribute atts+				,	wItemNr		= 0+				,	wItemKind	= IsLayoutControl+				,	wItemShow	= not (any isControlHide atts)+				,	wItemSelect	= getSelectStateAttribute atts+				,	wItemInfo	= NoWItemInfo+				,	wItemAtts	= filter (not . redundantAttribute) atts+				,	wItems		= map controlStateToWElementHandle cs+				,	wItemVirtual	= False+				,	wItemPos	= zero+				,	wItemSize	= zero+				,	wItemPtr	= osNoWindowPtr+				,	wItemLayoutInfo	= undefined+				})+			]+		}++instance Controls PopUpControl where+	controlToHandles (PopUpControl popUpItems index atts)+		= do {+			wMetrics <- accIOEnv ioStGetOSWindowMetrics;+			size <- liftIO (getPopUpSize wMetrics (map fst popUpItems) cWidth);+			return [wElementHandleToControlState+				(WItemHandle+				{ wItemId		= getIdAttribute atts+				, wItemNr		= 0+				, wItemKind		= IsPopUpControl+				, wItemShow		= not (any isControlHide atts)+				, wItemSelect		= getSelectStateAttribute atts+				, wItemInfo		= WPopUpInfo (PopUpInfo+								{	popUpInfoItems = popUpItems+								,	popUpInfoIndex = validateIndex (length popUpItems) index+								,	popUpInfoEdit  = Nothing+								})+				, wItemAtts		= filter (not . redundantAttribute) atts+				, wItems		= []+				, wItemVirtual		= False+				, wItemPos		= zero+				, wItemSize		= size+				, wItemPtr		= osNoWindowPtr+				, wItemLayoutInfo	= undefined+				})]+		}+		where+			cWidth						= getControlWidthAttribute atts++			getPopUpSize :: OSWindowMetrics -> [String] -> (Maybe ControlWidth) -> IO Size+			getPopUpSize wMetrics _ (Just (PixelWidth reqW)) =+				let wOK	= max (osGetPopUpControlMinWidth wMetrics) reqW+				    hOK = osGetPopUpControlHeight wMetrics+				in+				    return (Size{w=wOK,h=hOK})+			getPopUpSize wMetrics _ (Just (TextWidth wtext)) = do+				w <- getDialogFontTextWidth wMetrics wtext+				(let wOK = max (osGetPopUpControlMinWidth wMetrics) w+				     hOK = osGetPopUpControlHeight wMetrics+				 in return (Size{w=wOK,h=hOK}))+			getPopUpSize wMetrics _ (Just (ContentWidth wtext)) = do+				(w,hOK) <- osGetPopUpControlSize wMetrics [wtext]+				(let wOK = max (osGetPopUpControlMinWidth wMetrics) w+				 in return (Size{w=wOK,h=hOK}))+			getPopUpSize wMetrics itemtexts Nothing = do+				(w,hOK) <- osGetPopUpControlSize wMetrics (if null itemtexts then ["MMMMMMMMMM"] else itemtexts)+				(let wOK = max (osGetPopUpControlMinWidth wMetrics) w+				 in return (Size{w=wOK,h=hOK}))+++instance Controls ListBoxControl where+	controlToHandles (ListBoxControl listBoxItems nrLines multi atts)+		= do {+			wMetrics <- accIOEnv ioStGetOSWindowMetrics;+			size <- liftIO (getListBoxSize wMetrics (map fst3 listBoxItems) cWidth);+			return [wElementHandleToControlState+				(WItemHandle+				{ wItemId		= getIdAttribute atts+				, wItemNr		= 0+				, wItemKind		= IsListBoxControl+				, wItemShow		= not (any isControlHide atts)+				, wItemSelect		= getSelectStateAttribute atts+				, wItemInfo		= WListBoxInfo (ListBoxInfo+								{ listBoxInfoItems = listBoxItems+								, listBoxNrLines   = nrLines+								, listBoxInfoMultiSel = multi+								})+				, wItemAtts		= filter (not . redundantAttribute) atts+				, wItems		= []+				, wItemVirtual		= False+				, wItemPos		= zero+				, wItemSize		= size+				, wItemPtr		= osNoWindowPtr+				, wItemLayoutInfo	= undefined+				})]+		}+		where+			fst3 (a,b,c) = a+			cWidth	= getControlWidthAttribute atts++			getListBoxSize :: OSWindowMetrics -> [String] -> (Maybe ControlWidth) -> IO Size+			getListBoxSize wMetrics _ (Just (PixelWidth reqW)) =+				let wOK	= max (osGetListBoxControlMinWidth wMetrics) reqW+				    hOK = osGetListBoxControlHeight wMetrics nrLines+				in+				    return (Size{w=wOK,h=hOK})+			getListBoxSize wMetrics _ (Just (TextWidth wtext)) = do+				w <- getDialogFontTextWidth wMetrics wtext+				(let wOK = max (osGetListBoxControlMinWidth wMetrics) w+				     hOK = osGetListBoxControlHeight wMetrics nrLines+				 in return (Size{w=wOK,h=hOK}))+			getListBoxSize wMetrics _ (Just (ContentWidth wtext)) = do+				(w,hOK) <- osGetListBoxControlSize wMetrics nrLines [wtext]+				(let wOK = max (osGetListBoxControlMinWidth wMetrics) w+				 in return (Size{w=wOK,h=hOK}))+			getListBoxSize wMetrics itemtexts Nothing = do+				(w,hOK) <- osGetListBoxControlSize wMetrics nrLines (if null itemtexts then ["MMMMMMMMMM"] else itemtexts)+				(let wOK = max (osGetListBoxControlMinWidth wMetrics) w+				 in return (Size{w=wOK,h=hOK}))+++instance Controls RadioControl where+	controlToHandles (RadioControl items layout index atts)+		= do {+			wMetrics <- accIOEnv ioStGetOSWindowMetrics;+			infoItems <- liftIO (mapM (radioItemToInfo wMetrics) items);+			return [wElementHandleToControlState+				(WItemHandle+				{	wItemId			= getIdAttribute atts+				,	wItemNr			= 0+				,	wItemKind		= IsRadioControl+				,	wItemShow		= not (any isControlHide atts)+				,	wItemSelect		= getSelectStateAttribute atts+				,	wItemInfo		= let nrItems = length items in+									WRadioInfo (RadioInfo+										{	radioItems = infoItems+										,	radioLayout= validateLayout nrItems layout+										,	radioIndex = setBetween index 1 nrItems+										})+				,	wItemAtts		= filter (not . redundantAttribute) atts+				,	wItems			= []+				,	wItemVirtual	= False+				,	wItemPos		= zero+				,	wItemSize		= zero+				,	wItemPtr		= osNoWindowPtr+				,	wItemLayoutInfo	= undefined+				})]+		}+		where+			radioItemToInfo :: OSWindowMetrics -> (RadioControlItem ps (ls,ps)) -> IO (RadioItemInfo ls ps)++			radioItemToInfo wMetrics (text,Just (PixelWidth reqW),f) =+				let+					wOK = max (osGetRadioControlItemMinWidth wMetrics) reqW+					hOK = osGetRadioControlItemHeight wMetrics+				in+					return (RadioItemInfo {radioItem=(text,wOK,f)+							, radioItemSize=Size{w=wOK,h=hOK}+							, radioItemPos=zero+							, radioItemPtr=osNoWindowPtr})+			radioItemToInfo wMetrics (text,Just (TextWidth wtext),f) = do+				w <- getDialogFontTextWidth wMetrics wtext+			  	let wOK = max (osGetRadioControlItemMinWidth wMetrics) w+				    hOK = osGetRadioControlItemHeight wMetrics+				return (RadioItemInfo{radioItem=(text,wOK,f)+						,radioItemSize=Size{w=wOK,h=hOK}+						,radioItemPos=zero+						,radioItemPtr=osNoWindowPtr})+			radioItemToInfo wMetrics (text,Just (ContentWidth wtext),f) = do+				(w,hOK) <- osGetRadioControlItemSize wMetrics wtext+			  	let wOK	= max (osGetRadioControlItemMinWidth wMetrics) w+				return (RadioItemInfo{radioItem=(text,wOK,f)+						,radioItemSize=Size{w=wOK,h=hOK}+						,radioItemPos=zero+						,radioItemPtr=osNoWindowPtr})+			radioItemToInfo wMetrics (text,Nothing,f) = do+				(w,hOK)	<- osGetRadioControlItemSize wMetrics text+			  	let wOK	= max (osGetRadioControlItemMinWidth wMetrics) w+				return (RadioItemInfo{radioItem=(text,wOK,f)+						,radioItemSize=Size{w=wOK,h=hOK}+						,radioItemPos=zero+						,radioItemPtr=osNoWindowPtr})++++instance Controls SliderControl where+	controlToHandles (SliderControl direction cWidth sliderState action atts)+		= do {+			wMetrics <- accIOEnv ioStGetOSWindowMetrics;+			size <- liftIO (getSliderSize wMetrics isHorizontal cWidth);+			return [wElementHandleToControlState+				(WItemHandle+				{	wItemId		= getIdAttribute atts+				,	wItemNr		= 0+				,	wItemKind	= IsSliderControl+				,	wItemShow	= not (any isControlHide atts)+				,	wItemSelect	= getSelectStateAttribute atts+				,	wItemInfo	= WSliderInfo (SliderInfo+								{	sliderInfoDir	= direction+								,	sliderInfoLength= (if isHorizontal then w else h) size -- PA: maybe this field is now redundant+								,	sliderInfoState	= validateSliderState sliderState+								,	sliderInfoAction= action+								})+				,	wItemAtts	= filter (not . redundantAttribute) atts+				,	wItems		= []+				,	wItemVirtual	= False+				,	wItemPos	= zero+				,	wItemSize	= size+				,	wItemPtr	= osNoWindowPtr+				,	wItemLayoutInfo	= undefined+				})+			]+		}+		where+			isHorizontal = direction == Horizontal++			getSliderSize :: OSWindowMetrics -> Bool -> ControlWidth -> IO Size+			getSliderSize wMetrics isHorizontal (PixelWidth reqW) = do+				let (wOK,hOK) = osGetSliderControlSize wMetrics isHorizontal reqW+				return (Size{w=wOK,h=hOK})+			getSliderSize wMetrics isHorizontal (TextWidth wtext) = do+				w <- getDialogFontTextWidth wMetrics wtext+				let (wOK,hOK) = osGetSliderControlSize wMetrics isHorizontal w+				return (Size{w=wOK,h=hOK})+			getSliderSize wMetrics isHorizontal (ContentWidth wtext) = do+				w <- getDialogFontTextWidth wMetrics wtext+				let (wOK,hOK) = osGetSliderControlSize wMetrics isHorizontal w+				return (Size{w=wOK,h=hOK})+++instance Controls TextControl where+	controlToHandles (TextControl textLine atts)+		= do {+			wMetrics <- accIOEnv ioStGetOSWindowMetrics;+			size     <- liftIO (getTextSize wMetrics textLine cWidth);+			return+				[wElementHandleToControlState+					(WItemHandle+						{ wItemId         = getIdAttribute atts+						, wItemNr         = 0+						, wItemKind       = IsTextControl+						, wItemShow	  = not (any isControlHide atts)+						, wItemSelect	  = getSelectStateAttribute atts+						, wItemInfo       = WTextInfo (TextInfo {textInfoText=textLine})+						, wItemAtts       = filter (not . redundantAttribute) atts+						, wItems	  = []+						, wItemVirtual	  = False+						, wItemPos        = zero+						, wItemSize       = size+						, wItemPtr        = osNoWindowPtr+						, wItemLayoutInfo = undefined+						})+				]+		  }+		where+			cWidth = getControlWidthAttribute atts++			getTextSize :: OSWindowMetrics -> String -> Maybe ControlWidth -> IO Size+			getTextSize wMetrics _ (Just (PixelWidth reqW))+				= return (Size {w=wOK,h=hOK})+				where+					wOK = max (osGetTextControlMinWidth wMetrics) reqW+					hOK = osGetTextControlHeight wMetrics+			getTextSize wMetrics _ (Just (TextWidth wtext))+				= do {+					width <- getDialogFontTextWidth wMetrics wtext;+					let wOK = max (osGetTextControlMinWidth wMetrics) width+					    hOK = osGetTextControlHeight wMetrics+					in  return (Size {w=wOK,h=hOK})+				  }+			getTextSize wMetrics _ (Just (ContentWidth wtext))+				= do {+					(width,hOK) <- osGetTextControlSize wMetrics wtext;+					let wOK = max (osGetTextControlMinWidth wMetrics) width+					in  return (Size {w=wOK,h=hOK})+				  }+			getTextSize wMetrics text Nothing+				= do {+					(width,hOK) <- osGetTextControlSize wMetrics text;+					let wOK = max (osGetTextControlMinWidth wMetrics) width+					in  return (Size {w=wOK,h=hOK})+				  }++-- getDialogFontTextWidth is not the proper implementation because accScreenPicture class not yet implemented.+-- This version gives a crude estimation in terms of max width times text length.+getDialogFontTextWidth :: OSWindowMetrics -> String -> IO Int+getDialogFontTextWidth wMetrics text+	= do {+		(_,_,_,maxwidth) <- osGetFontMetrics Nothing (osmFont wMetrics);+		return ((length text) * maxwidth)+	  }++getIdAttribute :: [ControlAttribute ls ps] -> Maybe Id+getIdAttribute atts = fmap getControlIdAtt (find isControlId atts)++getControlWidthAttribute :: [ControlAttribute ls ps] -> Maybe ControlWidth+getControlWidthAttribute atts = fmap getControlWidthAtt (find isControlWidth atts)++getSelectStateAttribute :: [ControlAttribute ls ps] -> Bool+getSelectStateAttribute atts = maybe True (enabled . getControlSelectStateAtt) (find isControlSelectState atts)++redundantAttribute :: ControlAttribute ls ps -> Bool+redundantAttribute (ControlId _) = True+redundantAttribute _             = False++getInitialPen :: [ControlAttribute ls ps] -> Pen+getInitialPen atts =+	case find isControlPen atts of+		Just penAttsAtt -> foldr setPenAttribute defaultPen (getControlPenAtt penAttsAtt)+		Nothing		-> defaultPen++validateLayout :: Int -> RowsOrColumns -> RowsOrColumns+validateLayout nrItems (Rows    n) = Rows    (setBetween n 1 nrItems)+validateLayout nrItems (Columns n) = Columns (setBetween n 1 nrItems)++validateIndex :: Int -> Index -> Index+validateIndex nrItems index+	| isBetween index 1 nrItems 	= index+	| otherwise			= 1++validateOrigin :: ViewDomain -> Point2 -> Point2+validateOrigin (Rectangle{corner1=Point2{x=corX1, y=corY1}, corner2=Point2{x=corX2, y=corY2}}) (Point2{x=origX, y=origY})+	= Point2 {	x=setBetween origX corX1 corX2+	  	 ,	y=setBetween origY corY1 corY2+	  	 }
+ Graphics/UI/ObjectIO/StdControlDef.hs view
@@ -0,0 +1,138 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdControlDef+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdControlDef contains the types to define the standard set of controls.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdControlDef+		( module Graphics.UI.ObjectIO.StdControlDef+		, module Graphics.UI.ObjectIO.StdIOCommon+		, module Graphics.UI.ObjectIO.StdGUI+		) where+++import Graphics.UI.ObjectIO.StdGUI+import Graphics.UI.ObjectIO.StdIOCommon+import Graphics.UI.ObjectIO.StdPicture(PenAttribute(..), Look)+++data	ButtonControl ls ps+ =	ButtonControl String                      				[ControlAttribute ls ps]++data	CheckControl  ls ps+ = 	CheckControl  [CheckControlItem ps (ls,ps)]  RowsOrColumns       	[ControlAttribute ls ps]++-- | The compound control is a control that contains other controls. It introduces a new+-- layout scope like 'LayoutControl' but it provides programmers with a lot more functionality.+-- Just like the windows,  the compound controls have a view domain and can have its own Look +-- function. If we add 'ControlHScroll' or 'ControlVScroll' attribute then the control will be decorated with scroll bars.+data	CompoundControl c ls ps+ = 	CompoundControl (c ls ps)                                		[ControlAttribute ls ps]++-- | CustomButtonControl is like the 'ButtonControl' but has its own 'Look' and +-- doesn\'t accept the 'ControlTitle' attribute.+data	CustomButtonControl ls ps+ = 	CustomButtonControl Size Look                                        	[ControlAttribute ls ps]++-- | CustomControl allows the programmer to design his\/her own controls.+data	CustomControl       ls ps+ = 	CustomControl       Size Look                                        	[ControlAttribute ls ps]++-- | An edit control is a rectangular box in which the user can enter text.+data	EditControl   ls ps+ =	EditControl   String ControlWidth NrLines 				[ControlAttribute ls ps]++-- | The layout control is a control that contains other controls. It introduces a new layout+-- scope: i.e. the controls inside it are positioned in relation to the bounds of the layout control.+data	LayoutControl     c ls ps+ = 	LayoutControl     (c ls ps)                                  		[ControlAttribute ls ps]++-- | A popup control consists of a list box combined with simple text control.+-- The list-box portion of the control drop down when the user selects the drop-down arrow next to the control.+data	PopUpControl 	ls ps+ = 	PopUpControl   	[PopUpControlItem ps (ls,ps)] Index 			[ControlAttribute ls ps]++-- | The control is a rectangle containing a list of strings from which the user can select.+data	ListBoxControl 	ls ps+ = 	ListBoxControl  [ListBoxControlItem ps (ls,ps)] NrLines Bool		[ControlAttribute ls ps]++data	RadioControl   	ls ps+ = 	RadioControl    [RadioControlItem ps (ls,ps)] RowsOrColumns Index 	[ControlAttribute ls ps]++data	SliderControl  	ls ps+ = 	SliderControl   Direction ControlWidth SliderState  (SliderAction  ls ps) [ControlAttribute ls ps]++-- | This is a simple control that just displays its caption.+data	TextControl   ls ps+ =	TextControl   String                      				[ControlAttribute ls ps]+++type	CheckControlItem   ps st = (String, Maybe ControlWidth, MarkState, st -> GUI ps st)+type	PopUpControlItem   ps st = (String,                                st -> GUI ps st)+type	ListBoxControlItem ps st = (String, MarkState,                     st -> GUI ps st)+type	RadioControlItem   ps st = (String, Maybe ControlWidth,            st -> GUI ps st)+++type	NrLines+ =	Int+data	RowsOrColumns+	= Rows       Int+	| Columns    Int+data	ControlWidth                                -- The width of the control:+ =	PixelWidth   Int                            -- the exact number of pixels+ |	TextWidth    String                         -- the exact string width in dialog font+ |	ContentWidth String                         -- width of the control as if string is its content++data	ControlAttribute ls ps            	    -- Default:+ -- General control attributes:+ =	ControlActivate     (GUIFun ls ps)          -- return+ |	ControlDeactivate   (GUIFun ls ps)   	    -- return+ |	ControlFunction (GUIFun ls ps)              -- (\st->return st)+ |	ControlHide                                 -- initially visible+ |	ControlId       Id                          -- no id+ |	ControlKeyboard KeyboardStateFilter SelectState (KeyboardFunction ls ps)+	                                            -- no keyboard input/overruled+ |	ControlMinimumSize  Size                    -- zero+ |	ControlModsFunction (ModifiersFunction ls ps)+                                                    -- ControlFunction+ |	ControlMouse        MouseStateFilter    SelectState (MouseFunction ls ps)+		                                    -- no mouse input/overruled+ |	ControlPen	    [PenAttribute]	    -- default pen attributes+ |	ControlPos          ItemPos                 -- (RightTo previous,zero)+ |	ControlResize       ControlResizeFunction   -- no resize+ |	ControlSelectState  SelectState             -- control Able+ |	ControlTip          String                  -- no tip+ |	ControlWidth        ControlWidth            -- system derived+ --	For CompoundControls only:+ |	ControlHMargin      Int Int                 -- system dependent+ |	ControlHScroll      ScrollFunction          -- no horizontal scrolling+ |	ControlItemSpace    Int Int                 -- system dependent+ |	ControlLook         Bool Look               -- control is transparant+ |	ControlOrigin       Point2                  -- Left top of ViewDomain+ |	ControlOuterSize    Size		    -- enclose elements+ |	ControlViewDomain   ViewDomain              -- {zero,max range}+ |	ControlViewSize     Size                    -- enclose elements+ |	ControlVMargin      Int Int                 -- system dependent+ |	ControlVScroll      ScrollFunction          -- no vertical   scrolling+ |      ControlDoubleBuffered+++++type ControlResizeFunction =+	Size ->                                     		-- current control outer size+	Size ->                                     		-- old     parent  view  size+	Size ->                                     		-- new     parent  view  size+	Size                                        		-- new     control outer size++++type ControlType = String
+ Graphics/UI/ObjectIO/StdControlReceiver.hs view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdControlReceiver+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdControlReceiver defines Receiver(2) instances of 'Controls' class.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdControlReceiver where++++import	Graphics.UI.ObjectIO.StdControlClass+import	Graphics.UI.ObjectIO.StdReceiverAttribute+import	Graphics.UI.ObjectIO.Window.Handle+import	Graphics.UI.ObjectIO.CommonDef(cselect)+import	Graphics.UI.ObjectIO.Receiver.Access(newReceiverHandle,newReceiver2Handle)+import	Graphics.UI.ObjectIO.OS.Types(osNoWindowPtr)+++instance Controls (Receiver m) where	+	controlToHandles (Receiver rid f atts) =+		return [wElementHandleToControlState+				(WItemHandle +					{ wItemId		= Just (rIdtoId rid)+					, wItemNr		= 0+					, wItemKind		= IsReceiverControl+					, wItemShow		= False+					, wItemSelect		= enabled select+					, wItemInfo		= WReceiverInfo (newReceiverHandle rid select f)+					, wItemAtts		= []+					, wItems		= []+					, wItemVirtual		= True+					, wItemPos		= zero+					, wItemSize		= zero+					, wItemPtr		= osNoWindowPtr+					, wItemLayoutInfo	= LayoutFix+					})+			]		  +		where		+			select	= getReceiverSelectStateAtt (snd (cselect isReceiverSelectState (ReceiverSelectState Able) atts))+++instance Controls (Receiver2 m r) where	+	controlToHandles (Receiver2 rid f atts) =+		return [wElementHandleToControlState+				(WItemHandle +					{ wItemId		= Just (r2IdtoId rid)+					, wItemNr		= 0+					, wItemKind		= IsReceiverControl+					, wItemShow		= False+					, wItemSelect		= enabled select+					, wItemInfo		= WReceiverInfo (newReceiver2Handle rid select f)+					, wItemAtts		= []+					, wItems		= []+					, wItemVirtual		= True+					, wItemPos		= zero+					, wItemSize		= zero+					, wItemPtr		= osNoWindowPtr+					, wItemLayoutInfo	= LayoutFix+					})+			]		  +		where		+			select	= getReceiverSelectStateAtt (snd (cselect isReceiverSelectState (ReceiverSelectState Able) atts))
+ Graphics/UI/ObjectIO/StdFileSelect.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdFileSelect+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdFileSelect(selectInputFile, selectOutputFile, selectDirectory) where++++import Graphics.UI.ObjectIO.Process.Scheduler+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.OS.FileSelect+import Graphics.UI.ObjectIO.OS.Event++-- | The selectInputFile function opens a dialog for file selecting and returns the selected file name.+-- If the file doesn\'t exist, the function shows a popup message box with a warning message.+selectInputFile :: ps -> GUI ps (Maybe String, ps)+selectInputFile ps = do+	context <- accIOEnv ioStGetContext+	liftContextIO (\context -> osSelectInputFile (handleOSEvent context)) ps+++-- | The selectOutputFile function opens a dialog for file selecting and returns the selected file name.+-- If the file already exists, the function shows a popup message box with a warning message.+selectOutputFile :: String -> String -> ps -> GUI ps (Maybe String, ps)+selectOutputFile prompt filename ps = do+	context <- accIOEnv ioStGetContext+	liftContextIO (\context -> osSelectOutputFile (handleOSEvent context) prompt filename) ps++-- | The selectDirectory opens a dialog for directory selecting.+selectDirectory :: ps -> GUI ps (Maybe String, ps)+selectDirectory ps = do+	context <- accIOEnv ioStGetContext+	liftContextIO (\context -> osSelectDirectory (handleOSEvent context)) ps++handleOSEvent :: Context -> OSEvent -> IO ()+handleOSEvent context osEvent = do+	handleContextOSEvent context (ScheduleOSEvent osEvent [])+	return ()
+ Graphics/UI/ObjectIO/StdGUI.hs view
@@ -0,0 +1,80 @@+{-# OPTIONS_GHC -cpp #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  StdGUI+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+--  This is a new module that provides similar functionality as StdPSt in the Clean+--  Object I\/O library.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdGUI (+        noLS, noLS1, +        GUIFun, GUI, ProcessAttribute(..), ModifiersFunction, KeyboardFunction,+        MouseFunction, SliderAction, ScrollFunction,+        ProcessWindowResizeFunction, ProcessOpenFilesFunction, ToolbarItem(..)) where++#ifndef __HADDOCK__+import {-# SOURCE #-} Graphics.UI.ObjectIO.Process.IOState(GUI, noLS, noLS1)+#endif+import Graphics.UI.ObjectIO.StdIOCommon(Modifiers(..),KeyboardState(..),SliderState(..),SliderMove(..),MouseState(..),ViewFrame, ItemPos, Size(..))+import Graphics.UI.ObjectIO.StdBitmap(Bitmap)++type    GUIFun ls ps+ =  (ls,ps) -> GUI ps (ls,ps)+ +type    GUI2Fun ps+ =  ps -> GUI ps ps+++{-  Process attributes.             -}++data    ProcessAttribute ps                  -- Default:+    = ProcessActivate   (ps -> GUI ps ps)        -- No action on activate+    | ProcessDeactivate (ps -> GUI ps ps)        -- No action on deactivate+    | ProcessClose      (ps -> GUI ps ps)        -- Process is closed+--  Attributes for (M/S)DI process only:+    | ProcessOpenFiles  (ProcessOpenFilesFunction ps)    -- Request to open files+    | ProcessWindowPos  ItemPos              -- Platform dependent+    | ProcessWindowSize Size                 -- Platform dependent+    | ProcessWindowResize   (ProcessWindowResizeFunction ps) -- Platform dependent+    | ProcessToolbar    [ToolbarItem ps]         -- Process has no toolbar+ -- Attributes for MDI processes only:+    | ProcessNoWindowMenu                    -- Process has WindowMenu++type    ProcessWindowResizeFunction ps +     =  Size                        -- Old ProcessWindow size+     -> Size                        -- New ProcessWindow size+     -> ps -> GUI ps ps+type    ProcessOpenFilesFunction ps+     =  [String]                    -- The file names to open+     -> ps -> GUI ps ps++data    ToolbarItem ps+    = ToolbarItem Bitmap (Maybe String) (ps -> GUI ps ps)+    | ToolbarSeparator++++{-  Frequently used function types.         -}++type    ModifiersFunction ls ps = Modifiers     -> GUIFun ls ps+type    KeyboardFunction  ls ps = KeyboardState -> GUIFun ls ps+type    MouseFunction     ls ps = MouseState    -> GUIFun ls ps+type    SliderAction      ls ps = SliderMove    -> GUIFun ls ps+++{-  Scrolling function.             -}++type    ScrollFunction =+        ViewFrame   ->              -- Current  view+        SliderState ->              -- Current  state of scrollbar+        SliderMove  ->              -- Action of the user+        Int
+ Graphics/UI/ObjectIO/StdIOBasic.hs view
@@ -0,0 +1,135 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdIOBasic+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdIOBasic defines basic types and access functions for the I\/O library.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdIOBasic (module Graphics.UI.ObjectIO.StdIOBasic) where++++class Zero a where+	zero   :: a+class One a where+	one    :: a+class Toggle a where		-- This used to be ~ in Clean, but in Haskell ~ is reserved.+	toggle :: a -> a+++instance Toggle Bool where+	toggle x = not x++{-	General type constructors for composing context-independent data structures.+-}+infixr 9 :^:+data	Tup	t1 t2			= t1 :^: t2+++{-	General type constructors for composing context-dependent data structures.+-}+infixr 9 :~:+data	TupSt	t1 t2		ps	= (t1 ps) :~: (t2 ps)+data	ListCS	t		ps	= ListCS [t ps]+data	NilCS			ps	= NilCS+++{-	General type constructors for composing local and context-dependent +	data structures.+-}+infixr 9 :+:+data	TupLS	t1 t2	ls	ps	= (t1 ls ps) :+: (t2 ls ps)+data	ListLS	t	ls	ps	= ListLS [t ls ps]+data	NilLS		ls	ps	= NilLS+data	NewLS	t	ls	ps	= forall new . NewLS new (t  new     ps)+data	AddLS	t	ls	ps	= forall add . AddLS add (t (add,ls) ps)+++type	Index = Int+type	Title = String+++data	Vector2 = Vector2 {vx :: !Int, vy :: !Int}+	deriving (Eq,Show)++instance Zero Vector2 where+	zero          = Vector2 {vx=0,vy=0}+instance Num Vector2 where+	(+)    v1 v2  = Vector2 {vx=vx v1+vx v2,vy=vy v1+vy v2}+	(-)    v1 v2  = Vector2 {vx=vx v1-vx v2,vy=vy v1-vy v2}+	negate v      = Vector2 {vx=0-vx v,vy=0-vy v}++{-	(*), abs, signum, fromInteger are undefined!!+	Application generates runtime error.+-}+	(*) _ _       = error "Undefined application of Vector2 instance of (*) Num"+	abs _         = error "Undefined application of Vector2 instance of abs Num"+	signum _      = error "Undefined application of Vector2 instance of signum Num"+	fromInteger   = error "Undefined application of Vector2 instance of fromInteger Num"+++class ToVector x where+	toVector :: x -> Vector2++data	Size = Size {w :: !Int, h :: !Int}+	deriving (Eq,Show)++instance Zero Size where		-- {w=0,h=0}+	zero = Size {w=0,h=0}+instance ToVector Size where		-- {w,h}->{vx=w,vy=h}+	toVector s = Vector2 {vx=w s,vy=h s}+++data	Point2    = Point2 {x :: !Int, y :: !Int}+	deriving (Eq,Show)+data	Rectangle = Rectangle {corner1 :: !Point2, corner2 :: !Point2}+	deriving (Eq,Show)++instance Zero Point2 where+	zero          = Point2 {x=0,y=0}+instance Num Point2 where+	(+)    p1 p2  = Point2 {x=x p1+x p2,y=y p1+y p2}+	(-)    p1 p2  = Point2 {x=x p1-x p2,y=y p1-y p2}+	negate p      = Point2 {x=0-x p,y=0-y p}++{-	(*), abs, signum, fromInteger are undefined!!+	Application generates runtime error.+-}+	(*) _ _       = error "Undefined application of Point2 instance of (*) Num"+	abs _         = error "Undefined application of Point2 instance of abs Num"+	signum _      = error "Undefined application of Point2 instance of signum Num"+	fromInteger _ = error "Undefined application of Point2 instance of fromInteger Num"+instance ToVector Point2 where+	toVector p    = Vector2 {vx=x p,vy=y p}++instance Zero Rectangle where+	zero = Rectangle {corner1=zero, corner2=zero}++rectangleSize :: Rectangle -> Size		-- {w=abs (@1.corner1-@1.corner2).x,+						--  h=abs (@1.corner1-@1.corner2).y}+rectangleSize r+	= let	p1 = corner1 r+		p2 = corner2 r+	  in	Size {w=abs (x p2-x p1),h=abs (y p2-y p1)}++movePoint :: Vector2 -> Point2 -> Point2	-- {vx,vy} {x,y} -> {vx+x,vy+y}+movePoint v p = Point2 {x=vx v+x p,y=vy v+y p}+++type	IdFun st = st -> st+++-- | IOMonad class is a simply way to call IO actions from IO-like monads.+-- There are instances for 'IO', 'Draw' and 'GUI'.+class Monad m => IOMonad m where+	liftIO :: IO a -> m a+	+instance IOMonad IO where+	liftIO f = f
+ Graphics/UI/ObjectIO/StdIOCommon.hs view
@@ -0,0 +1,315 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdIOCommon+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdIOCommon defines common types and access functions for the I\/O library.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdIOCommon+		   ( module Graphics.UI.ObjectIO.StdIOCommon+                   , module Graphics.UI.ObjectIO.StdIOBasic+                   , module Graphics.UI.ObjectIO.StdKey+                   , module Data.Maybe+                   , Graphics.UI.ObjectIO.Id.Id+                   , Graphics.UI.ObjectIO.Id.R2Id+                   , Graphics.UI.ObjectIO.Id.RId+                   , Graphics.UI.ObjectIO.Id.rIdtoId+                   , Graphics.UI.ObjectIO.Id.r2IdtoId+                   ) where++++import Graphics.UI.ObjectIO.Id (Id, RId, R2Id, rIdtoId, r2IdtoId)+import Graphics.UI.ObjectIO.StdIOBasic+import Graphics.UI.ObjectIO.StdKey+import Data.Maybe+import Data.Dynamic+++{-	The SelectState and MarkState types.			-}++-- | 'SelectState' is similar to Bool but it shows whether an object is enabled or disabled.+data	SelectState+	= Able | Unable+	deriving (Eq,Show)+	+-- | 'MarkState' is similar to Bool but it shows whether the 'CheckControl' is marked.	+data	MarkState+	= Mark | NoMark+	deriving (Eq,Show)++enabled :: SelectState -> Bool					-- @1 == Able+enabled Able   = True+enabled unable = False++marked :: MarkState -> Bool					-- @1 == Able+marked Mark   = True+marked unable = False++instance Toggle SelectState where				-- Able <-> Unable+	toggle Able = Unable+	toggle _    = Able+	+	+instance Toggle MarkState where					-- Mark <-> NoMark+	toggle Mark = NoMark+	toggle _    = Mark+++-- | 'KeyboardState' is passed to keyboard handler for every keyboard event.+data	KeyboardState+	= CharKey    Char       KeyState			-- ^ ASCII character input+	| SpecialKey SpecialKey KeyState Modifiers		-- ^ Special key input+	| KeyLost						-- ^ Key input lost while key was down+	deriving (Eq,Show)+	+-- | The KeyState type+data	KeyState+	= KeyDown    IsRepeatKey				-- ^ Key is down+	| KeyUp							-- ^ Key goes up+	deriving (Eq,Show)+	+-- | Flag on key down (True iff key is repeating)+type	IsRepeatKey+	= Bool+data	Key+	= IsCharKey    Char+	| IsSpecialKey SpecialKey+	+-- | Predicate on KeyboardState+type	KeyboardStateFilter = KeyboardState -> Bool++-- | getKeyboardStateKeyState gets KeyState from KeyboardState (KeyUp if KeyboardState is KeyLost)+getKeyboardStateKeyState:: KeyboardState -> KeyState+getKeyboardStateKeyState (CharKey _ keyState) 		= keyState+getKeyboardStateKeyState (SpecialKey _ keyState _)	= keyState+getKeyboardStateKeyState KeyLost			= KeyUp++-- | getKeyboardStateKey gets Key value from KeyboardState (Nothing if KeyboardState is KeyLost)+getKeyboardStateKey :: KeyboardState -> Maybe Key+getKeyboardStateKey (CharKey char _)		= Just (IsCharKey char)+getKeyboardStateKey (SpecialKey special _ _)	= Just (IsSpecialKey special)+getKeyboardStateKey KeyLost			= Nothing+	+	+-- | The MouseState type.+data	MouseState+	= MouseMove	Point2 Modifiers		-- ^ Mouse is up     (position,modifiers)+	| MouseDown	Point2 Modifiers Int		-- ^ Mouse goes down (and nr down)+	| MouseDrag	Point2 Modifiers		-- ^ Mouse is down   (position,modifiers)+	| MouseUp	Point2 Modifiers		-- ^ Mouse goes up   (position,modifiers)+	| MouseLost					-- ^ Mouse input lost while mouse was down+	deriving (Eq, Show)+	+-- | The ButtonState type.+data	ButtonState+ 	= ButtonStillUp					-- ^ MouseMove+ 	| ButtonDown					-- ^ MouseDown  _ _ 1+	| ButtonDoubleDown				-- ^		_ _ 2+	| ButtonTripleDown				-- ^            _ _ >2+	| ButtonStillDown				-- ^ MouseDrag+ 	| ButtonUp					-- ^ MouseUp\/MouseLost+ 	deriving (Eq, Show)+ 	+-- | Predicate on MouseState+type	MouseStateFilter = MouseState -> Bool+++getMouseStatePos :: MouseState -> Point2+getMouseStatePos (MouseMove pos _)	= pos+getMouseStatePos (MouseDown pos _ _)	= pos+getMouseStatePos (MouseDrag pos _)	= pos+getMouseStatePos (MouseUp   pos _)	= pos+getMouseStatePos MouseLost		= zero++getMouseStateModifiers :: MouseState -> Modifiers+getMouseStateModifiers (MouseMove _ mods)	= mods+getMouseStateModifiers (MouseDown _ mods _)	= mods+getMouseStateModifiers (MouseDrag _ mods)	= mods+getMouseStateModifiers (MouseUp   _ mods)	= mods+getMouseStateModifiers MouseLost		= noModifiers++getMouseStateButtonState:: MouseState	-> ButtonState+getMouseStateButtonState (MouseMove _ _)	= ButtonStillUp+getMouseStateButtonState (MouseDown _ _ nr)	= +	case nr of+	  1 -> ButtonDown +	  2 -> ButtonDoubleDown+	  _ -> ButtonTripleDown++getMouseStateButtonState (MouseDrag _ _)	= ButtonStillDown+getMouseStateButtonState (MouseUp   _ _)	= ButtonUp+getMouseStateButtonState MouseLost		= ButtonUp+++{-	The SliderState type.					-}++data	SliderState +	= SliderState+		{ sliderMin	:: !Int+		, sliderMax	:: !Int+		, sliderThumb	:: !Int+		}+	deriving (Eq, Show)+		+		+{-	The UpdateState type.					-}+data	UpdateState+	= UpdateState+		{ oldFrame	:: !ViewFrame+		, newFrame	:: !ViewFrame+		, updArea	:: !UpdateArea+		}+	deriving (Show)+	+-- | ViewDomain is the 'Rectangle', which specifies the logical drawing area of the CompoundControl or Window.+type	ViewDomain = Rectangle++-- | ViewFrame is the current visible 'Rectangle' of CompoundControl or Window.+-- When there are horizontal and vertical scroll bars then the changing of +-- the scroller thumb will change the 'ViewFrame'.+type	ViewFrame  = Rectangle++type	UpdateArea = [ViewFrame]++rectangleToUpdateState :: Rectangle -> UpdateState+rectangleToUpdateState frame+	= UpdateState {oldFrame=frame,newFrame=frame,updArea=[frame]}+++-- | viewDomainRange defines the minimum and maximum values for ViewDomains+viewDomainRange :: ViewDomain+viewDomainRange+	= Rectangle+		{ corner1 = Point2 {x = -1073741824,y = -1073741824}+		, corner2 = Point2 {x =  1073741824,y =  1073741824}+		}++-- | viewFrameRange defines the minimum and maximum values for ViewFrames.+viewFrameRange :: ViewFrame+viewFrameRange+	= Rectangle+		{ corner1 = Point2 {x = 2147483647,y = 2147483647}+		, corner2 = Point2 {x = 2147483647,y = 2147483647}+		}+++-- | Modifiers indicates the meta keys that have been pressed (True) or not (False).+data	Modifiers+	= Modifiers+		{ shiftDown	:: !Bool			-- ^ True iff shift   down+		, optionDown	:: !Bool			-- ^ True iff option  down+		, commandDown	:: !Bool			-- ^ True iff command down+		, controlDown	:: !Bool			-- ^ True iff control down+		, altDown	:: !Bool			-- ^ True iff alt     down+		}+	deriving (Eq,Show)+++--	Constants to check which of the Modifiers are down.++noModifiers = Modifiers {shiftDown = False, optionDown = False, commandDown = False, controlDown = False, altDown = False}+shiftOnly   = Modifiers {shiftDown = True,  optionDown = False, commandDown = False, controlDown = False, altDown = False}+optionOnly  = Modifiers {shiftDown = False, optionDown = True,  commandDown = False, controlDown = False, altDown = True }+commandOnly = Modifiers {shiftDown = False, optionDown = False, commandDown = True,  controlDown = True,  altDown = False}+controlOnly = Modifiers {shiftDown = False, optionDown = False, commandDown = True,  controlDown = True,  altDown = False}+altOnly     = Modifiers {shiftDown = False, optionDown = True,  commandDown = False, controlDown = False, altDown = True }+++-- | 	The layout language used for windows and controls.	-}+type	ItemPos+	=	( ItemLoc+		, ItemOffset+		)+data	ItemLoc+ --	Absolute:+	= Fix+ --	Relative to corner:+	| LeftTop+	| RightTop+	| LeftBottom+	| RightBottom+ --	Relative in next line:+	| Left+	| Center+	| Right+ --	Relative to other item:+	| LeftOf  Id+	| RightTo Id+	| Above   Id+	| Below   Id+ --	Relative to previous item:+	| LeftOfPrev+	| RightToPrev+	| AbovePrev+	| BelowPrev+	deriving (Eq,Show)+type	ItemOffset+	= Vector2						-- A constant offset vector+	+	+{-	The Direction type.					-}++data	Direction+	= Horizontal+	| Vertical+	deriving Eq++{-	The CursorShape type.					-}++data	CursorShape+	= StandardCursor+	| BusyCursor+	| IBeamCursor+	| CrossCursor+	| FatCrossCursor+	| ArrowCursor+	| HiddenCursor+	deriving Eq++-- | The document interface type of interactive processes.+data	DocumentInterface+	= NDI				-- ^ No document interface+	| SDI				-- ^ Single document interface+	| MDI				-- ^ Multiple document interface+	deriving (Eq,Show)++data	SliderMove+	= SliderIncSmall+	| SliderDecSmall+	| SliderIncLarge+	| SliderDecLarge+	| SliderThumb Int+	deriving Show+++-- | Common error report type.+data	ErrorReport						-- Usual cause:	+	= ErrorViolateDI					-- ^ Violation against DocumentInterface+	| ErrorIdsInUse						-- ^ Object contains Ids that are bound+	| ErrorUnknownObject					-- ^ Object can not be found+	| ErrorNotifierOpen					-- ^ It was tried to open a second send notifier+	| ErrorUnableReceiver					-- ^ Sending to receiver that exists, but its ReceiverSelectState is Unable. +	| OtherError !String					-- ^ Some other kind of error+	deriving (Eq,Show)++{-# NOINLINE errTy #-}+errTy = mkTyConApp (mkTyCon "ErrorReport") []++instance Typeable ErrorReport where+	typeOf _ = errTy++handleErrorReport :: Monad m => ErrorReport -> m a+handleErrorReport ErrorViolateDI = fail "Object I/O: Violation against DocumentInterface"+handleErrorReport ErrorIdsInUse	= fail "Object I/O: Object contains Ids that are bound"+handleErrorReport ErrorUnknownObject = fail "Object I/O: Object can not be found"+handleErrorReport ErrorNotifierOpen = fail "Object I/O: It was tried to open a second send notifier"+handleErrorReport ErrorUnableReceiver = fail "Object I/O: unable receiver"+handleErrorReport (OtherError msg) = fail ("Object I/O: " ++ msg)
+ Graphics/UI/ObjectIO/StdId.hs view
@@ -0,0 +1,72 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdId+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdId specifies the generation functions for identification values.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdId+		( openId,  openRId,  openR2Id+	     	, openIds, openRIds, openR2Ids+             	, getParentId+             	, Graphics.UI.ObjectIO.Id.Id+             	) where+++import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.StdIOBasic(IOMonad(..))+import Graphics.UI.ObjectIO.Process.IOState(GUI(..),ioStGetIdTable)+import Data.Maybe+import Data.Unique+import Data.IORef+import qualified Data.Map as Map+import System.IO.Unsafe++------------+------------++-- | The openId function generates one new id+openId  :: IOMonad m => m Id+openId  = liftIO (fmap toId newUnique)++-- | The openIds function returns a list of N new items i.e. [id1, id2..idN]+openIds   :: IOMonad m => Int -> m [Id]+openIds n = sequence (replicate n openId)++-- | The openRId function is the same as openId but they return +-- special bi-receiver id (see "Graphics.UI.ObjectIO.StdReceiver").+openR2Id  :: IOMonad m => m (R2Id msg resp)+openR2Id  = liftIO $ do+	u   <- newUnique+	cIn  <- newIORef undefined+	cOut <- newIORef undefined+	return (toR2Id u cIn cOut)++-- | The openR2Ids function returns a list of N new bi-receiver ids i.e. [rId1, rId2..rIdN]+openR2Ids :: IOMonad m => Int -> m [R2Id msg resp]+openR2Ids n = sequence (replicate n openR2Id)++-- | The openRId function is the same as openId but they return +-- special bi-receiver id (see "Graphics.UI.ObjectIO.StdReceiver").+openRId  :: IOMonad m => m (RId msg)	+openRId = liftIO $ do+	u   <- newUnique+	cIn  <- newIORef []+	return (toRId u cIn)++-- | The openRIds function returns a list of N new receiver ids i.e. [rId1, rId2..rIdN]+openRIds :: IOMonad m => Int -> m [RId msg]+openRIds n = sequence (replicate n openRId)++-- | The getParentId function retrieves an id of the specified window\'s parent.+getParentId :: Id -> GUI ps (Maybe Id)+getParentId id = do+	it <- ioStGetIdTable+	return (fmap idpId (Map.lookup id it))
+ Graphics/UI/ObjectIO/StdKey.hs view
@@ -0,0 +1,39 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdKey+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdKey defines the special keys for the Object I\/O library.+-- Keyboard event handlers receive 'KeyboardState' as a parameter.+-- When the special key (like F1, F2, PgUp, PgDn and other) is pressed, then +-- the 'KeyboardState' contains a value of 'SpecialKey' type. Here is a list+-- of all predefined values.+--+-----------------------------------------------------------------------------++++module Graphics.UI.ObjectIO.StdKey+              (	SpecialKey, +		backSpaceKey, beginKey, +		clearKey, +		deleteKey, downKey, +		endKey, enterKey, escapeKey, +		f1Key,  f2Key,  f3Key,  f4Key,  f5Key,  +		f6Key,  f7Key,  f8Key,  f9Key,  f10Key,+		f11Key, f12Key, f13Key, f14Key, f15Key, +		helpKey, +		leftKey, +		pgDownKey, pgUpKey, +		rightKey, +		upKey+              ) where++++import Graphics.UI.ObjectIO.Key hiding (toSpecialKey, isSpecialKey)
+ Graphics/UI/ObjectIO/StdMenu.hs view
@@ -0,0 +1,415 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdMenu+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdMenu defines functions on menus.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdMenu+		(+		-- * Opening a menu.+		  Menus(..),+		  +		-- * Closing a menu.+	      	  closeMenu,+	      	  +	      	-- * Enabling and disabling of the MenuSystem+	      	  enableMenuSystem+	      	, disableMenuSystem,+	      	+	      	-- * Enabling and disabling of Menus+	      	  enableMenus+	      	, disableMenus,+	      	+	      	-- * Get the 'SelectState' of a menu+	      	  getMenuSelectState,+	      	  +	      	-- * Adding menu elements to (sub\/radio)menus+	      	  openMenuElements+	      	, openSubMenuElements+	      	, openRadioMenuItems,+	      	+	      	-- * Removing menu elements from (sub\/radio)menus+	      	  closeMenuElements+	      	, closeMenuIndexElements+	      	, closeSubMenuIndexElements+	      	, closeRadioMenuIndexElements,+	      	+	      	-- * Determine the Ids of all menus.+	      	  getMenus,+	      	  +	      	-- * Determine the index position of a menu.+	      	  getMenuPos,+	      	  +	      	-- * Set and get the title of a menu.+	      	  setMenuTitle+	      	, getMenuTitle,+	      	+	      	-- * A visible module+	      	  module Graphics.UI.ObjectIO.StdMenuDef) where++++import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.Process.IOState+import	Graphics.UI.ObjectIO.Id+import	Graphics.UI.ObjectIO.StdId(openId)+import	Graphics.UI.ObjectIO.Menu.Create+import	Graphics.UI.ObjectIO.Menu.Device+import qualified Graphics.UI.ObjectIO.Menu.Internal as I+import	Graphics.UI.ObjectIO.Menu.Handle+import	Graphics.UI.ObjectIO.Menu.Items+import  Graphics.UI.ObjectIO.StdMenuElementClass+import  Graphics.UI.ObjectIO.StdMenuDef+import	Graphics.UI.ObjectIO.Device.SystemState(windowSystemStateGetWindowHandles)+import	Graphics.UI.ObjectIO.Menu.Access(menuStateHandleGetMenuId, menuStateHandleGetSelect, menuStateHandleGetTitle, menuStateHandleGetHandle)+import	Graphics.UI.ObjectIO.Menu.DefAccess(menuDefGetMenuId)+import	Graphics.UI.ObjectIO.Device.SystemState(menuSystemStateGetMenuHandles)+import	Graphics.UI.ObjectIO.Window.Access(getWindowHandlesActiveModalDialog)+import  Graphics.UI.ObjectIO.OS.Menu(osTrackPopUpMenu, osEnableMenu, osDisableMenu)+import	Graphics.UI.ObjectIO.OS.MenuEvent(menuHandlesGetMenuStateHandles)+import  Control.Monad(unless)+import  qualified Data.Map as Map++stdMenuFatalError :: String -> String -> x+stdMenuFatalError function error =+	dumpFatalError function "StdMenu" error+++--	General rules to access MenuHandles:+++accessMenuHandles :: Id -> (MenuStateHandle ps -> x) -> GUI ps (Maybe x)+accessMenuHandles id f = do+	(found,mDevice)	<- accIOEnv (ioStGetDevice MenuDevice)+	(if not found then return Nothing+	 else do return (accessmenuhandles id f (mMenus (menuSystemStateGetMenuHandles mDevice))))+	where+		accessmenuhandles :: Id -> (MenuStateHandle ps -> x) -> [MenuStateHandle ps] -> Maybe x+		accessmenuhandles id f [] = Nothing+		accessmenuhandles id f (mH:mHs)+			| id==menuStateHandleGetMenuId mH = Just (f mH)+			| otherwise = accessmenuhandles id f mHs+++--	Opening a menu for an interactive process.++class Menus mdef where+	openMenu :: ls -> mdef ls ps -> ps -> GUI ps ps++instance MenuElements m => Menus (Menu m) where	+	openMenu ls mDef ps = do+		ps <- dOpen menuFunctions ps+		isZero <- checkZeroMenuBound+		(if isZero then throwGUI ErrorViolateDI+		 else do+			optMenuId <- validateMenuId (menuDefGetMenuId mDef)+			(case optMenuId of+				Just menuId -> openMenu' menuId ls mDef ps+				_ 	    -> throwGUI ErrorIdsInUse))+		where+			checkZeroMenuBound :: GUI ps Bool+			checkZeroMenuBound = do+				(found,mDevice) <- accIOEnv (ioStGetDevice MenuDevice)+				(if not found+				 then stdMenuFatalError "openMenu (Menu)" "could not retrieve MenuSystemState from IOSt"+				 else return (zeroBound (mNrMenuBound (menuSystemStateGetMenuHandles mDevice))))++			validateMenuId :: Maybe Id -> GUI ps (Maybe Id)+			validateMenuId Nothing = do+				mId <- openId+				return (Just mId)+			validateMenuId (Just id) = do+				idtable <- ioStGetIdTable+				return (if Map.member id idtable then Nothing else Just id)++instance PopUpMenuElements m => Menus (PopUpMenu m) where+	openMenu ls mDef ps = do+		osdInfo <- accIOEnv ioStGetOSDInfo+		(if getOSDInfoDocumentInterface osdInfo==NDI+		 then throwGUI ErrorViolateDI+		 else case getOSDInfoOSMenuBar osdInfo of+			Nothing -> stdMenuFatalError "openMenu (PopUpMen)" "OSMenuBar could not be retrieved from OSDInfo"+			Just osMenuBar -> do+				ps <- dOpen menuFunctions ps+				(found,mDevice)	<- accIOEnv (ioStGetDevice MenuDevice)+				(if not found then throwGUI ErrorUnknownObject+				 else let +					 mHs  = menuSystemStateGetMenuHandles mDevice+		  			 mHs1 = closePopUpMenu mHs+		  		      in do+		  		     		it <- ioStGetIdTable						+						ioid <- accIOEnv ioStGetIOId+						(ok,mHs2,it) <- createPopUpMenu ioid ls mDef mHs1 it osMenuBar+						ioStSetIdTable it+						appIOEnv (ioStSetDevice (MenuSystemState mHs2))		+						(if ok then handlePopUpMenu ps+						 else throwGUI ErrorIdsInUse)))+		where+		--	handlePopUpMenu opens the pop up menu.+			handlePopUpMenu :: ps -> GUI ps ps+			handlePopUpMenu ps = do+				osdInfo <- accIOEnv ioStGetOSDInfo+				let framePtr = case getOSDInfoOSInfo osdInfo of+					Just info -> osFrame info+					Nothing   -> stdMenuFatalError "openMenu (PopUpMenu)" "incorrect OSDInfo retrieved"+				(found,mDevice)	<- accIOEnv (ioStGetDevice MenuDevice)+				unless found (stdMenuFatalError "openMenu (PopUpMenu)" "could not retrieve MenuSystemState from IOSt")+				let mHs	= menuSystemStateGetMenuHandles mDevice+				let ((popUpMenu:menus),mHs1) = menuHandlesGetMenuStateHandles mHs				+				let popUpId = menuStateHandleGetMenuId popUpMenu+				let mPtr = menuStateHandleGetHandle popUpMenu+				ok <- liftIO (osTrackPopUpMenu mPtr framePtr)+				(if not ok+				 then do+					appIOEnv (ioStSetDevice (MenuSystemState mHs1{mMenus=menus,mPopUpId=Just popUpId}))+					throwGUI (OtherError "PopUpMenu tracking error")+				 else do+					appIOEnv (ioStSetDevice (MenuSystemState mHs1{mMenus=popUpMenu:menus}))+					return ps)++++--	Closing a menu.++-- | The function closes the specified menu.+closeMenu :: Id -> GUI ps ()+closeMenu id = I.closeMenu id++checkIdParent :: IdParent -> SystemId -> Bool+checkIdParent parent ioId = idpDevice parent==MenuDevice && idpIOId parent==ioId+++--	Enabling and Disabling of the MenuSystem:++-- | The function enables interaction with menu device.+-- Enabling of the menu device doesn\'t affect the select+-- state of the individual menus.+enableMenuSystem :: GUI ps ()+enableMenuSystem = do+	isModal <- hasModalDialog+	di <- accIOEnv ioStGetDocumentInterface+	(if isModal || di==NDI then return ()+	 else I.changeMenuSystemState True (enableMenuSystem' di))+	where+		hasModalDialog :: GUI ps Bool+		hasModalDialog = do+			(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+			let windows	= windowSystemStateGetWindowHandles wDevice+			return (found && isJust (getWindowHandlesActiveModalDialog windows))++		enableMenuSystem' :: DocumentInterface -> OSMenuBar -> MenuHandles ps -> IO (MenuHandles ps)+		enableMenuSystem' di osMenuBar menus@(MenuHandles {mEnabled=mEnabled,mMenus=mMenus})+			| mEnabled = return menus+			| otherwise = do+				enableMenus mMenus osMenuBar+				return (menus{mEnabled=systemAble})+			where+				enableMenus :: [MenuStateHandle ps] -> OSMenuBar -> IO ()+				enableMenus [] osMenuBar = return ()+				enableMenus ((MenuStateHandle (MenuLSHandle {mlsHandle=m})):ms) osMenuBar = do+					osEnableMenu (mHandle m) osMenuBar+					enableMenus ms osMenuBar+						++-- | The function disables interaction with menu device.+-- Disabling of the menu device doesn\'t affect the select+-- state of the individual menus.+disableMenuSystem :: GUI ps ()+disableMenuSystem = do	+	di <- accIOEnv ioStGetDocumentInterface+	(if di==NDI then return ()+	 else I.changeMenuSystemState True (disableMenuSystem' di))+	where+		disableMenuSystem' :: DocumentInterface -> OSMenuBar -> MenuHandles ps -> IO (MenuHandles ps)+		disableMenuSystem' di osMenuBar menus@(MenuHandles {mEnabled=mEnabled,mMenus=mMenus})+			| mEnabled = return menus+			| otherwise = do+				disableMenus mMenus osMenuBar+				return (menus{mEnabled=systemUnable})+			where+				disableMenus :: [MenuStateHandle ps] -> OSMenuBar -> IO ()+				disableMenus [] osMenuBar = return ()+				disableMenus ((MenuStateHandle (MenuLSHandle {mlsHandle=m})):ms) osMenuBar = do+					osDisableMenu (mHandle m) osMenuBar+					disableMenus ms osMenuBar++--	Enabling and Disabling of Menus:++-- | The function enables the menus with the specified Ids.+-- When the menu and the corresponding menu device are both enabled+-- then the user can use the menu.+enableMenus :: [Id] -> GUI ps ()+enableMenus []  = return ()+enableMenus ids = I.enableMenus ids++-- | The function disables the menus with the specified Ids.+-- When the menu or the corresponding menu device are disabled+-- then the user cann\'t use the menu.+disableMenus :: [Id] -> GUI ps ()+disableMenus []  = return ()+disableMenus ids = I.disableMenus ids+++--	Get the SelectState of a menu: ++getMenuSelectState :: Id -> GUI ps (Maybe SelectState)+getMenuSelectState id = do+	optSelect <- accessMenuHandles id menuStateHandleGetSelect+	return (fmap (\sel -> if sel then Able else Unable) optSelect)+++{-	Adding menu elements to (sub/radio)menus:+		Items in a (sub/radio)menu are positioned starting from 1 and increasing by 1.+		Open with a position less than 1 adds the new elements in front+		Open with a position higher than the number of items adds the new elements to+		the end.+		Open an item on a position adds the item AFTER the item on that position.+-}++-- | dynamically creates additional elements to the specified menu.+openMenuElements :: MenuElements m => Id -> Index -> ls -> m ls ps -> GUI ps ()+openMenuElements mId pos ls new = do+	it   <- ioStGetIdTable+	ioId <- accIOEnv ioStGetIOId+	(case Map.lookup mId it of+		Just parent | checkIdParent parent ioId && idpId parent == mId -> do+			(found,mDevice) <- accIOEnv (ioStGetDevice MenuDevice)+			unless found (throwGUI ErrorUnknownObject)+			osdInfo <- accIOEnv ioStGetOSDInfo+			(case getOSDInfoOSMenuBar osdInfo of+				Nothing -> stdMenuFatalError "openMenuElements" "OSMenuBar could not be retrieved from OSDInfo"+				Just osMenuBar -> do+					let menus = menuSystemStateGetMenuHandles mDevice+					(it,menus) <- addMenusItems (mId,Nothing) (max 0 pos) ls new ioId it menus osMenuBar					+					appIOEnv (ioStSetDevice (MenuSystemState menus))+					ioStSetIdTable it					+					return ())+	  	_ -> throwGUI ErrorUnknownObject)+	++-- | dynamically creates additional elements to the specified sub menu (here the Id is an Id of the sub menu).	+openSubMenuElements :: MenuElements m => Id -> Index -> ls -> m ls ps -> GUI ps ()+openSubMenuElements sId pos ls new = do+	it   <- ioStGetIdTable+	ioId <- accIOEnv ioStGetIOId+	(case Map.lookup sId it of+		Just parent | checkIdParent parent ioId -> do+			(found,mDevice) <- accIOEnv (ioStGetDevice MenuDevice)+			unless found (throwGUI ErrorUnknownObject)+			osdInfo <- accIOEnv ioStGetOSDInfo+			(case getOSDInfoOSMenuBar osdInfo of+				Nothing -> stdMenuFatalError "openSubMenuElements" "OSMenuBar could not be retrieved from OSDInfo"+				Just osMenuBar -> do					+					let menus = menuSystemStateGetMenuHandles mDevice					+					(it,menus) <- addMenusItems (idpId parent,Just sId) (max 0 pos) ls new ioId it menus osMenuBar+					appIOEnv (ioStSetDevice (MenuSystemState menus))+					ioStSetIdTable it					+					return ())+		_ -> throwGUI ErrorUnknownObject)+	++-- | dynamically creates additional radio menu elements.+openRadioMenuItems :: Id -> Index -> [MenuRadioItem ps ps] -> GUI ps ()+openRadioMenuItems rId pos radioItems = do+	idtable <- ioStGetIdTable+	ioId <- accIOEnv ioStGetIOId+	(case Map.lookup rId idtable of+		Just parent | checkIdParent parent ioId ->+			if null radioItems then return ()+			else+				let radioIds = filterMap (\(_,maybeId,_,_)->(isJust maybeId,fromJust maybeId)) radioItems+				in if not (okMembersIdTable radioIds idtable)+				   then throwGUI ErrorIdsInUse+				   else do+					   let mId	= idpId parent+					   I.changeMenuSystemState True (addMenuRadioItems (mId,rId) (max 0 pos) radioItems)+					   let  insMap id tbl = Map.insert id IdParent{idpIOId=ioId,idpDevice=MenuDevice,idpId=mId} tbl+					        idtable1 = foldr insMap idtable radioIds+					   ioStSetIdTable idtable1+		_ 	-> throwGUI ErrorUnknownObject)++--	Removing menu elements from (sub/radio)menus:++-- | closes the elements with specified Ids from the specified menu.+closeMenuElements :: Id -> [Id] -> GUI ps ()+closeMenuElements mId []  = return ()+closeMenuElements mId ids = I.closeMenuElements mId ids++--	Removing menu elements from (sub/radio)menus by index (counting from 1):++-- | closes the elements with specified indexes from the specified menu.+closeMenuIndexElements :: Id -> [Index] -> GUI ps ()+closeMenuIndexElements mId indices = do+	idtable <- ioStGetIdTable+	ioId <- accIOEnv ioStGetIOId+	(case Map.lookup mId idtable of+		Just parent | checkIdParent parent ioId ->+			I.closeMenuIndexElements False ioId (mId,Nothing) indices+		_ -> return ())++-- | closes the elements with specified indexes from the specified sub menu.+closeSubMenuIndexElements :: Id -> [Index] -> GUI ps ()+closeSubMenuIndexElements sId indices = do+	idtable <- ioStGetIdTable+	ioId <- accIOEnv ioStGetIOId+	(case Map.lookup sId idtable of+		Just parent | checkIdParent parent ioId ->+			I.closeMenuIndexElements False ioId (idpId parent,Just sId) indices+		_ -> return ())+++-- | closes the radio menu elements with specified indexes from the specified menu.+closeRadioMenuIndexElements :: Id -> [Index] -> GUI ps ()+closeRadioMenuIndexElements rId indices = do+	idtable <- ioStGetIdTable+	ioId <- accIOEnv ioStGetIOId+	(case Map.lookup rId idtable of+		Just parent | checkIdParent parent ioId ->+			I.closeMenuIndexElements True ioId (idpId parent,Just rId) indices+		_ -> return ())++--	Determine the Ids of all menus.++-- | returns the list of ids of all existing menus for the current process.+getMenus :: GUI ps [Id]+getMenus = do+	(found,mDevice)	<- accIOEnv (ioStGetDevice MenuDevice)+	(if not found then return []+	 else let mHs	= menuSystemStateGetMenuHandles mDevice+	      in return (map menuStateHandleGetMenuId (mMenus mHs)))+++--	Determine the index position of a menu.++-- | returns the menu item index from the item Id.+getMenuPos :: Id -> GUI ps (Maybe Index)+getMenuPos id = do+	(found,mDevice)	<- accIOEnv (ioStGetDevice MenuDevice)+	(if not found then return Nothing+	 else let mHs	= menuSystemStateGetMenuHandles mDevice+	      in return (getMenuIndex id 0 (mMenus mHs)))+	where+		getMenuIndex :: Id -> Int -> [MenuStateHandle ps] -> Maybe Int+		getMenuIndex id index (mH:mHs)+			| id==menuStateHandleGetMenuId mH = Just index+			| otherwise = getMenuIndex id (index+1) mHs+		getmenuindex _ _ _ = Nothing+++--	Set & Get the title of a menu.++-- | sets the menu title.+setMenuTitle :: Id -> Title -> GUI ps ()+setMenuTitle id title = I.setMenuTitle id title++-- | returns the menu title.+getMenuTitle :: Id -> GUI ps (Maybe Title)+getMenuTitle id = accessMenuHandles id menuStateHandleGetTitle
+ Graphics/UI/ObjectIO/StdMenuAttribute.hs view
@@ -0,0 +1,106 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdMenuAttribute+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdMenuAttribute specifies which MenuAttributes are valid for each of the+-- standard menus and menu elements.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdMenuAttribute+		( module Graphics.UI.ObjectIO.StdMenuAttribute+		, module Graphics.UI.ObjectIO.StdMenuDef+		) where+++import Graphics.UI.ObjectIO.StdMenuDef+import Graphics.UI.ObjectIO.Id++isValidMenuAttribute :: MenuAttribute ls ps -> Bool+isValidMenuAttribute (MenuId          _)	= True+isValidMenuAttribute (MenuIndex       _)	= True+isValidMenuAttribute (MenuInit        _)	= True+isValidMenuAttribute (MenuSelectState _)	= True+isValidMenuAttribute _				= False++isValidSubMenuAttribute :: MenuAttribute ls ps -> Bool+isValidSubMenuAttribute (MenuId          _)	= True+isValidSubMenuAttribute (MenuSelectState _)	= True+isValidSubMenuAttribute _			= False++isValidRadioMenuAttribute :: MenuAttribute ls ps -> Bool+isValidRadioMenuAttribute (MenuId          _)	= True+isValidRadioMenuAttribute (MenuSelectState _)	= True+isValidRadioMenuAttribute _			= False++isValidMenuItemAttribute :: MenuAttribute ls ps -> Bool+isValidMenuItemAttribute (MenuIndex _)	= False+isValidMenuItemAttribute (MenuInit  _)	= False+isValidMenuItemAttribute _		= True++isValidMenuSeparatorAttribute :: MenuAttribute ls ps -> Bool+isValidMenuSeparatorAttribute (MenuId _)	= True+isValidMenuSeparatorAttribute _			= False++isMenuFunction	:: MenuAttribute ls ps -> Bool+isMenuFunction	(MenuFunction _)	= True+isMenuFunction	_			= False++isMenuId :: MenuAttribute ls ps -> Bool+isMenuId (MenuId _)	= True+isMenuId _		= False++isMenuIndex :: MenuAttribute ls ps -> Bool+isMenuIndex (MenuIndex _)	= True+isMenuIndex _			= False++isMenuInit :: MenuAttribute ls ps -> Bool+isMenuInit (MenuInit _)	= True+isMenuInit _		= False++isMenuMarkState	:: MenuAttribute ls ps -> Bool+isMenuMarkState	(MenuMarkState _)	= True+isMenuMarkState	_			= False++isMenuModsFunction :: MenuAttribute ls ps -> Bool+isMenuModsFunction (MenuModsFunction _)	= True+isMenuModsFunction _			= False++isMenuSelectState :: MenuAttribute ls ps -> Bool+isMenuSelectState (MenuSelectState _)	= True+isMenuSelectState _			= False++isMenuShortKey :: MenuAttribute ls ps -> Bool+isMenuShortKey (MenuShortKey _)		= True+isMenuShortKey _			= False+++getMenuFun :: MenuAttribute ls ps -> GUIFun ls ps+getMenuFun (MenuFunction f) = f++getMenuIdAtt :: MenuAttribute ls ps -> Id+getMenuIdAtt (MenuId id) = id++getMenuIndexAtt :: MenuAttribute ls ps -> Index+getMenuIndexAtt (MenuIndex index) = index++getMenuInitFun :: MenuAttribute ls ps -> ps -> GUI ps ps+getMenuInitFun (MenuInit f) = f++getMenuMarkStateAtt :: MenuAttribute ls ps -> MarkState+getMenuMarkStateAtt (MenuMarkState mark) = mark++getMenuModsFun :: MenuAttribute ls ps -> ModifiersFunction ls ps+getMenuModsFun (MenuModsFunction f) = f++getMenuSelectStateAtt :: MenuAttribute ls ps -> SelectState+getMenuSelectStateAtt (MenuSelectState select) = select++getMenuShortKeyAtt :: MenuAttribute ls ps -> Char+getMenuShortKeyAtt (MenuShortKey key) = key
+ Graphics/UI/ObjectIO/StdMenuDef.hs view
@@ -0,0 +1,79 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdMenuDef+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Definition of Menus and MenuElements:+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdMenuDef +		(+		-- * Menus+		  Menu(..), PopUpMenu(..),+		  +		-- * Menu items+		  MenuItem(..), MenuSeparator(..)+		, RadioMenu(..), MenuRadioItem(..)+		, SubMenu(..),+		+		-- * Menu attributes+		  MenuAttribute(..),+		  +		-- * A visible modules+		  module Graphics.UI.ObjectIO.StdGUI +		, module Graphics.UI.ObjectIO.StdIOCommon+		) where+++import  Graphics.UI.ObjectIO.StdGUI+import	Graphics.UI.ObjectIO.StdIOCommon+++--	Menus:++-- | The standard menus that are usually placed at the top of the process window and+-- can be selected at any time+data	Menu        m ls ps = Menu        Title         (m ls ps)        [MenuAttribute ls ps]++-- | The popup menus can be created and shown at any time as a response to+-- any other event (usually to the click of the right mouse button).+data	PopUpMenu   m ls ps = PopUpMenu                 (m ls ps)+++--	Menu elements:++-- | The simple menu item is just an item with a specified title and an event handler+-- which is called when the item is clicked+data	MenuItem      ls ps = MenuItem    Title                       	   [MenuAttribute ls ps]++-- | The menu separator is nonselectable item which can be used to+-- separate menu items in different groups+data	MenuSeparator ls ps = MenuSeparator                           	   [MenuAttribute ls ps]++-- | The radio menu is a group of items which can be used as 'RadioControl'+data	RadioMenu     ls ps = RadioMenu   [MenuRadioItem (ls,ps) ps] Index [MenuAttribute ls ps]++-- | The sub menu item is an item which shows a sub menu when the user selects it.+data	SubMenu     m ls ps = SubMenu     Title        (m ls ps)       	   [MenuAttribute ls ps]++type	MenuRadioItem st ps = (Title,Maybe Id,Maybe Char,st -> GUI ps st)++data	MenuAttribute ls ps							-- Default:+ --	Attributes for Menus and MenuElements:+	=	MenuId			Id					-- no Id+	|	MenuSelectState		SelectState				-- menu(item) Able+ --	Attributes only for Menus:+	|	MenuIndex		Int					-- at the end of the current menu list+	|	MenuInit		(ps -> GUI ps ps)			-- no actions after opening menu+ --	Attributes ignored by (Sub)Menus:+	|	MenuFunction		(GUIFun ls ps)				-- return+	|	MenuMarkState		MarkState				-- NoMark+	|	MenuModsFunction	(ModifiersFunction ls ps)		-- MenuFunction+	|	MenuShortKey		Char					-- no ShortKey+
+ Graphics/UI/ObjectIO/StdMenuElement.hs view
@@ -0,0 +1,496 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdMenuElement+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdMenuElement specifies all functions on menu elements.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdMenuElement+		( +		-- * Enabling and disabling of menu elements+		  enableMenuElements, disableMenuElements+		, getMenuElementSelectStates, getMenuElementSelectState,+		-- * Marking and unmarking of MenuItems only+		  markMenuItems, unmarkMenuItems+		, getMenuElementMarkStates, getMenuElementMarkState, +		-- * Changing the title of menu elements:+		  setMenuElementTitles, getMenuElementTitles+		, getMenuElementTitle,+		-- * Item selection+		  selectRadioMenuItem, selectRadioMenuIndexItem+		, getSelectedRadioMenuItems, getSelectedRadioMenuItem,+		-- * Short keys+		  getMenuElementShortKeys+		, getMenuElementShortKey+		) where+++import	Graphics.UI.ObjectIO.Id+import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.Process.IOState+import	Graphics.UI.ObjectIO.Menu.Access(menuStateHandleGetMenuId)+import	Graphics.UI.ObjectIO.Menu.Handle+import	Graphics.UI.ObjectIO.Device.SystemState(menuSystemStateGetMenuHandles)+import	Graphics.UI.ObjectIO.OS.Menu(drawMenuBar, osEnableMenuItem, osDisableMenuItem, osChangeMenuItemTitle, osMenuItemCheck)+import	Graphics.UI.ObjectIO.OS.Types(OSMenu)+import  Control.Monad(when)+import  Data.Char(toUpper)+import  qualified Data.Map as Map+++stdMenuElementFatalError :: String -> String -> x+stdMenuElementFatalError function error = dumpFatalError function "StdMenuElement" error+++--	The function isOkMenuElementId can be used to filter out the proper IdParent records.++isOkMenuElementId :: SystemId -> (x,Maybe IdParent) -> (Bool,(x,Id))+isOkMenuElementId ioId (x,Just (IdParent {idpIOId=idpIOId,idpDevice=idpDevice,idpId=idpId})) =+	(ioId==idpIOId && idpDevice==MenuDevice,(x,idpId))+isOkMenuElementId _ _ = (False,undefined)+++--	Enabling and Disabling of menu elements:++enableMenuElements :: [Id] -> GUI ps ()+enableMenuElements ids = do+	it <- ioStGetIdTable+	ioId <- accIOEnv ioStGetIOId+	let ids_mIds  = filterMap (isOkMenuElementId ioId) (map (\id -> (id,Map.lookup id it)) ids)+	let ids_mIds1 = gather ids_mIds+	(if null ids_mIds1 then return ()+	 else sequence [setMenu mId recurseAll setItemAbility (map (\id->(id,True)) ids) | (ids,mId)<-ids_mIds1] >> return ())++disableMenuElements :: [Id] -> GUI ps ()+disableMenuElements ids = do+	it <- ioStGetIdTable+	ioId <- accIOEnv ioStGetIOId+	let ids_mIds  = filterMap (isOkMenuElementId ioId) (map (\id -> (id,Map.lookup id it)) ids)+	let ids_mIds1 = gather ids_mIds+	(if null ids_mIds1 then return ()+	 else sequence [setMenu mId recurseAll setItemAbility (map (\id->(id,False)) ids) | (ids,mId)<-ids_mIds1] >> return ())+++setItemAbility :: Bool -> OSMenu -> Int -> MenuElementHandle ls ps -> IO (MenuElementHandle ls ps)++setItemAbility enabled menu itemNr itemH@(SubMenuHandle {mSubHandle=mSubHandle})+	| enabled	= osEnableMenuItem  menu mSubHandle >> return submenu+	| otherwise	= osDisableMenuItem menu mSubHandle >> return submenu+	where+		submenu		= itemH{mSubSelect=enabled}++setItemAbility enabled menu itemNr itemH@(RadioMenuHandle {mRadioItems=mRadioItems})+	| enabled	= enableAbleItems menu mRadioItems itemNr >> return radiomenu+	| otherwise	= disableAllItems menu mRadioItems itemNr >> return radiomenu+	where+		radiomenu = itemH{mRadioSelect=enabled}++		enableAbleItems :: OSMenu -> [MenuElementHandle ls ps] -> Int -> IO ()+		enableAbleItems menu (itemH:itemHs) itemNr = do+			enableAbleItems menu itemHs (itemNr+1)+			when (mItemSelect itemH) (osEnableMenuItem menu (mOSMenuItem itemH))+		enableAbleItems _ [] _ = return ()++		disableAllItems :: OSMenu -> [MenuElementHandle ls ps] -> Int -> IO ()+		disableAllItems menu itemHs itemNr =+			mapM_ (\itemH -> osDisableMenuItem menu (mOSMenuItem itemH)) itemHs++setItemAbility enabled menu itemNr itemH@(MenuItemHandle {mOSMenuItem=mOSMenuItem})+	| enabled	= osEnableMenuItem  menu mOSMenuItem >> return menuitem+	| otherwise	= osDisableMenuItem menu mOSMenuItem >> return menuitem+	where+		menuitem = itemH{mItemSelect=enabled}++setItemAbility _ _ _ itemH = return itemH+++--	Marking and Unmarking of MenuItems only:++markMenuItems :: [Id] -> GUI ps ()+markMenuItems ids = do+	it <- ioStGetIdTable+	ioId <- accIOEnv ioStGetIOId+	let ids_mIds = filterMap (isOkMenuElementId ioId) (map (\id -> (id,Map.lookup id it)) ids)+	let ids_mIds1 = gather ids_mIds+	(if null ids_mIds1 then return ()+	 else sequence [setMenu mId recurseSubMenuOnly setItemMark (map (\id->(id,True)) ids) | (ids,mId)<-ids_mIds1] >> return ())++unmarkMenuItems :: [Id] -> GUI ps ()+unmarkMenuItems ids = do+	it <- ioStGetIdTable+	ioId <- accIOEnv ioStGetIOId+	let ids_mIds  = filterMap (isOkMenuElementId ioId) (map (\id -> (id,Map.lookup id it)) ids)+	let ids_mIds1 = gather ids_mIds+	(if null ids_mIds1 then return ()+	 else sequence [setMenu mId recurseSubMenuOnly setItemMark (map (\id->(id,False)) ids) | (ids,mId)<-ids_mIds1] >> return ())++setItemMark :: Bool -> OSMenu -> Int -> MenuElementHandle ls ps -> IO (MenuElementHandle ls ps)+setItemMark marked menu itemNr itemH@(MenuItemHandle {}) = do+	osMenuItemCheck marked menu (mOSMenuItem itemH)+	return (itemH{mItemMark=marked})+setItemMark _ _ _ itemH = return itemH+++--	Changing the Title of menu elements:++setMenuElementTitles :: [(Id,Title)] -> GUI ps ()+setMenuElementTitles id_titles = do+	it <- ioStGetIdTable+	ioId <- accIOEnv ioStGetIOId+	let id_titles_mIds  = filterMap (isOkMenuElementId ioId) (map (\id_t@(id,_) -> (id_t,Map.lookup id it)) id_titles)+	let id_titles_mIds1 = gather id_titles_mIds+	(if null id_titles_mIds1 then return ()+	 else sequence [setMenu mId recurseAll setItemTitle id_titles | (id_titles,mId)<-id_titles_mIds1] >> return ())+	where+		setItemTitle :: Title -> OSMenu -> Int -> MenuElementHandle ls ps -> IO (MenuElementHandle ls ps)+		setItemTitle title menu itemNr itemH@(SubMenuHandle {}) = do+			osChangeMenuItemTitle menu (mSubHandle itemH) title+			return (itemH{mSubTitle=title})+		setItemTitle title menu itemNr itemH@(MenuItemHandle {}) = do+			osChangeMenuItemTitle menu (mOSMenuItem itemH) title+			return (itemH{mItemTitle=title})+		setItemTitle _ _ _ itemH = return itemH+++--	Changing the selected menu item of a RadioMenu by its Id:++selectRadioMenuItem :: Id -> Id -> GUI ps ()+selectRadioMenuItem id itemId = do+	it <- ioStGetIdTable+	ioId <- accIOEnv ioStGetIOId+	let maybeParent	= Map.lookup id it+	(if not (fst (isOkMenuElementId ioId (id,maybeParent)))+	 then return ()+	 else setMenu (idpId (fromJust maybeParent)) recurseAll selectradiomenuitem [(id,itemId)])+	where+		selectradiomenuitem :: Id -> OSMenu -> Int -> MenuElementHandle ls ps -> IO (MenuElementHandle ls ps)+		selectradiomenuitem itemId menu itemNr radioH@(RadioMenuHandle {mRadioIndex=now,mRadioItems=itemHs})+			| null itemHs = return radioH+			| otherwise =+				let new	= getRadioMenuItemIndex itemId itemHs 1+				in if new == 0 then return radioH+				   else do+					(itemHs,_) <- stateMapM (setmark menu new) itemHs 1+					return (radioH{mRadioIndex=new,mRadioItems=itemHs})+			where+				getRadioMenuItemIndex :: Id -> [MenuElementHandle ls ps] -> Index -> Index+				getRadioMenuItemIndex id (MenuItemHandle {mItemId=mItemId}:itemHs) index+					| mItemId /= Just id = getRadioMenuItemIndex id itemHs (index+1)+					| otherwise	     = index+				getRadioMenuItemIndex _ [] _ = 0+		selectradiomenuitem _ _ _ itemH = return itemH++setmark :: OSMenu -> Index -> MenuElementHandle ls ps -> Int -> IO (MenuElementHandle ls ps,Int)+setmark menu new itemH@(MenuItemHandle {mOSMenuItem=mOSMenuItem}) index = do+	osMenuItemCheck marked menu mOSMenuItem+	return (itemH{mItemMark=marked},index+1)+	where+		marked	= index==new+++--	Changing the selected menu item of a RadioMenu by its index:++selectRadioMenuIndexItem :: Id -> Index -> GUI ps ()+selectRadioMenuIndexItem id index = do+	it <- ioStGetIdTable+	ioId <- accIOEnv ioStGetIOId+	let maybeParent	= Map.lookup id it+	(if not (fst (isOkMenuElementId ioId (id,maybeParent)))+	 then return ()+	 else setMenu (idpId (fromJust maybeParent)) recurseAll selectradiomenuindexitem [(id,index)])+	where+		selectradiomenuindexitem :: Index -> OSMenu -> Int -> MenuElementHandle ls ps -> IO (MenuElementHandle ls ps)+		selectradiomenuindexitem new menu itemNr radioH@(RadioMenuHandle {mRadioIndex=now,mRadioItems=itemHs})+			| null itemHs = return radioH+			| otherwise =+				let new	= setBetween new 1 (length itemHs)+				in if new==now then return radioH+				   else do+					(items,_) <- stateMapM (setmark menu new) itemHs 1+					return (radioH{mRadioIndex=new,mRadioItems=itemHs})+		selectradiomenuindexitem _ _ _ itemH = return itemH+++--	Now do it!++type ItemChange x = (Id, x)+type Recurse = (Bool, Bool)+type DeltaItemHandle  ps x = forall ls . x -> OSMenu -> Int -> MenuElementHandle ls ps -> IO (MenuElementHandle ls ps)+type AccessItemHandle ps x = forall ls . MenuElementHandle ls ps -> x -> x++recurseAll		= (True, True )+recurseSubMenuOnly	= (True, False)+recurseRadioOnly	= (False,True )+recurseNone		= (False,False)++setMenu :: Id -> Recurse -> DeltaItemHandle ps x -> [ItemChange x] -> GUI ps ()+setMenu menuId recurse f changes = do+	ok <- accIOEnv (ioStHasDevice MenuDevice)+	(if not ok then return ()+	 else do+		osdinfo <- accIOEnv ioStGetOSDInfo+	  	(case getOSDInfoOSMenuBar osdinfo of+	  		Nothing -> stdMenuElementFatalError "setMenu" "OSMenuBar could not be retrieved from OSDInfo"+	  		Just osMenuBar -> do+	  			(found,menus) <- accIOEnv (ioStGetDevice MenuDevice)+				(if not found+				 then stdMenuElementFatalError "setMenu" "MenuSystemState could not be retrieved from IOSt"+				 else let+					  mHs = menuSystemStateGetMenuHandles menus+	  				  (found,msH) = cselect (eqMenuLSHandleId menuId) undefined (mMenus mHs)+	  			      in+					  if not found then return ()+					  else do+		  				msH <- liftIO (changeMenuItems f changes msH)+						liftIO (drawMenuBar osMenuBar)+		  				let (_,msHs) = creplace (eqMenuLSHandleId menuId) msH (mMenus mHs)+						appIOEnv (ioStSetDevice (MenuSystemState mHs{mMenus=msHs})))))+	where+		changeMenuItems :: DeltaItemHandle ps x -> [ItemChange x] -> MenuStateHandle ps -> IO (MenuStateHandle ps)+		changeMenuItems change changes (MenuStateHandle mlsH@(MenuLSHandle {mlsHandle=mH@(MenuHandle {mItems=itemHs})})) = do+			(_,itemHs,_) <- changeMenuItems' (mHandle mH) change changes itemHs 1+			return (MenuStateHandle mlsH{mlsHandle=mH{mItems=itemHs}})+			where+				changeMenuItems' :: OSMenu -> DeltaItemHandle ps x -> [ItemChange x] -> [MenuElementHandle ls ps] -> Int -> IO ([ItemChange x],[MenuElementHandle ls ps],Int)+				changeMenuItems' menu change changes []     itemNr = return (changes,[],itemNr)+				changeMenuItems' menu change changes (h:hs) itemNr+					| null changes = return (changes,(h:hs),itemNr)+					| otherwise    = do+						(changes,h, itemNr) <- changeMenuItem'  menu change changes h  itemNr+						(changes,hs,itemNr) <- changeMenuItems' menu change changes hs itemNr+						return (changes,(h:hs),itemNr)+					where+						changeMenuItem' :: OSMenu -> DeltaItemHandle ps x -> [ItemChange x] -> MenuElementHandle ls ps -> Int -> IO ([ItemChange x],MenuElementHandle ls ps,Int)+						changeMenuItem' menu change changes itemH@(MenuItemHandle {mItemId=mItemId}) itemNr+							| not anItem = return (changes,itemH,itemNr+1)+							| otherwise  = do+								itemH <- change x menu itemNr itemH+								return (changes1,itemH,itemNr+1)+							where+								(anItem,(_,x),changes1)	= case mItemId of+									Nothing	-> (False,(undefined,undefined),changes)+									Just id	-> remove (eqfst2id id) (id,undefined) changes++						changeMenuItem' menu change changes subH@(SubMenuHandle {mSubHandle=mSubHandle,mSubMenuId=mSubMenuId,mSubItems=mSubItems}) itemNr+							| not anItem && not (fst recurse) = return (changes,subH,itemNr+1)+							| otherwise = do+								(changes2,subItems,_) <- changeMenuItems' mSubHandle change changes1 mSubItems 1+								let subH1 = subH{mSubItems=subItems}+								(if not anItem then return (changes2,subH1,itemNr+1)+								 else do+									subH2 <- change x menu itemNr subH1+									return (changes2,subH2,itemNr+1))+							where+								(anItem,(_,x),changes1)	= case mSubMenuId of+									Nothing	-> (False,(undefined,undefined),changes)+									Just id	-> remove (eqfst2id id) (id,undefined) changes++						changeMenuItem' menu change changes radioH@(RadioMenuHandle {mRadioId=mRadioId,mRadioItems=mRadioItems}) itemNr+							| not anItem && not (snd recurse) = return (changes,radioH,itemNr+nrItems)+							| otherwise = do+								(changes2,items,_) <- changeMenuItems' menu change changes1 mRadioItems itemNr+								let radioH1 = radioH{mRadioItems=items}+								(if not anItem then return (changes2,radioH1,itemNr+nrItems)+								 else do+									radioH2 <- change x menu itemNr radioH1+									return (changes2,radioH2,itemNr+nrItems))+							where+								(anItem,(_,x),changes1)	= case mRadioId of+									Nothing	-> (False,(undefined,undefined),changes)+									Just id	-> remove (eqfst2id id) (id,undefined) changes+								nrItems	= length mRadioItems++						changeMenuItem' menu change changes (MenuListLSHandle items) itemNr = do+							(changes,items,itemNr) <- changeMenuItems' menu change changes items itemNr+							return (changes,MenuListLSHandle items,itemNr)++						changeMenuItem' menu change changes (MenuExtendLSHandle exLS items) itemNr = do+							(changes,items,itemNr) <- changeMenuItems' menu change changes items itemNr+							return (changes,MenuExtendLSHandle exLS items,itemNr)++						changeMenuItem' menu change changes (MenuChangeLSHandle chLS items) itemNr = do+							(changes,items,itemNr) <- changeMenuItems' menu change changes items itemNr+							return (changes,MenuChangeLSHandle chLS items,itemNr)++						changeMenuItem' _ _ changes h itemNr = return (changes,h,itemNr+1)+++--	Read access operations on MState:++getMenu :: Id -> Recurse -> Cond x -> AccessItemHandle ps x -> x -> GUI ps x+getMenu menuId recurse cond f s = do+	ok <- accIOEnv (ioStHasDevice MenuDevice)+	(if not ok then throwGUI ErrorUnknownObject+	 else do+		(found,menus) <- accIOEnv (ioStGetDevice MenuDevice)+		(if not found+		 then stdMenuElementFatalError "getMenu" "MenuSystemState could not be retrieved from IOSt"+		 else let+			  mHs = menuSystemStateGetMenuHandles menus+			  (found,msH) = cselect (eqMenuLSHandleId menuId) undefined (mMenus mHs)+		      in+			  if not found then throwGUI ErrorUnknownObject+			  else return (statemapMenuStateHandle cond f msH s)))+	where+		statemapMenuStateHandle :: Cond x -> AccessItemHandle ps x -> MenuStateHandle ps -> x -> x+		statemapMenuStateHandle cond f (MenuStateHandle mlsH@(MenuLSHandle {mlsHandle=mH@(MenuHandle {mItems=itemHs})})) s =+			statemapMenuElementHandles cond f itemHs s+			where+				statemapMenuElementHandles :: Cond x -> AccessItemHandle ps x -> [MenuElementHandle ls ps] -> x -> x+				statemapMenuElementHandles cond f [] s = s+				statemapMenuElementHandles cond f (itemH:itemHs) s+					| cond s    = s+					| otherwise = statemapMenuElementHandles cond f itemHs (statemapMenuElementHandle cond f itemH s)+					where+						statemapMenuElementHandle :: Cond x -> AccessItemHandle ps x -> MenuElementHandle ls ps -> x -> x+						statemapMenuElementHandle cond f itemH@(MenuListLSHandle        itemHs) s = statemapMenuElementHandles cond f itemHs s+						statemapMenuElementHandle cond f itemH@(MenuExtendLSHandle exLS itemHs) s = statemapMenuElementHandles cond f itemHs s+						statemapMenuElementHandle cond f itemH@(MenuChangeLSHandle chLS itemHs) s = statemapMenuElementHandles cond f itemHs s+						statemapMenuElementHandle cond f itemH@(SubMenuHandle{mSubItems=itemHs}) s = +							statemapMenuElementHandles cond f itemHs (if fst recurse then f itemH s else s)+						statemapMenuElementHandle cond f itemH@(RadioMenuHandle{mRadioItems=itemHs}) s =+							statemapMenuElementHandles cond f itemHs (if snd recurse then f itemH s else s)+						statemapMenuElementHandle cond f itemH			    	        s = f itemH s++eqMenuLSHandleId :: Id -> MenuStateHandle ps -> Bool+eqMenuLSHandleId id msH = id==menuStateHandleGetMenuId msH+++getSelectedRadioMenuItems :: Id -> [Id] -> GUI ps [(Index,Maybe Id)]+getSelectedRadioMenuItems menuId ids = do+	r <- getMenu menuId recurseRadioOnly (null . fst) getradioitemselect (ids,map (\id->(id,0,Nothing)) ids)+	return (map snd3thd3 (snd r))+	where+		getradioitemselect :: MenuElementHandle ls ps -> ([Id],[(Id,Index,Maybe Id)]) -> ([Id],[(Id,Index,Maybe Id)])+		getradioitemselect itemH@(RadioMenuHandle {mRadioItems=itemHs,mRadioIndex=index}) (ids,selects)+			| not hadId	= (ids,selects)+			| otherwise	= (ids1,snd (creplace (eqfst3id id) (id,index,selectid) selects))+			where+				selectid = if index == 0 then Nothing else mItemId (itemHs !! (index-1))++				(hadId,id,ids1)	= case mRadioId itemH of+					Nothing	-> (False,undefined,ids)+					Just id	-> remove ((==) id) id ids++		getradioitemselect _ ids_selects = ids_selects++getSelectedRadioMenuItem :: Id -> Id -> GUI ps (Index,Maybe Id)+getSelectedRadioMenuItem menuId id = fmap head (getSelectedRadioMenuItems menuId [id])++getMenuElementSelectStates :: Id -> [Id] -> GUI ps [(Bool,SelectState)]+getMenuElementSelectStates menuId ids = do+	r <- getMenu menuId recurseAll (null . fst) getmenuitemselect (ids,map (\id->(id,False,Able)) ids)+	return (map snd3thd3 (snd r))+	where+		getmenuitemselect :: MenuElementHandle ls ps -> ([Id],[(Id,Bool,SelectState)]) -> ([Id],[(Id,Bool,SelectState)])+		getmenuitemselect itemH@(SubMenuHandle {}) (ids,selects)+			| not hadId	= (ids,selects)+			| otherwise	= (ids1,snd (creplace (eqfst3id id) (id,True,if mSubSelect itemH   then Able else Unable) selects))+			where+				(hadId,id,ids1)	= case mSubMenuId itemH of+					Nothing	-> (False,undefined,ids)+					Just id	-> remove ((==) id) id ids++		getmenuitemselect itemH@(RadioMenuHandle {}) (ids,selects)			  +			| not hadId	= (ids,selects)+			| otherwise	= (ids1,snd (creplace (eqfst3id id) (id,True,if mRadioSelect itemH then Able else Unable) selects))+			where+				(hadId,id,ids1)	= case mRadioId itemH of+					Nothing	-> (False,undefined,ids)+					Just id	-> remove ((==) id) id ids++		getmenuitemselect itemH@(MenuItemHandle {}) (ids,selects)+			| not hadId	= (ids,selects)+			| otherwise	= (ids1,snd (creplace (eqfst3id id) (id,True,if mItemSelect itemH  then Able else Unable) selects))+			where+				(hadId,id,ids1)	= case mItemId itemH of+					Nothing	-> (False,undefined,ids)+					Just id	-> remove ((==) id) id ids++		getmenuitemselect _ ids_selects = ids_selects++getMenuElementSelectState :: Id -> Id -> GUI ps (Bool,SelectState)+getMenuElementSelectState menuId id = fmap head (getMenuElementSelectStates menuId [id])+++getMenuElementMarkStates :: Id -> [Id] -> GUI ps [(Bool,MarkState)]+getMenuElementMarkStates menuId ids = do+	r <- getMenu menuId recurseNone (null . fst) getmenuitemmark (ids,map (\id->(id,False,NoMark)) ids)+	return (map snd3thd3 (snd r))+	where+		getmenuitemmark :: MenuElementHandle ls ps -> ([Id],[(Id,Bool,MarkState)]) -> ([Id],[(Id,Bool,MarkState)])+		getmenuitemmark itemH@(MenuItemHandle {}) (ids,marks)			+			| not hadId	= (ids,marks)+			| otherwise	= (ids1,snd (creplace (eqfst3id id) (id,True,if mItemMark itemH then Mark else NoMark) marks))+			where+				(hadId,id,ids1)	= case mItemId itemH of+					Nothing	-> (False,undefined,ids)+					Just id	-> remove ((==) id) id ids+		getmenuitemmark _ ids_marks = ids_marks++getMenuElementMarkState :: Id -> Id -> GUI ps (Bool,MarkState)+getMenuElementMarkState menuId id = fmap head (getMenuElementMarkStates menuId [id])+++getMenuElementTitles :: Id -> [Id] -> GUI ps [(Bool,Maybe String)]+getMenuElementTitles menuId ids = do+	r <- getMenu menuId recurseAll (null . fst) getmenuitemtitle (ids, map (\id->(id,False,Nothing)) ids)+	return (map snd3thd3 (snd r))+	where+		getmenuitemtitle :: MenuElementHandle ls ps -> ([Id],[(Id,Bool,Maybe String)]) -> ([Id],[(Id,Bool,Maybe String)])+		getmenuitemtitle itemH@(SubMenuHandle {}) (ids,titles)+			| not hadId	= (ids,titles)+			| otherwise	= (ids1,snd (creplace (eqfst3id id) (id,True,Just (mSubTitle itemH)) titles))+			where+				(hadId,id,ids1)	= case mSubMenuId itemH of+					Nothing	-> (False,undefined,ids)+					Just id	-> remove ((==) id) id ids++		getmenuitemtitle itemH@(RadioMenuHandle {}) (ids,titles)						  +			| not hadId	= (ids,titles)+			| otherwise	= (ids1,snd (creplace (eqfst3id id) (id,True,Nothing) titles))+			where+				(hadId,id,ids1)	= case mRadioId itemH of+					Nothing	-> (False,undefined,ids)+					Just id	-> remove ((==) id) id ids++		getmenuitemtitle itemH@(MenuItemHandle {}) (ids,titles)			+			| not hadId	= (ids,titles)+			| otherwise	= (ids1,snd (creplace (eqfst3id id) (id,True,Just (mItemTitle itemH)) titles))+			where+				(hadId,id,ids1)	= case mItemId itemH of+					Nothing	-> (False,undefined,ids)+					Just id	-> remove ((==) id) id ids++		getmenuitemtitle _ ids_titles = ids_titles++getMenuElementTitle :: Id -> Id -> GUI ps (Bool,Maybe String)+getMenuElementTitle menuId id = fmap head (getMenuElementTitles menuId [id])++-- | returns the shortcut keys associated with the corresponding menu elements+getMenuElementShortKeys :: Id -> [Id] -> GUI ps [(Bool,Maybe Char)]+getMenuElementShortKeys menuId ids = do+	r <- getMenu menuId recurseNone (null . fst) getmenuitemshortkey (ids, map (\id->(id,False,Nothing)) ids)+	return (map snd3thd3 (snd r))+	where+		getmenuitemshortkey :: MenuElementHandle ls ps -> ([Id],[(Id,Bool,Maybe Char)]) -> ([Id],[(Id,Bool,Maybe Char)])+		getmenuitemshortkey itemH@(MenuItemHandle {}) (ids,keys)+			| not hadId	= (ids,keys)+			| otherwise	= (ids1,snd (creplace (eqfst3id id) (id,True,mItemKey itemH) keys))+			where+				(hadId,id,ids1)	= case mItemId itemH of+					Nothing	-> (False,undefined,ids)+					Just id	-> remove ((==) id) id ids++		getmenuitemshortkey _ ids_keys = ids_keys++-- | returns the shortcut key associated with the menu element+getMenuElementShortKey :: Id -> Id -> GUI ps (Bool,Maybe Char)+getMenuElementShortKey menuId id = fmap head (getMenuElementShortKeys menuId [id])
+ Graphics/UI/ObjectIO/StdMenuElementClass.hs view
@@ -0,0 +1,222 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdMenuElementClass+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Definition of the MenuElements class for menu elements.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdMenuElementClass(MenuElements(..), PopUpMenuElements(..)) where+++import  Graphics.UI.ObjectIO.StdIOBasic(TupLS(..))+import  Graphics.UI.ObjectIO.CommonDef+import  Graphics.UI.ObjectIO.Process.IOState+import  Graphics.UI.ObjectIO.StdMenuAttribute+import	Graphics.UI.ObjectIO.Menu.DefAccess+import	Graphics.UI.ObjectIO.Menu.Handle+import	Graphics.UI.ObjectIO.OS.Menu+import	Graphics.UI.ObjectIO.OS.Types(osNoMenu,osNoMenuItem)++-- | Translating menu elements into the internal representation.+-- There are instances for combinator types: 'AddLS', 'NewLS',+-- 'ListLS', 'NilLS' and 'TupLS' and for the concrete menu elements:+-- 'MenuItem', 'MenuSeparator', 'SubMenu' and 'RadioMenu'+class MenuElements m where+	menuElementToHandles	:: m ls ps -> GUI ps [MenuElementState ls ps]	+++{-	Fields which values can not be determined now are filled with dummy values.+	These are the following:+	-	SubMenuHandle+		-	mSubHandle			(the handle to the sub menu)+	-	MenuItemHandle+		-	mOSMenuItem			(the handle to the item)+	-	MenuSeparatorHandle+		-	mOSMenuSeparator	(the handle to the item)+	The remaining attributes are copied.+-}+instance MenuElements m => MenuElements (AddLS m) where+	menuElementToHandles (AddLS addLS addDef) = do+		ms <- menuElementToHandles addDef+		return  [menuElementHandleToMenuElementState+				(MenuExtendLSHandle addLS (map menuElementStateToMenuElementHandle ms))+			]++instance MenuElements m => MenuElements (NewLS m) where+	menuElementToHandles (NewLS newLS newDef) = do+		ms <- menuElementToHandles newDef+		return  [menuElementHandleToMenuElementState+				(MenuChangeLSHandle newLS (map menuElementStateToMenuElementHandle ms))+			]++instance MenuElements m => MenuElements (ListLS m) where	+	menuElementToHandles (ListLS mDefs) = do+		mss <- mapM menuElementToHandles mDefs+		return  [menuElementHandleToMenuElementState+			  	(MenuListLSHandle (map menuElementStateToMenuElementHandle (concat mss)))+			]++instance MenuElements NilLS where	+	menuElementToHandles NilLS = do+		return [menuElementHandleToMenuElementState (MenuListLSHandle [])]++instance (MenuElements m1, MenuElements m2) => MenuElements (TupLS m1 m2) where	+	menuElementToHandles (m1:+:m2) = do+		ms1 <- menuElementToHandles m1+		ms2 <- menuElementToHandles m2+		return (ms1 ++ ms2)	++instance MenuElements m => MenuElements (SubMenu m) where	+	menuElementToHandles (SubMenu title items atts) = do+		ms <- menuElementToHandles items+		let (selectAtt,atts1) = validateSelectState atts+		let (idAtt,    atts2) = validateId          atts1+		return [menuElementHandleToMenuElementState+			  (SubMenuHandle +			  	{ mSubHandle	= osNoMenu+				, mSubMenuId	= idAtt+				, mSubItems	= map menuElementStateToMenuElementHandle ms+				, mSubTitle	= title+				, mSubSelect	= enabled selectAtt+				, mSubAtts	= atts+				}+			  )+			]		  ++instance MenuElements RadioMenu where	+	menuElementToHandles (RadioMenu items index atts) = do+		let nrRadios = length items+		let validIndex = if nrRadios==0 then 0 else (setBetween index 1 nrRadios)+		let itemHs = validateRadioMenuIndex validIndex (map radioMenuItemToMenuElementHandle items)+		let (selectAtt,atts1) = validateSelectState atts+		let (idAtt,    atts2) = validateId          atts1+		return [menuElementHandleToMenuElementState+			  (RadioMenuHandle +			  	{ mRadioId	= idAtt+				, mRadioIndex	= validIndex+				, mRadioItems	= itemHs+				, mRadioSelect	= enabled selectAtt+				, mRadioAtts	= atts+				}+			  )+			]++instance MenuElements MenuItem where	+	menuElementToHandles (MenuItem title atts) = do+		let (selectAtt,atts1)	= validateSelectState atts+		let (markAtt,  atts2)	= validateMarkState   atts1+		let (keyAtt,   atts3)	= validateShortKey    atts2+		let (idAtt,    atts4)	= validateId          atts3+		return [menuElementHandleToMenuElementState+			  (MenuItemHandle+			  	{ mItemId	= idAtt+				, mItemKey	= keyAtt+				, mItemTitle	= title+				, mItemSelect	= enabled selectAtt+				, mItemMark	= marked  markAtt+				, mItemAtts	= atts+				, mOSMenuItem	= osNoMenuItem+				}+			  )+			]++instance MenuElements MenuSeparator where	+	menuElementToHandles (MenuSeparator atts) = do+		let (idAtt,_) = validateId atts+		return [menuElementHandleToMenuElementState +			  (MenuSeparatorHandle+			  	{ mSepId	   = idAtt+				, mOSMenuSeparator = osNoMenuItem+				}+			  )+			]		  +++--	Obtain the SelectState attribute from the attribute list:+validateSelectState :: [MenuAttribute ls ps] -> (SelectState,[MenuAttribute ls ps])+validateSelectState atts =+	let (found,selectAtt,atts1)= remove isMenuSelectState undefined atts+	in if found then (getMenuSelectStateAtt selectAtt,atts1)+	   else (Able,atts)++--	Obtain the MarkState attribute from the attribute list:+validateMarkState :: [MenuAttribute ls ps] -> (MarkState,[MenuAttribute ls ps])+validateMarkState atts =+	let (found,markAtt,atts1) = remove isMenuMarkState undefined atts+	in if found then (getMenuMarkStateAtt markAtt,atts1)+	   else (NoMark,atts)++--	Obtain the Id attribute from the attribute list:+validateId :: [MenuAttribute ls ps] -> (Maybe Id,[MenuAttribute ls ps])+validateId atts =+	let (found,idAtt,atts1)	= remove isMenuId undefined atts+	in if found then (Just (getMenuIdAtt idAtt),atts1)+	   else (Nothing,atts)++--	Obtain the ShortKey attribute from the attribute list:+validateShortKey :: [MenuAttribute ls ps] -> (Maybe Char,[MenuAttribute ls ps])+validateShortKey atts =+	let (hasKey,keyAtt,atts1) = remove isMenuShortKey undefined atts+	in if hasKey then (Just (getMenuShortKeyAtt keyAtt),atts1)+	   else (Nothing,atts)++--	validateRadioMenuIndex ensures that only the element at the valid index position of the RadioMenu+--	has a check mark and all others don't.+validateRadioMenuIndex :: Int -> [MenuElementHandle ls ps] -> [MenuElementHandle ls ps]+validateRadioMenuIndex index itemHs =+	fst (stateMap (\itemH i -> (itemH{mItemMark=i==index},i+1)) itemHs 1)+++{-	Menu elements for PopUpMenus: -}++-- | Translating menu elements into the internal representation.+-- For the PopUpMenuElements class there are instances for same types as 'MenuElements'+class PopUpMenuElements m where+	popUpMenuElementToHandles :: m ls ps -> GUI ps [MenuElementState ls ps]++instance PopUpMenuElements m => PopUpMenuElements (AddLS m) where+	popUpMenuElementToHandles (AddLS addLS addDef) = do+		ms <- popUpMenuElementToHandles addDef+		return  [menuElementHandleToMenuElementState+				(MenuExtendLSHandle addLS (map menuElementStateToMenuElementHandle ms))+			]++instance PopUpMenuElements m => PopUpMenuElements (NewLS m) where+	popUpMenuElementToHandles (NewLS newLS newDef) = do+		ms <- popUpMenuElementToHandles newDef+		return  [menuElementHandleToMenuElementState+				(MenuChangeLSHandle newLS (map menuElementStateToMenuElementHandle ms))+			]++instance PopUpMenuElements m => PopUpMenuElements (ListLS m) where+	popUpMenuElementToHandles (ListLS mDefs) = do+		mss <- mapM popUpMenuElementToHandles mDefs+		return  [menuElementHandleToMenuElementState+			  	(MenuListLSHandle (map menuElementStateToMenuElementHandle (concat mss)))+			]++instance PopUpMenuElements NilLS where+	popUpMenuElementToHandles NilLS = do+		return [menuElementHandleToMenuElementState (MenuListLSHandle [])]++instance (PopUpMenuElements m1, PopUpMenuElements m2) => PopUpMenuElements (TupLS m1 m2) where	+	popUpMenuElementToHandles (m1:+:m2) = do+		ms1 <- popUpMenuElementToHandles m1+		ms2 <- popUpMenuElementToHandles m2+		return (ms1 ++ ms2)++instance PopUpMenuElements RadioMenu where	+	popUpMenuElementToHandles  = menuElementToHandles++instance PopUpMenuElements MenuItem where	+	popUpMenuElementToHandles  = menuElementToHandles++instance PopUpMenuElements MenuSeparator where	+	popUpMenuElementToHandles  = menuElementToHandles
+ Graphics/UI/ObjectIO/StdMenuReceiver.hs view
@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdMenuReceiver+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdMenuReceiver defines Receiver(2) instances of 'MenuElements' class.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdMenuReceiver(MenuElements(..)) where+++import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.StdReceiverAttribute+import	Graphics.UI.ObjectIO.StdMenuElementClass+import	Graphics.UI.ObjectIO.StdMenuDef+import	Graphics.UI.ObjectIO.Menu.Handle+import	Graphics.UI.ObjectIO.Receiver.Access(newReceiverHandle, newReceiver2Handle)+++instance MenuElements (Receiver m) where+	menuElementToHandles (Receiver rid f atts) =+		return [menuElementHandleToMenuElementState+				(MenuReceiverHandle (newReceiverHandle rid (getSelectState atts) f)+						(MenuId (rIdtoId rid):map receiverAttToMenuAtt atts))+			]++instance MenuElements (Receiver2 m r) where+	menuElementToHandles (Receiver2 rid f atts) =+		return [menuElementHandleToMenuElementState+				(MenuReceiverHandle (newReceiver2Handle rid (getSelectState atts) f)+						(MenuId (r2IdtoId rid):map receiverAttToMenuAtt atts))+			]++getSelectState :: [ReceiverAttribute ls ps] -> SelectState+getSelectState rAtts = getReceiverSelectStateAtt (snd (cselect isReceiverSelectState (ReceiverSelectState Able) rAtts))++receiverAttToMenuAtt :: ReceiverAttribute ls ps -> MenuAttribute ls ps+receiverAttToMenuAtt (ReceiverSelectState s) = MenuSelectState s
+ Graphics/UI/ObjectIO/StdPicture.hs view
@@ -0,0 +1,712 @@+{-# OPTIONS_GHC -#include "cpicture_121.h" #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  StdPicture+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdPicture contains the drawing operations and access to Pictures.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdPicture+	( Draw(..), Look, doScreenDraw, accClipPicture, accXorPicture,+	  +	-- * Pen attributes+	  setPenAttributes, getPenAttributes+	, setPenPos, getPenPos+	, setPenSize, getPenSize, setDefaultPenSize+	, setPenColour, getPenColour, setDefaultPenColour+	, setPenBack, getPenBack, setDefaultPenBack	+	, setPenFont, getPenFont, setDefaultPenFont,+	+	-- * Font operations+	  getFontNames, getFontSizes+	, getFontCharWidth, getFontCharWidths+	, getFontStringWidth, getFontStringWidths+	, getFontMetrics+	, getPenFontCharWidth, getPenFontCharWidths+	, getPenFontStringWidth, getPenFontStringWidths+	, getPenFontMetrics,+	+	-- * Type classes+	  MovePen(..), Drawables(..), Fillables(..), Hilites(..),+	  +	-- * Data declarations+	  Region(..), RegionShape(..), ToRegion(..), PolygonAt(..),+	  +	-- * Region functions+	  isEmptyRegion, getRegionBound, sumRegion,+	  +	-- * Drawing functions+	  drawPoint, drawPointAt, drawLineTo, drawLine, undrawLineTo, undrawLine+	, stdUnfillNewFrameLook, stdUnfillUpdAreaLook,+	+	-- * predefined fonts+	  defaultFont, dialogFont, serifFont+	, sansSerifFont, smallFont, nonProportionalFont, symbolFont,+	+	-- * A visible module+	  module Graphics.UI.ObjectIO.StdPictureDef+	) where+++--	Drawing functions and other operations on Picture++import	Graphics.UI.ObjectIO.OS.Picture+import	Graphics.UI.ObjectIO.OS.Font+import	Graphics.UI.ObjectIO.OS.Rgn+import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.StdPictureDef+import	Graphics.UI.ObjectIO.StdIOBasic+import  Foreign.Ptr(nullPtr)++--	Pen attribute functions:++setPenAttributes :: [PenAttribute] -> Draw ()+setPenAttributes atts = mapM_ setAttribute atts+	where+	  setAttribute :: PenAttribute -> Draw ()+	  setAttribute (PenSize size) = setPenSize size+	  setAttribute (PenPos   pos) = setPenPos   pos+	  setAttribute (PenColour  c) = setPenColour  c+	  setAttribute (PenBack    c) = setPenBack    c+	  setAttribute (PenFont font) = setPenFont font++getPenAttributes :: Draw [PenAttribute]+getPenAttributes = do+	pen <- getPictPen+	return (getattribute pen)+	where+	  getattribute :: Pen -> [PenAttribute]+	  getattribute (Pen{penSize=psize,penForeColour=fc,penBackColour=bc,penPos=pos,penFont=font}) =+		  [PenSize psize,PenPos pos,PenColour fc,PenBack bc,PenFont font]+++--	Pen position attributes:++-- The setPenPos function corresponds to the 'PenPos' attribute. The function moves the pen to the given position.+setPenPos :: Point2 -> Draw ()+setPenPos = setPictPenPos++-- | The getPenPos function corresponds to the 'PenPos' attribute. The function returns the current pen position.+getPenPos :: Draw Point2+getPenPos = getPictPenPos++class MovePen f where+	movePenPos :: f -> Draw ()  -- Move the pen position as much as when drawing the figure.+++instance MovePen Vector2 where+	movePenPos v = movePictPenPos v++instance MovePen Curve where	+	movePenPos curve = do+	  curPos <- getPictPenPos+	  setPictPenPos (getCurveEnd curPos curve)+	  +getCurveEnd :: Point2 -> Curve -> Point2+getCurveEnd start@(Point2{x=x,y=y}) (Curve{curve_oval=Oval{oval_rx=rx,oval_ry=ry},curve_from=from,curve_to=to,curve_clockwise=clockwise})+	| clockwise	= start+	| otherwise	= end+	where+	   rx'		= fromIntegral (abs rx)+	   ry'		= fromIntegral (abs ry)+	   cx		= x  - (round ((cos from)*rx'))+	   cy		= y  + (round ((sin from)*ry'))+	   ex		= cx + (round ((cos to  )*rx'))+	   ey		= cy - (round ((sin to  )*ry'))+	   end		= Point2{x=ex,y=ey}	   +++-- PenSize attributes:+setPenSize :: Int -> Draw ()+setPenSize = setPictPenSize++getPenSize :: Draw Int+getPenSize = getPictPenSize++setDefaultPenSize :: Draw ()+setDefaultPenSize = setPictPenSize 1+++--	Colour attributes:+setPenColour :: Colour -> Draw ()+setPenColour = setPictPenColour++getPenColour :: Draw Colour+getPenColour = getPictPenColour++setPenBack :: Colour -> Draw ()+setPenBack = setPictBackColour++getPenBack :: Draw Colour+getPenBack = getPictBackColour++setDefaultPenColour :: Draw ()+setDefaultPenColour = setPictPenColour black++setDefaultPenBack :: Draw ()+setDefaultPenBack = setPictBackColour white+++--	Font attributes:+setPenFont :: Font -> Draw ()+setPenFont = setPictPenFont++getPenFont :: Draw Font+getPenFont = getPictPenFont++setDefaultPenFont :: Draw ()+setDefaultPenFont = setPictPenDefaultFont+++--	Font operations:+getFontNames :: Draw [FontName]+getFontNames = liftIO (osFontNames)++getFontSizes :: Int -> Int -> FontName -> Draw [FontSize]+getFontSizes sizeBound1 sizeBound2 fName = liftIO (osFontSizes sizeBound1 sizeBound2 fName)	++getFontCharWidth :: Font -> Char -> Draw Int+getFontCharWidth font char = do+	osPictContext <- peekOSPictContext+	widths <- liftIO (osGetFontCharWidths (Just osPictContext) [char] font)+	return (head widths)++getFontCharWidths :: Font -> [Char] -> Draw [Int]+getFontCharWidths font chars = do+	osPictContext <- peekOSPictContext+	liftIO (osGetFontCharWidths (Just osPictContext) chars font)++getFontStringWidth :: Font -> String -> Draw Int+getFontStringWidth font string = do+	osPictContext <- peekOSPictContext+	widths <- liftIO (osGetFontStringWidths (Just osPictContext) [string] font)+	return (head widths)++getFontStringWidths :: Font -> [String] -> Draw [Int]+getFontStringWidths font strings = do+	osPictContext <- peekOSPictContext+	liftIO (osGetFontStringWidths (Just osPictContext) strings font)++getFontMetrics :: Font -> Draw FontMetrics+getFontMetrics font = do+	osPictContext <- peekOSPictContext+	(ascent,descent,leading,maxwidth) <- liftIO (osGetFontMetrics (Just osPictContext) font)+	return (FontMetrics{fAscent=ascent,fDescent=descent,fLeading=leading,fMaxWidth=maxwidth})++getPenFontCharWidth :: Char -> Draw Int+getPenFontCharWidth char = do+	font <- getPenFont+	getFontCharWidth font char++getPenFontCharWidths :: [Char] -> Draw [Int]+getPenFontCharWidths chars = do+	font <- getPenFont+	getFontCharWidths font chars++getPenFontStringWidth :: String -> Draw Int+getPenFontStringWidth string = do+	font <- getPenFont+	getFontStringWidth font string++getPenFontStringWidths :: [String] -> Draw [Int]+getPenFontStringWidths strings = do+	font <- getPenFont+	getFontStringWidths font strings++getPenFontMetrics :: Draw FontMetrics+getPenFontMetrics = getPenFont >>= getFontMetrics+++{-	Drawing functions.+	These functions are divided into the following classes:+	Drawables:+		draw     'line-oriented' figures at the current  pen position.+		drawAt   'line-oriented' figures at the argument pen position.+		undraw     f = appPicture (draw     f o setPenColour background)+		undrawAt x f = appPicture (drawAt x f o setPenColour background)+	Fillables:+		fill     'area-oriented' figures at the current  pen position.+		fillAt   'area-oriented' figures at the argument pen position.+		unfill     f = appPicture (fill     f o setPenColour background)+		unfillAt x f = appPicture (fillAt x f o setPenColour background)+	Hilites:+		hilite	 draws figures in the appropriate 'hilite' mode at the current pen position.+		hiliteAt draws figures in the appropriate 'hilite' mode at the current pen position.+		Both functions reset the 'hilite' after drawing.+-}++class Drawables figure where+	draw	:: figure -> Draw ()+	drawAt	:: Point2 -> figure -> Draw ()+	undraw	:: figure -> Draw ()+	undrawAt:: Point2 -> figure -> Draw ()++class Fillables figure where+	fill	:: figure -> Draw ()+	fillAt	:: Point2 -> figure -> Draw ()+	unfill	:: figure -> Draw ()+	unfillAt:: Point2 -> figure -> Draw ()++class Hilites figure where+	hilite	:: figure -> Draw ()+	hiliteAt:: Point2 -> figure -> Draw ()+++{-	(app/acc)Picture applies the given drawing function to the given picture.+	When drawing is done, all picture attributes are set to the attribute values of the original picture.+-}+appPicture :: Draw a -> Draw a+appPicture drawf = do+	pen <- getPictPen+	x <- drawf+	setPictPen pen+	return x++++--	Drawing in a clipping region.++data Region+   = Region+   	{ region_shape	:: [RegionShape]+	, region_bound	:: Rect+	}+data RegionShape+   = RegionRect	   Rect+   | RegionPolygon Point2 [Vector2]+++isEmptyRegion :: Region -> Bool+isEmptyRegion (Region {region_shape=[]}) = True+isEmptyRegion _				 = False++getRegionBound :: Region -> Rectangle+getRegionBound (Region{region_bound=rect}) = rectToRectangle rect++class ToRegion area where+	toRegion :: area -> Region++data PolygonAt+   = PolygonAt+   	{ polygon_pos	:: Point2+	, polygon	:: Polygon+	}++instance ToRegion Rectangle where	+	toRegion rectangle+		| isEmptyRect rect	= zero+		| otherwise		= Region{region_shape=[RegionRect rect],region_bound=rect}+		where+			rect = rectangleToRect rectangle++instance ToRegion PolygonAt where+	toRegion (PolygonAt{polygon_pos=p@(Point2{x=x,y=y}),polygon=Polygon{polygon_shape=polygon_shape}})+		| isEmptyRect bound	= zero+		| otherwise		= Region{region_shape=[RegionPolygon p shape],region_bound=bound}+		where+		    shape	= closeShape zero polygon_shape+		    bound	= polyBound p shape (Rect{rleft=x,rtop=y,rright=x,rbottom=y})++		    polyBound :: Point2 -> [Vector2] -> Rect -> Rect+		    polybound _ [] bound = bound+		    polyBound p (v:vs) (Rect{rleft=minx,rtop=miny,rright=maxx,rbottom=maxy}) =+			    polyBound p' vs (Rect{rleft=minx',rtop=miny',rright=maxx',rbottom=maxy'})+			    where+				    p'@(Point2 {x=x,y=y}) = movePoint v p+				    minx'	= min minx x+				    miny'	= min miny y+				    maxx'	= max maxx x+				    maxy'	= max maxy y		++		    closeShape :: Vector2 -> [Vector2] -> [Vector2]+		    closeShape v (v':vs) = (v':closeShape (v+v') vs)+		    closeShape v []+			    | v==zero	= []+			    | otherwise	= [Vector2{vx=0-(vx v),vy=0-(vy v)}]+++instance ToRegion area => ToRegion [area] where+	toRegion []		= zero+	toRegion (area:areas)	= sumRegion (toRegion area) (toRegion areas)+	++instance (ToRegion area1, ToRegion area2) => ToRegion (Tup area1 area2) where	+	toRegion (r1 :^: r2) = sumRegion (toRegion r1) (toRegion r2)++instance Zero Region where+	zero = Region{region_shape=[],region_bound=zero}+	++sumRegion :: Region -> Region -> Region+sumRegion r1 r2+	| isEmptyRect (region_bound r1) = r2+	| isEmptyRect (region_bound r2) = r1+	| otherwise = Region{region_shape=(region_shape r1)++(region_shape r2),+			     region_bound=sumBound (region_bound r1) (region_bound r2)}+		where+			sumBound :: Rect -> Rect -> Rect+			sumBound (Rect{rleft=minx,rtop=miny,rright=maxx,rbottom=maxy}) +				 (Rect{rleft=minx',rtop=miny',rright=maxx',rbottom=maxy'}) =+			    Rect{rleft=min minx minx',rtop=min miny miny',rright=max maxx maxx',rbottom=max maxy maxy'}++accClipPicture :: Region -> Draw x -> Draw x+accClipPicture region drawf = do+	curClipRgn <- pictGetClipRgn+	newClipRgn <- liftIO osNewRgn+	context <- peekOSPictContext+	(hFac,vFac) <- liftIO (getPictureScalingFactors context)+	origin <- getPictOrigin+	newClipRgn <- liftIO (setRgnShapes hFac vFac origin (region_shape region) newClipRgn)	+	let (set,dispose) = if curClipRgn==nullPtr then (pictSetClipRgn,\_ -> return ()) else (pictAndClipRgn,osDisposeRgn)+	set newClipRgn+	x <- drawf+	pictSetClipRgn curClipRgn+	liftIO (dispose curClipRgn >> osDisposeRgn newClipRgn)+	return x+	where+	    setRgnShapes :: (Int,Int) -> (Int,Int) -> Point2 -> [RegionShape] -> OSRgnHandle -> IO OSRgnHandle+	    setRgnShapes hFac vFac origin (shape:shapes) rgn = do+		rgn <- setRgnShape hFac vFac origin shape rgn+		setRgnShapes hFac vFac origin shapes rgn+		where+		    setRgnShape :: (Int,Int) -> (Int,Int) -> Point2 -> RegionShape -> OSRgnHandle -> IO OSRgnHandle+		    setRgnShape hFac vFac (Point2{x=ox,y=oy}) (RegionRect (Rect {rleft=left,rtop=top,rright=right,rbottom=bottom})) rgn = do+			    rectRgn <- osNewRectRgn rect+			    sumRgn	<- osUnionRgn rectRgn rgn+			    osDisposeRgn rectRgn+			    osDisposeRgn rgn+			    return sumRgn+			    where+				    rect = Rect+					    { rleft   = scale hFac (left  -ox)+					    , rtop    = scale vFac (top   -oy)+					    , rright  = scale hFac (right -ox)+					    , rbottom = scale vFac (bottom-oy)+					    }+		    setRgnShape hFac vFac (Point2{x=ox,y=oy}) (RegionPolygon (Point2{x=x,y=y}) shape) rgn = do+			    polyRgn  <- osPolyRgn (scale hFac (x-ox),scale vFac (y-oy)) (map (\(Vector2{vx=vx,vy=vy})->(scale hFac vx,scale vFac vy)) shape)+			    sumRgn <- osUnionRgn polyRgn rgn+			    osDisposeRgn polyRgn+			    osDisposeRgn rgn+			    return sumRgn+	    setRgnShapes _ _ _ _ rgn = return rgn++	    scale :: (Int,Int) -> Int -> Int+	    scale (n,d) x = n*x `div` d+++{-	(app/acc)XorPicture applies the given drawing function to the given picture in the platform appropriate+	xor mode. +-}++accXorPicture :: Draw a -> Draw a+accXorPicture drawf = do+	setPictXorMode+	x <- drawf+	setPictNormalMode+	return x+++{-	Hiliting figures: -}++instance Hilites Box where+	hilite box = do+		setPictHiliteMode+		curPos <- getPictPenPos+		pictFillRect (boxToRect curPos box)+		setPictNormalMode+		+	hiliteAt base box = do+		setPictHiliteMode+		pictFillRect (boxToRect base box)+		setPictNormalMode++instance Hilites Rectangle where+	hilite rectangle = do+		setPictHiliteMode+		pictFillRect (rectangleToRect rectangle)+		setPictNormalMode		+	+	hiliteAt _ rectangle = do+		setPictHiliteMode+		pictFillRect (rectangleToRect rectangle)+		setPictNormalMode+++drawPoint :: Draw ()+drawPoint = do+	curPos <- getPictPenPos+	pictDrawPoint curPos++drawPointAt :: Point2 -> Draw ()+drawPointAt = pictDrawPoint+++-- Point2 connecting drawing operations:++drawLineTo :: Point2 -> Draw ()+drawLineTo point = do+	pos <- getPictPenPos+	pictDrawLine pos point+	setPenPos point++drawLine :: Point2 -> Point2 -> Draw ()+drawLine = pictDrawLine++undrawLineTo :: Point2 -> Draw ()+undrawLineTo point = do+	pos <- getPictPenPos+	pictUndrawLine pos point+	setPenPos point+	+undrawLine :: Point2 -> Point2 -> Draw ()+undrawLine = pictUndrawLine+++-- Text drawing operations:++instance Drawables Char where+	draw c = do+		curPos <- getPictPenPos+		pictDrawChar curPos c+		w <- pictGetCharWidth c+		setPenPos (curPos{x = (x curPos)+w})+	+	drawAt = pictDrawChar	  +	+	undraw c = do+		curPos <- getPictPenPos+		pictUndrawChar curPos c+		w <- pictGetCharWidth c+		setPenPos (curPos{x = (x curPos)+w})+	+	undrawAt = pictUndrawChar+	  ++instance Drawables String where+	draw s = do+		curPos <- getPictPenPos+		pictDrawString curPos s+		w <- pictGetStringWidth s+		setPenPos (curPos{x = (x curPos)+w})++	drawAt = pictDrawString+	+	undraw s = do+		curPos <- getPictPenPos+		pictUndrawString curPos s+		w <- pictGetStringWidth s+		setPenPos (curPos{x = (x curPos)+w})+	+	undrawAt = pictUndrawString+++--	Line2 drawing operations:++instance Drawables Line2 where+	draw     (Line2 {line_end1=e1,line_end2=e2}) = pictDrawLine e1 e2	+	drawAt _ (Line2 {line_end1=e1,line_end2=e2}) = pictDrawLine e1 e2+	+	undraw     (Line2 {line_end1=e1,line_end2=e2}) = pictUndrawLine e1 e2	+	undrawAt _ (Line2 {line_end1=e1,line_end2=e2}) = pictUndrawLine e1 e2+++--	Vector2 drawing operations:++instance Drawables Vector2 where+	draw (Vector2 {vx=vx,vy=vy}) = do+		curPos <- getPictPenPos+		let endPos = Point2{x=(x curPos)+vx,y=(y curPos)+vy}+		pictDrawLine curPos endPos+		setPenPos endPos+	+	drawAt pos@(Point2{x=x,y=y}) (Vector2 {vx=vx,vy=vy}) = do+		let endPos = Point2 {x=x+vx,y=y+vy}+		pictDrawLine pos endPos+		setPenPos endPos+	+	undraw (Vector2 {vx=vx,vy=vy}) = do+		curPos <- getPictPenPos+		let endPos = Point2{x=(x curPos)+vx,y=(y curPos)+vy}+		pictUndrawLine curPos endPos+		setPenPos endPos+	+	undrawAt pos@(Point2{x=x,y=y}) (Vector2 {vx=vx,vy=vy}) = do+		let endPos = Point2 {x=x+vx,y=y+vy}+		pictUndrawLine pos endPos+		setPenPos endPos+++--	Oval drawing operations:++instance Drawables Oval where+	draw oval = do+		curPos <- getPictPenPos+		pictDrawOval curPos oval+	+	drawAt = pictDrawOval+	+	undraw oval = do+		curPos <- getPictPenPos+		pictUndrawOval curPos oval+	+	undrawAt = pictUndrawOval++++instance Fillables Oval where+	fill oval = do+		curPos <- getPictPenPos+		pictFillOval curPos oval+	+	fillAt = pictFillOval+	+	unfill oval = do+		curPos <- getPictPenPos+		pictUnfillOval curPos oval+	+	unfillAt = pictUnfillOval+++--	Curve drawing operations:++instance Drawables Curve where+	draw curve = do+		curPos <- getPictPenPos+		pictDrawCurve curPos curve+		setPenPos (getCurveEnd curPos curve)+	+	drawAt = pictDrawCurve+	+	undraw curve = do+		curPos <- getPictPenPos+		pictUndrawCurve curPos curve+		setPenPos (getCurveEnd curPos curve)+	+	undrawAt = pictUndrawCurve++instance Fillables Curve where+	fill curve = do+		curPos <- getPictPenPos+		pictFillCurve curPos curve+	+	fillAt = pictFillCurve++	unfill curve = do+		curPos <- getPictPenPos+		pictUnfillCurve curPos curve+	+	unfillAt = pictUnfillCurve+	+--	Box drawing operations:++instance Drawables Box where	+	draw box = do+		curPos <- getPictPenPos+		pictDrawRect (boxToRect curPos box)+	+	drawAt point box = pictDrawRect (boxToRect point box)+	+	undraw box = do+		curPos <- getPictPenPos+		pictUndrawRect (boxToRect curPos box)+	+	undrawAt point box = pictUndrawRect (boxToRect point box)++instance Fillables Box where+	fill box = do+		curPos <- getPictPenPos+		pictFillRect (boxToRect curPos box)+	+	fillAt pos box = pictFillRect (boxToRect pos box)++	unfill box = do+		curPos <- getPictPenPos+		pictUnfillRect (boxToRect curPos box)+	+	unfillAt pos box = pictUnfillRect (boxToRect pos box)++boxToRect :: Point2 -> Box -> Rect+boxToRect (Point2 {x=x,y=y}) (Box {box_w=bw,box_h=bh}) =+	Rect {rleft=l,rtop=t,rright=r,rbottom=b}+	where+	  (l,r) = minmax x (x+bw)+	  (t,b) = minmax y (y+bh)+++--	Rectangle drawing operations:++instance Drawables Rectangle where+	draw rectangle = pictDrawRect (rectangleToRect rectangle)+	+	drawAt _ rectangle = pictDrawRect (rectangleToRect rectangle)++	undraw rectangle = pictUndrawRect (rectangleToRect rectangle)+	+	undrawAt _ rectangle = pictUndrawRect (rectangleToRect rectangle)++instance Fillables Rectangle where+	fill rectangle = pictFillRect (rectangleToRect rectangle)+	+	fillAt _ rectangle = pictFillRect (rectangleToRect rectangle)++	unfill rectangle = pictUnfillRect (rectangleToRect rectangle)+	+	unfillAt _ rectangle = pictUnfillRect (rectangleToRect rectangle)+++--	Polygon drawing operations:++instance Drawables Polygon where+	draw polygon = do+		curPos <- getPictPenPos+		pictDrawPolygon curPos polygon+	+	drawAt = pictDrawPolygon++	undraw polygon = do+		curPos <- getPictPenPos+		pictUndrawPolygon curPos polygon+	+	undrawAt = pictUndrawPolygon++instance Fillables Polygon where+	fill polygon = do+		curPos <- getPictPenPos+		pictFillPolygon curPos polygon+	+	fillAt = pictFillPolygon+	+	unfill polygon = do+		curPos <- getPictPenPos+		pictUnfillPolygon curPos polygon+	+	unfillAt = pictUnfillPolygon+++-- MW...+getResolution :: Draw (Int, Int)+getResolution = do+	context <- peekOSPictContext+	liftIO (getResolutionC context)+-- ... MW++--	Standard GUI object rendering function.++type Look = SelectState ->					-- Current SelectState of GUI object+	    UpdateState ->					-- The area to be rendered+	    Draw ()						-- The rendering action++stdUnfillNewFrameLook :: SelectState -> UpdateState -> Draw ()+stdUnfillNewFrameLook _ (UpdateState {newFrame=newFrame}) = unfill newFrame++stdUnfillUpdAreaLook :: SelectState -> UpdateState -> Draw ()+stdUnfillUpdAreaLook _ (UpdateState {updArea=updArea}) = mapM_ unfill updArea
+ Graphics/UI/ObjectIO/StdPictureDef.hs view
@@ -0,0 +1,98 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdPictureDef+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdPictureDef contains the predefined figures that can be drawn.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdPictureDef(module Graphics.UI.ObjectIO.StdPictureDef, Font(..)) where+++import Graphics.UI.ObjectIO.StdIOBasic+import Graphics.UI.ObjectIO.OS.Font (Font(..))+++data	Line2						-- A line connects two points+	= Line2+		{ line_end1       :: !Point2		-- The first  point+		, line_end2       :: !Point2		-- The second point+		}+data	Box						-- A box is a rectangle+	= Box+		{ box_w           :: !Int		-- The width  of the box+		, box_h           :: !Int		-- The height of the box+		}+data	Oval						-- An oval is a stretched unit circle+	= Oval+		{ oval_rx         :: !Int		-- The horizontal radius (stretch)+		, oval_ry         :: !Int		-- The vertical   radius (stretch)+		}+data	Curve						-- A curve is a slice of an oval+	= Curve+		{ curve_oval      :: !Oval		-- The source oval+		, curve_from      :: !Float		-- Starting angle (in radians)+		, curve_to        :: !Float		-- Ending   angle (in radians)+		, curve_clockwise :: !Bool		-- Direction: True iff clockwise+		}+data	Polygon						-- A polygon is an outline shape+	= Polygon+		{ polygon_shape   :: ![Vector2]		-- The shape of the polygon+		}+data	FontDef+	= FontDef+		{ fName           :: !FontName		-- Name of the font+		, fStyles         :: ![FontStyle]	-- Stylistic variations+		, fSize           :: !FontSize		-- Size in points+		}+data	FontMetrics+	= FontMetrics+		{ fAscent         :: !Int		-- Distance between top    and base line+		, fDescent        :: !Int		-- Distance between bottom and base line+		, fLeading        :: !Int		-- Distance between two text lines+		, fMaxWidth       :: !Int		-- Max character width including spacing+		}+		+type	FontName  = String+type	FontStyle = String+type	FontSize  = Int++data	Colour+	= RGB +	    { r	:: !Int				-- The contribution of red+	    , g	:: !Int				-- The contribution of green+	    , b	:: !Int				-- The contribution of blue+	    } deriving Eq	++data	PenAttribute					-- Default:+	= PenSize	Int				-- 1+	| PenPos	Point2				-- zero+	| PenColour	Colour				-- Black+	| PenBack	Colour				-- White+	| PenFont	Font				-- defaultFont++--	Colour constants:+minRGB			= 0   :: Int+maxRGB			= 255 :: Int++black     = RGB {r=minRGB,g=minRGB,b=minRGB} :: Colour+darkGrey  = RGB {r=round((fromIntegral maxRGB)/4.0), g=round((fromIntegral maxRGB)/4.0), b=round((fromIntegral maxRGB)/4.0)} :: Colour+grey      = RGB {r=round((fromIntegral maxRGB)/2.0), g=round((fromIntegral maxRGB)/2.0), b=round((fromIntegral maxRGB)/2.0)} :: Colour+lightGrey = RGB {r=round((fromIntegral maxRGB)*0.75),g=round((fromIntegral maxRGB)*0.75),b=round((fromIntegral maxRGB)*0.75)} :: Colour+white     = RGB {r=maxRGB,g=maxRGB,b=maxRGB} :: Colour+red       = RGB {r=maxRGB,g=minRGB,b=minRGB} :: Colour+green     = RGB {r=minRGB,g=maxRGB,b=minRGB} :: Colour+blue      = RGB {r=minRGB,g=minRGB,b=maxRGB} :: Colour+cyan      = RGB {r=minRGB,g=maxRGB,b=maxRGB} :: Colour+magenta   = RGB {r=maxRGB,g=minRGB,b=maxRGB} :: Colour+yellow    = RGB {r=maxRGB,g=maxRGB,b=minRGB} :: Colour+++--	Standard lineheight of a font is the sum of its leading, ascent and descent:+fontLineHeight fMetrics	= fLeading fMetrics + fAscent fMetrics + fDescent fMetrics
+ Graphics/UI/ObjectIO/StdProcess.hs view
@@ -0,0 +1,106 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdProcess+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdProcess contains the process creation and manipulation functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdProcess+		( +		-- * Definitions+		  Processes(..)+		, startIO, closeProcess+		, getProcessWindowPos, getProcessWindowSize,+		-- * A visible module+		  module Graphics.UI.ObjectIO.StdProcessDef+		) where+++import Graphics.UI.ObjectIO.CommonDef (dumpFatalError, Rect(..), rectSize)+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.Process.Device+import Graphics.UI.ObjectIO.Process.Scheduler+import Graphics.UI.ObjectIO.StdProcessDef+import Graphics.UI.ObjectIO.OS.System(osGetProcessWindowDimensions)+++stdprocessFatalError :: String -> String -> x+stdprocessFatalError function error+	= dumpFatalError function "StdProcess" error+++-- | General process topology creation functions.+-- There are instances for 'Process' and Processes a => [a] types.++class Processes pdef where+	startProcesses :: pdef -> IO ()+	openProcesses  :: pdef -> GUI ps ()++instance Processes Process where+	startProcesses (Process xDI ps_init io_init atts)+		= do {+			initialContext  <- initContext atts io_init1 ps_init xDI;			+			(case initialContext of+				Just context -> handleEvents context >> closeContext context+				initFailed   -> stdprocessFatalError "startProcesses" "should not be evaluated inside GUI context");+		  }+		where+			io_init1 ps = dOpen processFunctions ps >>= io_init+	+	openProcesses (Process xDI ps_init io_init atts)+		= addInteractiveProcess atts io_init1 ps_init xDI+		where+			io_init1 ps = dOpen processFunctions ps >>= io_init+++instance Processes pdef => Processes [pdef] where+	startProcesses []+		= return ()+	startProcesses pdefs+		= do {			+			initialContext  <- initContext [] io_init1 () NDI;+			(case initialContext of+				Just context -> handleEvents context >> closeContext context+				initFailed   -> stdprocessFatalError "startProcesses" "should not be evaluated inside GUI context");+		  }+		where+			io_init1 ps = dOpen processFunctions ps >>= (\ps1 -> openProcesses pdefs >> closeProcess ps1)++	openProcesses pdefs+		= sequence_ (map openProcesses pdefs)+++--	Specialised process creation functions:++-- | Using of that function is the standard way for a single processed applications to run GUI.+startIO :: DocumentInterface -> ps -> ProcessInit ps -> [ProcessAttribute ps] -> IO ()+startIO xDI ps io_init atts+	= startProcesses (Process xDI ps io_init atts)+++--	Close this interactive process.++-- | The function terminates the current process.+closeProcess :: ps -> GUI ps ps+closeProcess ps = quitProcess ps++-- | Get the current position of the ProcessWindow (on Macintosh: zero).+getProcessWindowPos :: GUI ps Point2+getProcessWindowPos = do	+	osdinfo <- accIOEnv ioStGetOSDInfo+	rect <- liftIO (osGetProcessWindowDimensions osdinfo)+	return (Point2{x=rleft rect,y=rtop rect})++-- | Get the current size of the ProcessWindow (on Macintosh: ScreenSize).+getProcessWindowSize :: GUI ps Size+getProcessWindowSize = do+	osdinfo <- accIOEnv ioStGetOSDInfo+	rect <- liftIO (osGetProcessWindowDimensions osdinfo)	+	return (rectSize rect)
+ Graphics/UI/ObjectIO/StdProcessAttribute.hs view
@@ -0,0 +1,106 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdProcessAttribute+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdProcessAttribute specifies which ProcessAttributes are valid for +-- each of the standard interactive processes. Basic comparison operations +-- and retrieval functions are also included.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdProcessAttribute+		( isProcessKindAttribute+		, isProcessActivate, 	getProcessActivateFun +		, isProcessClose, 	getProcessCloseFun+		, isProcessDeactivate, 	getProcessDeactivateFun+		, isProcessNoWindowMenu+		, isProcessOpenFiles, 	getProcessOpenFilesFun+		, isProcessToolbar, 	getProcessToolbarAtt+		, isProcessWindowPos, 	getProcessWindowPosAtt+		, isProcessWindowResize,getProcessWindowResizeFun+		, isProcessWindowSize, 	getProcessWindowSizeAtt+		, module Graphics.UI.ObjectIO.StdProcessDef+		) where+++import Graphics.UI.ObjectIO.StdProcessDef+++isProcessKindAttribute :: DocumentInterface -> ProcessAttribute ps -> Bool +isProcessKindAttribute di (ProcessActivate     _) = True+isProcessKindAttribute di (ProcessClose        _) = True+isProcessKindAttribute di (ProcessDeactivate   _) = True+isProcessKindAttribute di (ProcessNoWindowMenu  ) = di == MDI+isProcessKindAttribute di (ProcessOpenFiles    _) = di /= NDI+isProcessKindAttribute di (ProcessToolbar      _) = di /= NDI+isProcessKindAttribute di (ProcessWindowPos    _) = di /= NDI+isProcessKindAttribute di (ProcessWindowResize _) = di /= NDI+isProcessKindAttribute di (ProcessWindowSize   _) = di /= NDI+++isProcessActivate :: ProcessAttribute ps -> Bool +isProcessActivate (ProcessActivate _) = True+isProcessActivate _ = False++isProcessClose :: ProcessAttribute ps -> Bool +isProcessClose (ProcessClose _) = True+isProcessClose _ = False++isProcessDeactivate :: ProcessAttribute ps -> Bool +isProcessDeactivate (ProcessDeactivate _) = True+isProcessDeactivate _ = False++isProcessNoWindowMenu :: ProcessAttribute ps -> Bool +isProcessNoWindowMenu ProcessNoWindowMenu = True+isProcessNoWindowMenu _ = False++isProcessOpenFiles :: ProcessAttribute ps -> Bool +isProcessOpenFiles (ProcessOpenFiles _) = True+isProcessOpenFiles _ = False++isProcessToolbar :: ProcessAttribute ps -> Bool +isProcessToolbar (ProcessToolbar _) = True+isProcessToolbar _ = False++isProcessWindowPos :: ProcessAttribute ps -> Bool +isProcessWindowPos (ProcessWindowPos _) = True+isProcessWindowPos _ = False++isProcessWindowResize :: ProcessAttribute ps -> Bool +isProcessWindowResize (ProcessWindowResize _) = True+isProcessWindowResize _ = False++isProcessWindowSize :: ProcessAttribute ps -> Bool +isProcessWindowSize (ProcessWindowSize _) = True+isProcessWindowSize _ = False++getProcessActivateFun :: ProcessAttribute ps -> (ps -> GUI ps ps)+getProcessActivateFun (ProcessActivate f) = f++getProcessCloseFun :: ProcessAttribute ps -> ps -> GUI ps ps+getProcessCloseFun (ProcessClose f) = f++getProcessDeactivateFun :: ProcessAttribute ps -> (ps -> GUI ps ps)+getProcessDeactivateFun (ProcessDeactivate f) = f++getProcessOpenFilesFun :: ProcessAttribute ps -> ProcessOpenFilesFunction ps+getProcessOpenFilesFun (ProcessOpenFiles f) = f++getProcessToolbarAtt :: ProcessAttribute ps -> [ToolbarItem ps]+getProcessToolbarAtt (ProcessToolbar t) = t++getProcessWindowPosAtt :: ProcessAttribute ps -> ItemPos+getProcessWindowPosAtt (ProcessWindowPos pos) = pos++getProcessWindowResizeFun :: ProcessAttribute ps -> ProcessWindowResizeFunction ps+getProcessWindowResizeFun (ProcessWindowResize f) = f++getProcessWindowSizeAtt :: ProcessAttribute ps -> Size+getProcessWindowSizeAtt (ProcessWindowSize size) = size+
+ Graphics/UI/ObjectIO/StdProcessDef.hs view
@@ -0,0 +1,37 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdProcessDef+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdProcessDef contains the types to define interactive processes.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdProcessDef+	( +	-- * Defintions+	  module Graphics.UI.ObjectIO.StdProcessDef,+	-- * A visible modules+	  module Graphics.UI.ObjectIO.StdIOCommon+	, module Graphics.UI.ObjectIO.StdGUI+	) where+++import Graphics.UI.ObjectIO.StdGUI+import Graphics.UI.ObjectIO.StdIOCommon+++-- | Standard process definition type+data	Process+	= forall ps . Process+			DocumentInterface	-- The process document interface+			ps			-- The process private state+			(ProcessInit ps)	-- The process initialisation+			[ProcessAttribute ps]	-- The process attributes+type	ProcessInit ps+	= ps -> GUI ps ps
+ Graphics/UI/ObjectIO/StdReceiver.hs view
@@ -0,0 +1,306 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdReceiver+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdReceiver specifies all receiver operations.+-- The receiver is a component which allows the communication between +-- different interactive process or between different devices +-- (For example from Timer device to Menu device) by user defined message events.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdReceiver+		(+		-- * Opening receivers+		  Receivers(..),+		-- * Closing receivers+		  closeReceiver,+		-- * Get the Ids of all current receivers+		  getReceivers,+		-- * Enabling\/Disabling of receivers+		  enableReceivers, disableReceivers, getReceiverSelectState,+		-- * Message passing+		  asyncSend, syncSend, syncSend2,+		-- * A visible module+		  module Graphics.UI.ObjectIO.StdReceiverDef+		) where++++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Device.Events+import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.Process.Scheduler+import Graphics.UI.ObjectIO.Receiver.Access+import Graphics.UI.ObjectIO.Receiver.DefAccess+import Graphics.UI.ObjectIO.Receiver.Device+import Graphics.UI.ObjectIO.Receiver.Handle+import Graphics.UI.ObjectIO.StdReceiverAttribute+import Graphics.UI.ObjectIO.StdReceiverDef+import Graphics.UI.ObjectIO.OS.Event+import Control.Monad(unless)+import System.IO(fixIO)+import Data.IORef+import qualified Data.Map as Map+++stdReceiverFatalError :: String -> String -> x+stdReceiverFatalError rule error+	= dumpFatalError rule "StdReceiver" error+++--	Open one-way receiver:++receiverStateIdentified :: Id -> ReceiverStateHandle ps -> Bool+receiverStateIdentified id (ReceiverStateHandle _ rH) = receiverIdentified id rH++class Receivers rdef where+	openReceiver :: ls -> rdef ls ps -> ps -> GUI ps ps+++instance Receivers (Receiver m) where+	openReceiver ls rDef ps+		= do {+			ps1 <- dOpen receiverFunctions ps;+			idtable      <-  ioStGetIdTable;+			if   Map.member id idtable+			then throwGUI ErrorIdsInUse+			else +			do {+				(found,rDevice) <- accIOEnv (ioStGetDevice ReceiverDevice);+				if   not found		-- This condition should not occur: ReceiverDevice has just been 'installed'+				then stdReceiverFatalError "openReceiver (Receiver)" "could not retrieve ReceiverSystemState from IOSt"+				else+				let  rsHs  = rReceivers (receiverSystemStateGetReceiverHandles rDevice)+				in+				do {+					ioId <- accIOEnv ioStGetIOId;+					ioStSetIdTable (Map.insert id (IdParent {idpIOId=ioId,idpDevice=ReceiverDevice,idpId=id}) idtable);+					ps2  <- toGUI (doInitIO (receiverInit (ls,ps1))+								(\ls ioState -> ioStSetDevice+										    (ReceiverSystemState+											 (ReceiverHandles+											     {rReceivers = (ReceiverStateHandle ls (newReceiverHandle rid select f)) : rsHs}))+										    ioState));+					return ps2+				}+			}+		  }+		where+			rid            = receiverDefRId        rDef+			select         = receiverDefSelectState rDef+			f              = receiverDefFunction    rDef+			rDefAttributes = receiverDefAttributes  rDef+			receiverInit   = getReceiverInitFun (snd (cselect isReceiverInit (ReceiverInit return) rDefAttributes))+			id             = rIdtoId rid+			+			+instance Receivers (Receiver2 m r) where+	openReceiver ls rDef ps+		= do {+			ps1 <- dOpen receiverFunctions ps;+			idtable      <-  ioStGetIdTable;+			if   Map.member id idtable+			then throwGUI ErrorIdsInUse+			else +			do {+				(found,rDevice) <- accIOEnv (ioStGetDevice ReceiverDevice);+				if   not found		-- This condition should not occur: ReceiverDevice has just been 'installed'+				then stdReceiverFatalError "openReceiver (Receiver)" "could not retrieve ReceiverSystemState from IOSt"+				else+				let  rsHs  = rReceivers (receiverSystemStateGetReceiverHandles rDevice)+				in+				do {					+					ioId <- accIOEnv ioStGetIOId;+					ioStSetIdTable (Map.insert id (IdParent {idpIOId=ioId,idpDevice=ReceiverDevice,idpId=id}) idtable);+					ps2  <- toGUI (doInitIO (receiverInit (ls,ps1))+								(\ls ioState -> ioStSetDevice+										    (ReceiverSystemState+											 (ReceiverHandles+											     {rReceivers = (ReceiverStateHandle ls (newReceiver2Handle rid select f)) : rsHs}))+										    ioState));+					return ps2+				}+			}+		  }+		where+			rid            = receiver2DefR2Id        rDef+			select         = receiver2DefSelectState rDef+			f              = receiver2DefFunction    rDef+			rDefAttributes = receiver2DefAttributes  rDef+			receiverInit   = getReceiverInitFun (snd (cselect isReceiverInit (ReceiverInit return) rDefAttributes))+			id             = r2IdtoId rid+++doInitIO :: GUI ps (ls,ps) -> (ls -> IOSt ps -> IOSt ps) -> IOSt ps -> IO (ps,IOSt ps)+doInitIO initGUI setReceiverLS ioState+	= do {+		r <- fixIO (\st -> fromGUI initGUI (setReceiverLS (fst (fst st)) ioState));+		let ((_,ps1),ioState1) = r+		in  return (ps1,ioState1)+	  }+++--	Closing receivers.++closeReceiver :: Id -> GUI ps ()+closeReceiver id+	= do {+		closed <- accIOEnv ioStClosed;+		if   closed+		then return ()+		else+		do {+			(found,rDevice) <- accIOEnv (ioStGetDevice ReceiverDevice);+			if   not found+			then return ()+			else +			let  rsHs              = rReceivers (receiverSystemStateGetReceiverHandles rDevice)+			     (found,rsH,rsHs1) = remove (receiverStateIdentified id) undefined rsHs+			in+			do {+				appIOEnv (ioStSetDevice (ReceiverSystemState (ReceiverHandles {rReceivers=rsHs1})));+				if   not found+				then return ()+				else +				do {+					idtable <- ioStGetIdTable;+					ioStSetIdTable (Map.delete id idtable);+				}+			}+		}+	  }+++--	Get the Ids of all current receivers:++getReceivers :: GUI ps [Id]+getReceivers+	= do {+		(found,rDevice) <- accIOEnv (ioStGetDevice ReceiverDevice);+		if   not found+		then return []+		else return (map  getreceiver (rReceivers (receiverSystemStateGetReceiverHandles rDevice)))+	  }+	where		+		getreceiver :: ReceiverStateHandle ps -> Id+		getreceiver rsH@(ReceiverStateHandle _ (ReceiverHandle {rId=rId})) = rId+		++--	Changing attributes:++enableReceivers  :: [Id] -> GUI ps ()+enableReceivers  ids = changeReceivers (receiverSetSelectState Able)   ids++disableReceivers :: [Id] -> GUI ps ()+disableReceivers ids = changeReceivers (receiverSetSelectState Unable) ids++changeReceivers :: IdFun (ReceiverStateHandle ps) -> [Id] -> GUI ps ()+changeReceivers changeReceiverState []  = return ()+changeReceivers changeReceiverState ids = +		do {+			(found,rDevice) <- accIOEnv (ioStGetDevice ReceiverDevice);+			if   not found+			then return ()+			else+			let  rsHs  = rReceivers $ receiverSystemStateGetReceiverHandles rDevice+			     rsHs1 = changereceiverstates changeReceiverState ids rsHs+			in+			do appIOEnv (ioStSetDevice (ReceiverSystemState (ReceiverHandles {rReceivers=rsHs1})));+		  }+	where+		changereceiverstates :: IdFun (ReceiverStateHandle ps) -> [Id] -> [ReceiverStateHandle ps] -> [ReceiverStateHandle ps]+		changereceiverstates _ [] _ = []+		changereceiverstates _ _ [] = []+		changereceiverstates f ids (rsH@(ReceiverStateHandle _ (ReceiverHandle {rId=rId})) : rsHs)+			| hadId       = (f rsH) : rsHs1+			| otherwise   =    rsH  : rsHs1+			where+				(hadId,_,ids1) = remove ((==) rId) (dummy "changereceiverstates") ids+				rsHs1 = changereceiverstates f ids1 rsHs+		+++--	Get the SelectState of a receiver:++getReceiverSelectState :: Id -> GUI ps (Maybe SelectState)+getReceiverSelectState id+		= do {+			(found,rDevice) <- accIOEnv (ioStGetDevice ReceiverDevice);+			if   not found+			then return Nothing+			else +			let  rsHs           = rReceivers $ receiverSystemStateGetReceiverHandles rDevice+			     (select,rsHs1) = getselectstate id rsHs+			in   appIOEnv (ioStSetDevice (ReceiverSystemState (ReceiverHandles {rReceivers=rsHs1}))) >> return select+		  }+	where+		getselectstate :: Id -> [ReceiverStateHandle ps] -> (Maybe SelectState,[ReceiverStateHandle ps])+		getselectstate id (rsH@(ReceiverStateHandle _ rH@(ReceiverHandle {rSelect=rSelect})) : rsHs)+			| receiverIdentified id rH = (Just rSelect, rsH:rsHs )+			| otherwise                = (select,       rsH:rsHs1)+			where+				(select,rsHs1)     = getselectstate id rsHs+		getselectstate _ _ = (Nothing,[])+++--	Message passing:+++{-	Asynchronous, uni-directional, message passing.+	If the receiver could not be found in the global ReceiverTable, +		then return SendUnknownReceiver and do nothing.+	If the receiver could be found, then increase the length of the +		asynchronous message queue of the receiver in the global +		ReceiverTable.+		Add the message to the asynchronous message queue of the +		receiver using the scheduler.+-}++asyncSend :: RId msg -> msg -> GUI ps ()+asyncSend rid msg = do+	it <- ioStGetIdTable+	unless (Map.member (rIdtoId rid) it) (throwGUI ErrorUnknownObject)+	liftIO (modifyIORef (getRIdIn rid) ((:) msg))	-- Put the msg in the async queue of the receiver+	ioStAppendEvents [ScheduleMsgEvent (rIdtoId rid)]+	return ()++{-	Synchronous message passing.+	If the receiver could not be found in the global ReceiverTable,+		then raise ErrorUnknownObject exception.+	If the receiver could be found, then let the receiver handle the+		synchronous message using the scheduler.+-}+syncSend :: RId msg -> msg -> ps -> GUI ps ps+syncSend rid msg ps = do+	it <- ioStGetIdTable+	unless (Map.member (rIdtoId rid) it) (throwGUI ErrorUnknownObject)+	liftIO (modifyIORef (getRIdIn rid) ((:) msg))	-- Put the msg in the async queue of the receiver+	(_,ps) <- liftContextIO (handleMsgEvent (rIdtoId rid)) ps+	return ps++{-	Synchronous bi-directional message passing.+	If the receiver could not be found in the global ReceiverTable,+		then raise ErrorUnknownObject exception.+	If the receiver could be found, then let the receiver handle the+		synchronous message using the scheduler.+-}+syncSend2 :: R2Id msg resp -> msg -> ps -> GUI ps (resp,ps)+syncSend2 rid msg ps = do+	it <- ioStGetIdTable+	unless (Map.member (r2IdtoId rid) it) (throwGUI ErrorUnknownObject)+	liftIO (writeIORef (getR2IdIn rid) msg)	-- Put the msg in the input of the receiver+	(_,ps) <- liftContextIO (handleMsgEvent (r2IdtoId rid)) ps+	out <- liftIO (readIORef (getR2IdOut rid))+	liftIO (writeIORef (getR2IdOut rid) undefined)  -- clearing receiver output+	return (out,ps)++handleMsgEvent :: Id -> Context -> IO [Int]+handleMsgEvent rId context = handleContextOSEvent context (ScheduleMsgEvent rId)
+ Graphics/UI/ObjectIO/StdReceiverAttribute.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdReceiverAttribute+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdReceiverAttribute specifies which ReceiverAttributes are valid for+-- each of the standard receivers. Basic comparison operations and +-- retrieval functions are also included.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdReceiverAttribute +		( module Graphics.UI.ObjectIO.StdReceiverAttribute+		, module Graphics.UI.ObjectIO.StdReceiverDef+		) where++++import Graphics.UI.ObjectIO.StdGUI+import Graphics.UI.ObjectIO.StdIOCommon+import Graphics.UI.ObjectIO.StdReceiverDef+++{-	The following functions specify the valid attributes for each standard receiver.+-}++isValidReceiverAttribute :: ReceiverAttribute ls ps -> Bool+isValidReceiverAttribute (ReceiverInit _)        = True+isValidReceiverAttribute (ReceiverSelectState _) = True++isValidReceiver2Attribute :: ReceiverAttribute ls ps -> Bool+isValidReceiver2Attribute (ReceiverInit _)        = True+isValidReceiver2Attribute (ReceiverSelectState _) = True+++isReceiverInit :: ReceiverAttribute ls ps -> Bool+isReceiverInit (ReceiverInit _) = True+isReceiverInit _                = False++isReceiverSelectState :: ReceiverAttribute ls ps -> Bool+isReceiverSelectState (ReceiverSelectState _) = True+isReceiverSelectState _                       = False++{-	TCP support not yet incorporated+isReceiverConnectedReceivers :: ReceiverAttribute ls ps -> Bool+isReceiverConnectedReceivers (ReceiverConnectedReceivers _) = True+isReceiverConnectedReceivers _                              = False+-}++getReceiverInitFun :: ReceiverAttribute ls ps -> GUIFun ls ps+getReceiverInitFun (ReceiverInit f) = f++getReceiverSelectStateAtt :: ReceiverAttribute ls ps -> SelectState+getReceiverSelectStateAtt (ReceiverSelectState s) = s++{-	TCP support not yet incorporated+getReceiverConnectedReceivers :: ReceiverAttribute ls ps -> [Id] -- MW11+++getReceiverConnectedReceivers (ReceiverConnectedReceivers ids) = ids+-}
+ Graphics/UI/ObjectIO/StdReceiverDef.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdReceiverDef+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdReceiverDef contains the types to define the standard set of receivers.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdReceiverDef +		( +		-- * Definitions+		  module Graphics.UI.ObjectIO.StdReceiverDef,+		  +		-- * A visible modules+		  module Graphics.UI.ObjectIO.StdIOCommon+		, module Graphics.UI.ObjectIO.StdGUI+		) where+++import Graphics.UI.ObjectIO.StdGUI+import Graphics.UI.ObjectIO.StdIOCommon+++-- | Uni-directional receiver. The uni-directional receiver can receive+-- messages but cann\'t respond to it.+data	Receiver         m ls ps = Receiver (RId m) (ReceiverFunction m ls ps) [ReceiverAttribute ls ps]+type	ReceiverFunction m ls ps = m -> GUIFun ls ps++-- | Bi-directional can receive messages and then must respond to it.+data	Receiver2         m r ls ps = Receiver2 (R2Id m r) (Receiver2Function m r ls ps) [ReceiverAttribute ls ps]+type	Receiver2Function m r ls ps = m -> (ls,ps) -> GUI ps (r,(ls,ps))++data	ReceiverAttribute ls ps				-- Default:+ =	ReceiverInit               (GUIFun ls ps)	-- no actions after opening receiver+ |	ReceiverSelectState        SelectState		-- receiver Able
+ Graphics/UI/ObjectIO/StdSound.hs view
@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdSound+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdSound specifies sound playing functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdSound(playSoundFile) where+++import 	Graphics.UI.ObjectIO.OS.ClCCall_12(winPlaySound)++playSoundFile :: String -> IO Bool+playSoundFile soundFileName = winPlaySound soundFileName
+ Graphics/UI/ObjectIO/StdSystem.hs view
@@ -0,0 +1,56 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdSystem+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdSystem defines platform dependent constants and functions. +--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdSystem where+++import	Graphics.UI.ObjectIO.OS.System+import	Graphics.UI.ObjectIO.StdIOBasic(Size(..))+++-- MW11+++newLineChars :: String+newLineChars = osNewLineChars++--	System dependencies concerning the time resolution+ticksPerSecond :: Int+ticksPerSecond = osTicksPerSecond+++--	System dependencies concerning the screen resolution+mmperinch = 25.4++hmm :: Float -> Int+hmm mm = osMMtoHPixels mm++vmm :: Float -> Int+vmm mm = osMMtoVPixels mm++hinch :: Float -> Int+hinch inch = osMMtoHPixels (inch*mmperinch)++vinch :: Float -> Int+vinch inch = osMMtoVPixels (inch*mmperinch)++maxScrollWindowSize :: Size+maxScrollWindowSize = Size {w=w,h=h}+	where (w,h) = osMaxScrollWindowSize++maxFixedWindowSize :: Size+maxFixedWindowSize = Size {w=w,h=h}+	where (w,h) = osMaxScrollWindowSize++-- MW11+++printSetupTypical :: Bool+printSetupTypical = osPrintSetupTypical
+ Graphics/UI/ObjectIO/StdTimer.hs view
@@ -0,0 +1,272 @@+module Graphics.UI.ObjectIO.StdTimer+		(+		-- * Opening timers+		  Timers(..),+		-- * Closing timers+		  closeTimer,+		-- * Get the Ids of all timers+		  getTimers,+		-- * Enable\/Disable timers+		  enableTimer, disableTimer, getTimerSelectState,+		-- * Timer interval+		setTimerInterval, getTimerInterval,+		-- * A visible module+		  module Graphics.UI.ObjectIO.StdTimerDef+		) where+++--	Clean Object I/O library, version 1.2++import	Graphics.UI.ObjectIO.CommonDef+import  Graphics.UI.ObjectIO.Id+import  Graphics.UI.ObjectIO.Process.IOState+import  Graphics.UI.ObjectIO.Timer.Access+import  Graphics.UI.ObjectIO.Timer.DefAccess+import  Graphics.UI.ObjectIO.Timer.Device+import  Graphics.UI.ObjectIO.Timer.Table+import  Graphics.UI.ObjectIO.Timer.Handle+import	Graphics.UI.ObjectIO.StdId+import	Graphics.UI.ObjectIO.StdTimerDef+import	Graphics.UI.ObjectIO.StdTimerAttribute+import	Graphics.UI.ObjectIO.StdTimerElementClass+import  Control.Monad(unless)+import  System.IO(fixIO)+import  qualified Data.Map as Map++stdTimerFatalError :: String -> String -> x+stdTimerFatalError function error+	= dumpFatalError function "StdTimer" error+++--	Open timer:++class Timers tdef where+	openTimer :: ls -> tdef ls ps -> ps -> GUI ps ps+	++instance TimerElements t => Timers (Timer t) where	+	openTimer ls tDef@(Timer period items atts) ps = do+		ps <- dOpen timerFunctions ps+		id <- validateTimerId maybeId+		(ok,timers) <- ioStGetTimerHandles+		unless ok (stdTimerFatalError "openTimer (Timer)" "could not retrieve TimerSystemState from IOSt")+		pid <- accIOEnv ioStGetIOId+		it <- ioStGetIdTable		+		tt <- ioStGetTimerTable+		ts <- timerElementToHandles items+		let itemHs = map timerElementStateToTimerElementHandle ts+		(case bindTimerElementIds pid id itemHs it of+			Just it -> do+				let tLoc = TimerLoc+					{ tlIOId	= pid+					, tlDevice	= TimerDevice+					, tlParentId	= id+					, tlTimerId	= id+					}+				let tt1	= if ableTimer then addTimerToTimerTable tLoc period tt else tt+				let it1	= Map.insert id IdParent{idpIOId=pid,idpDevice=TimerDevice,idpId=id} it+				ioStSetTimerTable tt1				+				ioStSetIdTable it1+				let tH = TimerHandle+					{ tId		= id+					, tSelect	= ableTimer+					, tPeriod	= max 0 period+					, tFun		= f+					, tItems	= itemHs+					}+				(_,ps) <- toGUI (\ioState -> fixIO(\st -> fromGUI (timerInit (ls,ps))+						(ioStSetDevice +							(TimerSystemState +								timers{tTimers=(TimerStateHandle (TimerLSHandle {tState=fst (fst st),tHandle=tH}):tTimers timers)})+							ioState)))+				return ps+			Nothing -> do+				appIOEnv (ioStSetDevice (TimerSystemState timers))+				throwGUI ErrorIdsInUse)+		where+			(hasIdAtt,idAtt)	= cselect isTimerId undefined atts+			maybeId			= if hasIdAtt then Just (getTimerIdAtt idAtt) else Nothing+			ableTimer		= enabled (getTimerSelectStateAtt (snd (cselect isTimerSelectState (TimerSelectState Able) atts)))+			f			= getTimerFun (snd (cselect isTimerFunction (TimerFunction (\_ st->return st)) atts))+			timerInit		= getTimerInitFun (snd (cselect isTimerInit (TimerInit return) atts))+			++			validateTimerId :: Maybe Id -> GUI ps Id+			validateTimerId Nothing = openId+			validateTimerId (Just id) = do+				it <- ioStGetIdTable+				(if Map.member id it then throwGUI ErrorIdsInUse+				 else return id)+	+	++eqTimerStateHandleId :: Id -> TimerStateHandle ps -> Bool+eqTimerStateHandleId id (TimerStateHandle (TimerLSHandle {tHandle=tH})) = id == tId tH+++--	Close timer:++closeTimer :: Id -> GUI ps ()+closeTimer id = do+	(ok,tHs) <- ioStGetTimerHandles+	(if not ok then return ()+	 else do+		pid <- accIOEnv ioStGetIOId+		tt <- ioStGetTimerTable+		it <- ioStGetIdTable+	  	let (tt1,it1) = closeTimer' id pid tt it (tTimers tHs)+		ioStSetIdTable it1+		ioStSetTimerTable tt1	  +		appIOEnv (ioStSetDevice (TimerSystemState tHs)))+	where+		closeTimer' :: Id -> SystemId -> TimerTable -> IdTable -> [TimerStateHandle ps] -> (TimerTable,IdTable)+		closeTimer' id pid tt it (tsH:tsHs)		+			| eqTimerStateHandleId id tsH = disposeElementIds pid tsH tt it+			| otherwise = closeTimer' id pid tt it tsHs+			where+				disposeElementIds :: SystemId -> TimerStateHandle ps -> TimerTable -> IdTable -> (TimerTable,IdTable)+				disposeElementIds pid (TimerStateHandle (TimerLSHandle {tHandle=tH})) tt it =+					let (tt1,it1) = unbindTimerElementIds pid (tItems tH) (tt,it)+					in (removeTimerFromTimerTable teLoc tt1,Map.delete (tId tH) it1)+					where+						teLoc	= TimerLoc {tlIOId=pid,tlDevice=TimerDevice,tlParentId=(tId tH),tlTimerId=(tId tH)}+		closeTimer' _ _ tt it [] = (tt,it)+++--	Get the Ids and TimerTypes of all timers:++getTimers :: GUI ps [Id]+getTimers = do+	(ok,tHs) <- ioStGetTimerHandles+	(if not ok then return []+	 else do+		let ids	= getIds (tTimers tHs)	  +		appIOEnv (ioStSetDevice (TimerSystemState tHs))+		return ids)+	where+		getIds :: [TimerStateHandle ps] -> [Id]+		getIds [] = []+		getIds (TimerStateHandle (TimerLSHandle {tHandle=tH}):tsHs) = (tId tH : getIds tsHs)+	+	++--	Enabling and Disabling of timers:++enableTimer :: Id -> GUI ps ()+enableTimer id = changeTimer id enableTimer'+	where+		enableTimer' :: TimerLoc -> TimerTable -> TimerStateHandle ps -> (TimerTable, TimerStateHandle ps)+		enableTimer' teLoc tt (TimerStateHandle tlsH@(TimerLSHandle {tHandle=tH}))+			| tSelect tH = (tt,TimerStateHandle tlsH)+			| otherwise  =+				let tt1 = addTimerToTimerTable teLoc (tPeriod tH) tt+				in (tt1,TimerStateHandle tlsH{tHandle=tH{tSelect=True}})++disableTimer :: Id -> GUI ps ()+disableTimer id = changeTimer id disableTimer'+	where+		disableTimer' :: TimerLoc -> TimerTable -> TimerStateHandle ps -> (TimerTable, TimerStateHandle ps)+		disableTimer' teLoc tt (TimerStateHandle tlsH@(TimerLSHandle {tHandle=tH}))+			| not (tSelect tH) = (tt,TimerStateHandle tlsH)+			| otherwise =+				let tt1 = removeTimerFromTimerTable teLoc tt+				in (tt1,TimerStateHandle tlsH{tHandle=tH{tSelect=False}})+++--	Get the SelectState of timers:++getTimerSelectState :: Id -> GUI ps (Maybe SelectState)+getTimerSelectState id = do+	(ok,tHs) <- ioStGetTimerHandles+	(if not ok then return Nothing+	 else do+		let maybe_select = getTimerSelect id (tTimers tHs)+		appIOEnv (ioStSetDevice (TimerSystemState tHs))+		return maybe_select)+	where+		getTimerSelect :: Id -> [TimerStateHandle ps] -> Maybe SelectState+		getTimerSelect id ((TimerStateHandle tlsH@(TimerLSHandle {tHandle=tH})):tsHs)+			| id == tId tH = Just (if tSelect tH then Able else Unable)+			| otherwise    = getTimerSelect id tsHs+		getTimerSelect _ [] = Nothing+++--	Set the TimerInterval of timers:++setTimerInterval :: Id -> TimerInterval -> GUI ps ()+setTimerInterval id interval = do+	changeTimer id (setTimerInterval' interval)+	where+		setTimerInterval' :: TimerInterval -> TimerLoc -> TimerTable -> TimerStateHandle ps -> (TimerTable, TimerStateHandle ps)+		setTimerInterval' period teLoc tt tsH@(TimerStateHandle tlsH@(TimerLSHandle {tHandle=tH}))+			| period' == tPeriod tH = (tt,tsH)+			| not (tSelect tH)	= (tt,tsH')+			| otherwise =+				let (_,tt) = setIntervalInTimerTable teLoc period' tt+				in (tt,tsH')+			where+				period'	= max 0 period+				tsH' = TimerStateHandle tlsH{tHandle=tH{tPeriod=period'}}+++-- Get the TimerInterval of timers:++getTimerInterval :: Id -> GUI ps (Maybe TimerInterval)+getTimerInterval id = do+	(ok,tHs) <- ioStGetTimerHandles+	(if not ok then return Nothing+	 else do+		let optInterval = getTimerInterval' id (tTimers tHs)	  +		appIOEnv (ioStSetDevice (TimerSystemState tHs))+		return optInterval)+	where+		getTimerInterval' :: Id -> [TimerStateHandle ps] -> Maybe TimerInterval+		getTimerInterval' id ((TimerStateHandle tlsH@(TimerLSHandle {tHandle=tH})):tsHs)+			| id == tId tH = Just (tPeriod tH)+			| otherwise    = getTimerInterval' id tsHs+		getTimerInterval' _ _  = Nothing+++ioStGetTimerHandles :: GUI ps (Bool,TimerHandles ps)+ioStGetTimerHandles = do+	(found,tDevice) <- accIOEnv (ioStGetDevice TimerDevice)+	(if not found then return (False,undefined)+	 else return (True,timerSystemStateGetTimerHandles tDevice))+++--	General TimerHandle changing function:++type DeltaTimerStateHandle ps = TimerLoc -> TimerTable -> TimerStateHandle ps -> (TimerTable,TimerStateHandle ps)++changeTimer :: Id -> DeltaTimerStateHandle ps -> GUI ps ()+changeTimer id f = do+	(ok,tHs) <- ioStGetTimerHandles+	(if not ok+	 then return ()+	 else do+		tt <- ioStGetTimerTable+		ioid <- accIOEnv ioStGetIOId+		let (tt1,tHs1) = changeTimerDevice ioid id f tt tHs+		appIOEnv (ioStSetDevice (TimerSystemState tHs1))+		ioStSetTimerTable tt1+		return ())+	where+		changeTimerDevice :: SystemId -> Id -> DeltaTimerStateHandle ps -> TimerTable -> TimerHandles ps -> (TimerTable,TimerHandles ps)+		changeTimerDevice ioid id f tt timers@(TimerHandles {tTimers=tsHs}) =+			let (tt1,tsHs1)	= changeTimerStateHandles ioid id f tt tsHs+			in (tt1,timers{tTimers=tsHs1})+			where+				changeTimerStateHandles :: SystemId -> Id -> DeltaTimerStateHandle ps -> TimerTable -> [TimerStateHandle ps] -> (TimerTable,[TimerStateHandle ps])+				changeTimerStateHandles ioid id f tt (tsH@(TimerStateHandle (TimerLSHandle {tHandle=tH})):tsHs)+					| id == tId tH =+						let+							teLoc		= TimerLoc{tlIOId=ioid,tlDevice=TimerDevice,tlParentId=id,tlTimerId=id}+							(tt1,tsH1)	= f teLoc tt tsH+						in+							 (tt1,tsH1:tsHs)+					| otherwise =+						let+							(tt1,tsHs1)	= changeTimerStateHandles ioid id f tt tsHs+						in +							(tt1,tsH:tsHs1)+				changeTimerStateHandles _ _ _ tt tsHs = (tt,tsHs)
+ Graphics/UI/ObjectIO/StdTimerAttribute.hs view
@@ -0,0 +1,68 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdTimerAttribute+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdTimerAttribute specifies which TimerAttributes are valid for each of +-- the standard timers. Basic comparison operations and retrieval functions +-- are also included.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdTimerAttribute+		( isValidTimerAttribute+		, isTimerFunction+		, isTimerId+		, isTimerInit+		, isTimerSelectState+		, getTimerFun+		, getTimerIdAtt+		, getTimerInitFun+		, getTimerSelectStateAtt+		, module Graphics.UI.ObjectIO.StdTimerDef+		) where+++import Graphics.UI.ObjectIO.StdTimerDef+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.Id++{-	The following functions specify the valid attributes for each standard timer. -}+++isValidTimerAttribute :: TimerAttribute ls ps -> Bool+isValidTimerAttribute _ = True+++isTimerFunction	:: TimerAttribute ls ps -> Bool+isTimerFunction	(TimerFunction _)	= True+isTimerFunction	_			= False++isTimerId	:: TimerAttribute ls ps -> Bool+isTimerId	(TimerId _)		= True+isTimerId	_			= False++isTimerInit	:: TimerAttribute ls ps -> Bool+isTimerInit	(TimerInit _)		= True+isTimerInit	_			= False++isTimerSelectState	:: TimerAttribute ls ps -> Bool+isTimerSelectState	(TimerSelectState _)	= True+isTimerSelectState	_			= False++getTimerFun :: TimerAttribute ls ps -> TimerFunction ls ps+getTimerFun (TimerFunction f) = f++getTimerIdAtt :: TimerAttribute ls ps -> Id+getTimerIdAtt (TimerId id) = id++getTimerInitFun :: TimerAttribute ls ps -> GUIFun ls ps+getTimerInitFun (TimerInit f) = f++getTimerSelectStateAtt :: TimerAttribute ls ps -> SelectState+getTimerSelectStateAtt (TimerSelectState s) = s
+ Graphics/UI/ObjectIO/StdTimerDef.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdTimerDef+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdTimerDef contains the types to define the standard set of timers.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdTimerDef+		(+		-- * Definitions+		  module Graphics.UI.ObjectIO.StdTimerDef,+		-- * A visible modules+		  module Graphics.UI.ObjectIO.StdIOCommon+		, module Graphics.UI.ObjectIO.StdGUI+		) where+++import	Graphics.UI.ObjectIO.StdIOCommon+import	Graphics.UI.ObjectIO.StdGUI++-- | Standard timer definition type+data Timer t ls ps = Timer TimerInterval (t ls ps) [TimerAttribute ls ps]++-- | Timer activation interval+type TimerInterval = Int++-- | Number of elapsed timer intervals+type NrOfIntervals = Int++data TimerAttribute ls ps					-- Default:+	= TimerFunction		(TimerFunction ls ps)		-- \_ x->x+	| TimerId		Id				-- no Id+	| TimerInit		(GUIFun ls ps)			-- no actions after opening timer+	| TimerSelectState	SelectState			-- timer Able++-- | Type of timer event handler. The argument of the handler+-- is the number of intervals elapsed between current and previous call.+type TimerFunction ls ps = NrOfIntervals -> GUIFun ls ps+
+ Graphics/UI/ObjectIO/StdTimerElementClass.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdTimerElementClass+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Definition of the TimerElements class for timer elements.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdTimerElementClass where++++import	Graphics.UI.ObjectIO.StdTimerDef+import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.Process.IOState+import	Graphics.UI.ObjectIO.Timer.Handle++-- | Translating timer elements into the internal representation.+-- There are instances for combinator types: 'AddLS', 'NewLS',+-- 'ListLS', 'NilLS' and 'TupLS'+class TimerElements t where+	timerElementToHandles	:: t ls ps -> GUI ps [TimerElementState ls ps]++instance TimerElements t => TimerElements (AddLS t) where+	timerElementToHandles (AddLS addLS addDef) = do+		ts <- timerElementToHandles addDef+		return [timerElementHandleToTimerElementState +				(TimerExtendLSHandle addLS+						     (map timerElementStateToTimerElementHandle ts))+			]+++instance TimerElements t => TimerElements (NewLS t) where+	timerElementToHandles (NewLS newLS newDef) = do+		ts <- timerElementToHandles newDef+		return [timerElementHandleToTimerElementState+				(TimerChangeLSHandle newLS+						     (map timerElementStateToTimerElementHandle ts))+			]+++instance TimerElements t => TimerElements (ListLS t) where	+	timerElementToHandles (ListLS tDefs) = do+		tss <- mapM timerElementToHandles tDefs+		return [timerElementHandleToTimerElementState +				(TimerListLSHandle (map timerElementStateToTimerElementHandle (concat tss)))+			]++instance TimerElements NilLS where	+	timerElementToHandles NilLS =+		return [timerElementHandleToTimerElementState (TimerListLSHandle [])]++instance (TimerElements t1, TimerElements t2) => TimerElements (TupLS t1 t2) where+	timerElementToHandles (t1:+:t2) = do+		ts1 <- timerElementToHandles t1+		ts2 <- timerElementToHandles t2+		return (ts1 ++ ts2)
+ Graphics/UI/ObjectIO/StdTimerReceiver.hs view
@@ -0,0 +1,47 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdTimerReceiver+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdTimerReceiver defines Receiver(2) instances of 'TimerElements' class.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdTimerReceiver where+++import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.Id+import	Graphics.UI.ObjectIO.Receiver.Access+import	Graphics.UI.ObjectIO.Receiver.DefAccess+import	Graphics.UI.ObjectIO.StdReceiverAttribute+import	Graphics.UI.ObjectIO.StdTimerDef+import	Graphics.UI.ObjectIO.StdTimerElementClass+import	Graphics.UI.ObjectIO.Timer.Handle+++instance TimerElements (Receiver m) where	+	timerElementToHandles (Receiver rid f atts) =+		return [timerElementHandleToTimerElementState+				(TimerReceiverHandle (newReceiverHandle rid (getSelectState atts) f)+						     (TimerId (rIdtoId rid):map receiverAttToTimerAtt atts))+			]+			+instance TimerElements (Receiver2 m r) where	+	timerElementToHandles (Receiver2 rid f atts) =+		return [timerElementHandleToTimerElementState+				(TimerReceiverHandle (newReceiver2Handle rid (getSelectState atts) f)+						     (TimerId (r2IdtoId rid):map receiverAttToTimerAtt atts))+			]+++receiverAttToTimerAtt :: ReceiverAttribute ls ps -> TimerAttribute ls ps+receiverAttToTimerAtt (ReceiverSelectState s) = TimerSelectState s++getSelectState :: [ReceiverAttribute ls ps] -> SelectState+getSelectState rAtts = getReceiverSelectStateAtt (snd (cselect isReceiverSelectState (ReceiverSelectState Able) rAtts))
+ Graphics/UI/ObjectIO/StdWindow.hs view
@@ -0,0 +1,1499 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdWindow+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdWindow defines functions on windows.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdWindow+		( +		-- * Opening windows+		  Windows(..), Dialogs(..),+		  +		-- * Closing windows+		  closeWindow, closeActiveWindow,+		  +		-- * Active window+		  setActiveWindow, getActiveWindow,+		  +		-- * Active control+		  setActiveControl, getActiveControl,+		  +		-- * Windows and dialogs stacking+		  stackWindow, getWindowStack, getWindowsStack, getDialogsStack,+		  +		-- * Layout attributes+		+		-- ** Default+		  getDefaultHMargin, getDefaultVMargin, getDefaultItemSpace,+		  +		-- ** Current+		  getWindowHMargin, getWindowVMargin, getWindowItemSpace,+		+		-- * Enable\/Disable windows+		  enableWindow, disableWindow+		, enableWindowMouse, disableWindowMouse, setWindowMouseSelectState+		, enableWindowKeyboard, disableWindowKeyboard, setWindowKeyboardSelectState+		, getWindowSelectState, getWindowMouseSelectState, getWindowKeyboardSelectState,+		+		-- * Mouse and keyboard event filters+		  getWindowMouseStateFilter, getWindowKeyboardStateFilter+		, setWindowMouseStateFilter, setWindowKeyboardStateFilter,+		+		-- * Drawing+		  drawInWindow, updateWindow+		, setWindowLook, getWindowLook,+		+		-- * Positioning & resizing+		  setWindowPos, getWindowPos+		, moveWindowViewFrame, getWindowViewFrame                 +		, setWindowViewSize, getWindowViewSize+		, setWindowOuterSize, getWindowOuterSize+		, setWindowViewDomain, getWindowViewDomain,+		+		-- * Scroll functions+		  setWindowScrollFunction, getWindowScrollFunction,+		+		-- * Window title+		  setWindowTitle, getWindowTitle,+		  +		-- * Window mouse cursor+		  setWindowCursor, getWindowCursor,+		+		-- * \"Ok\" and \"Cancel\" buttons+		  getWindowOk, getWindowCancel,+		  +		-- * Carret pos+		  setWindowCaretPos, getWindowCaretPos,+		  +		-- * Visible module+		  module Graphics.UI.ObjectIO.StdWindowDef+		) where++++import Data.List(find)+import qualified Data.Map as Map+import Control.Monad(when)+import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Control.Validate+import Graphics.UI.ObjectIO.Control.Layout(layoutControls)+import Graphics.UI.ObjectIO.Control.Relayout(relayoutControls)+import Graphics.UI.ObjectIO.Control.Internal(enablecontrols,disablecontrols)+import qualified Graphics.UI.ObjectIO.Control.Pos as CP+import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.Process.Scheduler(handleContextOSEvent)+import Graphics.UI.ObjectIO.StdControlClass+import Graphics.UI.ObjectIO.StdWindowDef+import Graphics.UI.ObjectIO.StdWindowAttribute+import Graphics.UI.ObjectIO.StdSystem(maxScrollWindowSize)+import Graphics.UI.ObjectIO.StdId(getParentId)+import Graphics.UI.ObjectIO.Window.Access+import Graphics.UI.ObjectIO.Window.Create+import Graphics.UI.ObjectIO.Window.Device+import Graphics.UI.ObjectIO.Window.Dispose+import Graphics.UI.ObjectIO.Window.Validate+import Graphics.UI.ObjectIO.Window.ClipState(validateWindowClipState, forceValidWindowClipState)+import qualified Graphics.UI.ObjectIO.Window.Draw as WD+import qualified Graphics.UI.ObjectIO.Window.Update as WU+import Graphics.UI.ObjectIO.Window.Draw(drawWindowLook)+import Graphics.UI.ObjectIO.Window.Update(updateWindowBackgrounds)+import Graphics.UI.ObjectIO.KeyFocus(getCurrentFocusItem)+import Graphics.UI.ObjectIO.OS.Picture(Draw(..))+import Graphics.UI.ObjectIO.OS.Window+import Graphics.UI.ObjectIO.OS.Event+import Graphics.UI.ObjectIO.OS.System(osStripOuterSize)+import Graphics.UI.ObjectIO.OS.ToolBar(OSToolbar(..))++++stdWindowFatalError :: String -> String -> x+stdWindowFatalError function error+	= dumpFatalError function "StdWindow" error++class Windows wdef where+	openWindow :: ls -> wdef ls ps -> ps -> GUI ps ps++	+--	Functions applied to non-existent windows or unknown ids have no effect.+class Dialogs ddef where+	openDialog :: ls -> ddef ls ps -> ps -> GUI ps ps+	openModalDialog	:: ls -> ddef ls ps -> ps -> GUI ps (ps, (Maybe ls))++ +instance Controls c => Windows (Window c) where	+	openWindow ls (Window title controls atts) ps+		= do {+			ps1 <- dOpen windowFunctions ps;+			isZero <- accIOEnv checkZeroWindowBound;+			if isZero then throwGUI ErrorViolateDI+			else do {+			   maybe_okId <- validateWindowId maybe_id;+			   case maybe_okId of+			   	Nothing -> throwGUI ErrorIdsInUse+			   	Just okId -> do+				  	cs   <- controlToHandles controls+				  	it   <- ioStGetIdTable+				  	ioId <- accIOEnv ioStGetIOId+				  	let itemHs = map controlStateToWElementHandle cs+				  	(case controlIdsAreConsistent ioId okId itemHs it of+				  		Nothing -> throwGUI ErrorIdsInUse+				  		Just it -> do+							ioStSetIdTable (Map.insert okId (IdParent {idpIOId=ioId,idpDevice=WindowDevice,idpId=okId}) it)+							ps2 <- openwindow okId (WindowLSHandle {wlsState=ls,wlsHandle=initWindowHandle title Modeless IsWindow NoWindowInfo itemHs atts}) ps1+							appIOEnv decreaseWindowBound+							return ps2)+				  }+			  }+		where+			maybe_id = getWindowIdAttribute atts+++instance Controls c => Dialogs (Dialog c) where+	openDialog ls (Dialog title controls atts) ps+		= do {+			ps1 <- dOpen windowFunctions ps;+			maybe_okId <- validateWindowId maybe_id;+			case maybe_okId of+				Nothing   -> throwGUI ErrorIdsInUse+				Just okId -> do+					cs   <- controlToHandles controls+					it   <- ioStGetIdTable					+					ioId <- accIOEnv ioStGetIOId+					let itemHs          = map controlStateToWElementHandle cs				    +				    	(case controlIdsAreConsistent ioId okId itemHs it of+				    		Nothing -> throwGUI ErrorIdsInUse+				    		Just it -> do+							ioStSetIdTable (Map.insert okId (IdParent {idpIOId=ioId,idpDevice=WindowDevice,idpId=okId}) it)+							openwindow okId (WindowLSHandle {wlsState=ls,wlsHandle=initWindowHandle title Modeless IsDialog NoWindowInfo itemHs atts}) ps1)+		}+		where+			maybe_id = getWindowIdAttribute atts+++	openModalDialog ls (Dialog title controls atts) ps+		= do {+			ps1 <- dOpen windowFunctions ps;+			maybe_okId <- validateWindowId maybe_id;+			case maybe_okId of+				Nothing   -> throwGUI ErrorIdsInUse+				Just okId -> do+					cs   <- controlToHandles controls+					it   <- ioStGetIdTable+					ioId <- accIOEnv ioStGetIOId+					let itemHs          = map controlStateToWElementHandle cs+				    	(case controlIdsAreConsistent ioId okId itemHs it of+				    		Nothing -> throwGUI ErrorIdsInUse+				    		Just it -> do+							ioStSetIdTable (Map.insert okId (IdParent {idpIOId=ioId,idpDevice=WindowDevice,idpId=okId}) it)+							openModalWindow okId (WindowLSHandle {wlsState=ls,wlsHandle=initWindowHandle title Modal IsDialog NoWindowInfo itemHs atts}) ps1)+		}+		where+			maybe_id = getWindowIdAttribute atts+++getWindowIdAttribute :: [WindowAttribute ls ps] -> Maybe Id+getWindowIdAttribute atts+	| hasIdAtt  = Just (getWindowIdAtt idAtt)+	| otherwise = Nothing+	where+		(hasIdAtt,idAtt) = cselect isWindowId undefined atts+++-- | closeWindow closes the indicated window.+closeWindow :: Id -> ps -> GUI ps ps+closeWindow id ps+	= disposeWindow (toWID id) ps++-- | closeActiveWindow closes the current active window.+closeActiveWindow :: ps -> GUI ps ps+closeActiveWindow ps+	= do {+		maybeId <- getActiveWindow;+		if   isNothing maybeId+		then return ps+		else closeWindow (fromJust maybeId) ps+	  }++-- | Call this function to activate and restore the window so that it is visible and available to the user.+setActiveWindow :: Id -> GUI ps ()+setActiveWindow winId = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else let windows	= windowSystemStateGetWindowHandles wDevice+	      in+	     	if not (hasWindowHandlesWindow wid windows) then return ()	-- Indicated window does not exist+		else case getWindowHandlesActiveWindow windows of+			Just wids | wId wids /= winId ->+				let (modal,modeless) = span isModalWindow (whsWindows windows)+				in if any (identifyWindowStateHandle wid) modal+				   then return ()+				   else do+					   osdInfo <- accIOEnv ioStGetOSDInfo+					   let isSDI = getOSDInfoDocumentInterface osdInfo==SDI+					   let (framePtr,clientPtr) = case getOSDInfoOSInfo osdInfo of+						  Just info -> (osFrame info, osClient info)+						  _         -> (osNoWindowPtr,osNoWindowPtr)+					   (if null modal	-- There are no modal windows, so put activated window in front+					    then let+						   (_,wsH,others) = remove (identifyWindowStateHandle wid) undefined modeless+						   shown = getWindowStateHandleShow wsH+						   wids = getWindowStateHandleWIDS wsH+						   activatePtr = if isSDI && wPtr wids==clientPtr then framePtr else wPtr wids	-- Do not activate SDI client, but SDI frame+						 in do+						   appIOEnv (ioStSetDevice (WindowSystemState windows{whsWindows=wsH:others}))+						   liftIO (if shown then return [] else osShowWindow activatePtr True)+						   context <- accIOEnv ioStGetContext+						   delayinfo <- liftIO (osActivateWindow osdInfo activatePtr (handleOSEvent context))+						   bufferDelayedEvents delayinfo+					    else let		-- There are modal windows, so put activated window behind last modal+						   (befModals,lastModal) = initLast modal+						   modalWIDS = getWindowStateHandleWIDS lastModal+						   (_,wsH,others) = remove (identifyWindowStateHandle wid) undefined modeless+						   shown = getWindowStateHandleShow wsH+						   modelessWIDS	= getWindowStateHandleWIDS wsH+						   activatePtr = if isSDI && wPtr modelessWIDS==clientPtr then framePtr else wPtr modelessWIDS	-- Do not activate SDI client, but SDI frame+						 in do+						   appIOEnv (ioStSetDevice (WindowSystemState windows{whsWindows=befModals++(lastModal:wsH:others)}))+						   liftIO (if shown then return [] else osShowWindow activatePtr True)+						   context <- accIOEnv ioStGetContext+						   delayinfo <- liftIO (osStackWindow activatePtr (wPtr modalWIDS) (handleOSEvent context))+						   bufferDelayedEvents delayinfo)+			_ -> return ())+	where+		wid = toWID winId+++-- | Call this function to obtain an Id of the active window.+getActiveWindow :: GUI ps (Maybe Id)+getActiveWindow+	= do {+		(found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice);+		if   not found+		then return Nothing+		else let+			windows    = windowSystemStateGetWindowHandles wDevice+			activeWIDS = getWindowHandlesActiveWindow windows+		in do {+			appIOEnv (ioStSetDevice (WindowSystemState windows));+			return (fmap wId activeWIDS)+		   }+	  }+	  +-- | Claims the input focus. The input focus directs all subsequent keyboard input to this window. +-- Any window that previously had the input focus loses it. setActiveControl makes the indicated+-- control active only if its parent window is already active.+setActiveControl :: Id -> GUI ps ()+setActiveControl controlId = do+	mb_parentId <- getParentId controlId+	mb_activeId <- getActiveWindow+	(case (mb_parentId,mb_activeId) of+		(Just parentId,Just activeId) | parentId==activeId -> do+			(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+			(if not found then return ()+			 else let +				windows	= windowSystemStateGetWindowHandles wDevice+				(found,wsH,windows1) = getWindowHandlesWindow (toWID activeId) windows+			      in+				(if not found+				 then stdWindowFatalError "setActiveControl" "parent window could not be located"+				 else do+					(delayinfo,wsH)	<- liftIO (setactivecontrol controlId wsH)+					let windows2 = setWindowHandlesWindow wsH windows1+					appIOEnv (ioStSetDevice (WindowSystemState windows2))+					bufferDelayedEvents delayinfo))+		_	-> return ())+	where+		setactivecontrol :: Id -> WindowStateHandle ps -> IO ([DelayActivationInfo],WindowStateHandle ps)+		setactivecontrol controlId (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) =+			let (found,itemNr,itemPtr,itemHs)	= getWElementHandlesItemNrPtr controlId (whItems wH)+			in if not found+			   then stdWindowFatalError "setActiveControl" "indicated control could not be located"+			   else do+			   		delayinfo <- osActivateControl (wPtr wids) itemPtr+					return (delayinfo,(WindowStateHandle wids (Just wlsH{wlsHandle=wH{whItems=itemHs}})))++			where+				getWElementHandlesItemNrPtr :: Id -> [WElementHandle ls ps] -> (Bool,Int,OSWindowPtr,[WElementHandle ls ps])+				getWElementHandlesItemNrPtr id (itemH:itemHs) =+					let (found,itemNr,itemPtr,itemH1) = getWElementHandleItemNrPtr id itemH+					in if found then (found,itemNr,itemPtr,itemH1:itemHs)+					   else let (found,itemNr,itemPtr,itemHs1) = getWElementHandlesItemNrPtr id itemHs+						in (found,itemNr,itemPtr,itemH1:itemHs1)+					where+						getWElementHandleItemNrPtr :: Id -> WElementHandle ls ps -> (Bool,Int,OSWindowPtr,WElementHandle ls ps)+						getWElementHandleItemNrPtr id itemH@(WItemHandle {wItemNr=wItemNr,wItems=itemHs,wItemId=itemId,wItemPtr=wItemPtr})+							| itemId /= Just id =+								let (found,itemNr,itemPtr,itemHs1) = getWElementHandlesItemNrPtr id itemHs+								in (found,itemNr,itemPtr,itemH{wItems=itemHs1})+							| otherwise = (True,wItemNr,wItemPtr,itemH)+						getWElementHandleItemNrPtr itemNr (WListLSHandle itemHs) =+							let (found,itemNr,itemPtr,itemHs1) = getWElementHandlesItemNrPtr id itemHs+							in (found,itemNr,itemPtr,WListLSHandle itemHs1)+						getWElementHandleItemNrPtr itemNr (WExtendLSHandle exLS itemHs) =+							let (found,itemNr,itemPtr,itemHs1) = getWElementHandlesItemNrPtr id itemHs+							in (found,itemNr,itemPtr,WExtendLSHandle exLS itemHs)+						getWElementHandleItemNrPtr itemNr (WChangeLSHandle chLS itemHs) =+							let (found,itemNr,itemPtr,itemHs1) = getWElementHandlesItemNrPtr id itemHs+							in (found,itemNr,itemPtr,WChangeLSHandle chLS itemHs)+				getWElementHandlesItemNrPtr _ _ = (False,0,osNoWindowPtr,[])+		setactivecontrol _ _ = stdWindowFatalError "setActiveControl" "unexpected window placeholder argument"++++-- | Retrieves an Id of the control that currently has the input focus.+getActiveControl :: GUI ps (Maybe Id)+getActiveControl = do+	mb_activeId <- getActiveWindow+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(case mb_activeId of+		Just activeId | found ->+			let+				windows	= windowSystemStateGetWindowHandles wDevice+				(hasWindow,wsH,windows1) = getWindowHandlesWindow (toWID activeId) windows+				keyfocus = getWindowStateHandleKeyFocus wsH+			in+				if not hasWindow then stdWindowFatalError "getActiveControl" "active window could not be located"+				else case getCurrentFocusItem keyfocus of+					Nothing     -> return Nothing+					Just itemNr -> return (getControlIdFromItemNr itemNr wsH)+		Nothing -> return Nothing)+	where+		getControlIdFromItemNr :: Int -> WindowStateHandle ps -> Maybe Id+		getControlIdFromItemNr itemNr (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) =+			getWElementHandlesIdFromItemNr itemNr (whItems wH)			+			where+				getWElementHandlesIdFromItemNr :: Int -> [WElementHandle ls ps] -> Maybe Id+				getWElementHandlesIdFromItemNr itemNr (itemH:itemHs)+					| isJust foundId = foundId+					| otherwise	 = getWElementHandlesIdFromItemNr itemNr itemHs+					where+						foundId = getWElementHandleIdFromItemNr itemNr itemH++						getWElementHandleIdFromItemNr :: Int -> WElementHandle ls ps -> Maybe Id+						getWElementHandleIdFromItemNr itemNr (WItemHandle {wItemNr=wItemNr,wItems=itemHs,wItemId=itemId})+							| itemNr/=wItemNr = getWElementHandlesIdFromItemNr itemNr itemHs+							| otherwise 	  = itemId+						getWElementHandleIdFromItemNr itemNr (WListLSHandle itemHs) =+							getWElementHandlesIdFromItemNr itemNr itemHs+						getWElementHandleIdFromItemNr itemNr (WExtendLSHandle exLS itemHs) =+							getWElementHandlesIdFromItemNr itemNr itemHs+						getWElementHandleIdFromItemNr itemNr (WChangeLSHandle chLS itemHs) =+							getWElementHandlesIdFromItemNr itemNr itemHs+				getWElementHandlesIdFromItemNr _ _ = Nothing+		getControlIdFromItemNr _ _ = stdWindowFatalError "getActiveControl" "unexpected window placeholder argument"+++-- | stackWindow changes the stacking order of the current windows.+stackWindow :: Id -> Id -> GUI ps ()+stackWindow windowId behindId+	| windowId==behindId = return ()				-- Don't stack a window behind itself+	| otherwise = do+		(found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+		(if not found then return ()+		 else let windows	= windowSystemStateGetWindowHandles wDevice+		      in if not (hasWindowHandlesWindow behindWID windows) then return ()		-- Behind window does not exist+			 else let (hasWindow,wsH,windows1) = getWindowHandlesWindow windowWID windows+			      in if not hasWindow || getWindowStateHandleWindowMode wsH==Modal 		-- Stack window does not exist or it's modal, skip+			      then return ()					+			      else do+			     		let (_,_,windows2) = removeWindowHandlesWindow windowWID windows1	-- remove placeholder window+					let wids = getWindowStateHandleWIDS wsH+					let (behindWIDS,windows3) = addBehindWindowHandlesWindow behindWID wsH windows2+					appIOEnv (ioStSetDevice (WindowSystemState windows3))+					context <- accIOEnv ioStGetContext+					delayinfo <- liftIO (osStackWindow (wPtr wids) (wPtr behindWIDS) (handleOSEvent context))+					bufferDelayedEvents delayinfo)+	where+		windowWID	= toWID windowId+		behindWID	= toWID behindId+++--	handleOSEvent turns handleContextOSEvent into the form required by osActivateWindow and osStackWindow.+--	(Used by stackWindow, setActiveWindow.)+handleOSEvent :: Context -> OSEvent -> IO ()+handleOSEvent context osEvent = do+	handleContextOSEvent context (ScheduleOSEvent osEvent [])+	return ()+++-- | returns list of window and dialog ids in stacking order.+getWindowStack :: GUI ps [(Id,WindowKind)]+getWindowStack = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return []+	 else let windows = windowSystemStateGetWindowHandles wDevice+	      in return (map getWindowIdType (whsWindows windows)))+	where+		getWindowIdType :: WindowStateHandle ps -> (Id,WindowKind)+		getWindowIdType wsH = (wId wids,kind)+			where+				wids = getWindowStateHandleWIDS wsH+				kind = getWindowStateHandleWindowKind wsH++-- | returns list of window ids in stacking order.+getWindowsStack :: GUI ps [Id]+getWindowsStack = do+	id_types <- getWindowStack+	return (filterMap (\(id,kind)->(kind==IsWindow,id)) id_types)++-- | returns list of dialog ids in stacking order.+getDialogsStack :: GUI ps [Id]+getDialogsStack = do+	id_types <- getWindowStack+	return (filterMap (\(id,kind)->(kind==IsDialog,id)) id_types)+++--	Return layout attributes and default values.++getDefaultHMargin :: Bool -> GUI ps Int+getDefaultHMargin isWindow+	| isWindow  = return 0+	| otherwise = do+		wMetrics <- accIOEnv ioStGetOSWindowMetrics+		return (osmHorMargin wMetrics)+		+getDefaultVMargin :: Bool -> GUI ps Int+getDefaultVMargin isWindow+	| isWindow  = return 0+	| otherwise = do+		wMetrics <- accIOEnv ioStGetOSWindowMetrics+		return (osmVerMargin wMetrics)+		++getDefaultItemSpace :: GUI ps (Int,Int)+getDefaultItemSpace = do+	wMetrics <- accIOEnv ioStGetOSWindowMetrics+	return (osmHorItemSpace wMetrics,osmVerItemSpace wMetrics)+++getWindowHMargin :: Id	-> GUI ps (Maybe (Int,Int))+getWindowHMargin id = do+	(found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return Nothing+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found then return Nothing+		 else do+			wMetrics <- accIOEnv ioStGetOSWindowMetrics+			let marginAtt = gethmargin wMetrics wsH+			return (Just marginAtt))+	where+		gethmargin :: OSWindowMetrics -> WindowStateHandle ps -> (Int,Int)+		gethmargin wMetrics (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) =+			getWindowHMargins (whKind wH) wMetrics (whAtts wH)+		gethmargin _ _ = stdWindowFatalError "getWindowHMargin" "unexpected window placeholder argument"+		++getWindowVMargin :: Id	-> GUI ps (Maybe (Int,Int))+getWindowVMargin id = do+	(found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return Nothing+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found then return Nothing+		 else do+			wMetrics <- accIOEnv ioStGetOSWindowMetrics+			let marginAtt = getvmargin wMetrics wsH+			return (Just marginAtt))+	where+		getvmargin :: OSWindowMetrics -> WindowStateHandle ps -> (Int,Int)+		getvmargin wMetrics (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) =+			getWindowVMargins (whKind wH) wMetrics (whAtts wH)+		getvmargin _ _ = stdWindowFatalError "getWindowVMargin" "unexpected window placeholder argument"+++getWindowItemSpace :: Id -> GUI ps (Maybe (Int,Int))+getWindowItemSpace id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return Nothing+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found then return Nothing+		 else do+			wMetrics <- accIOEnv ioStGetOSWindowMetrics+			let marginAtt = getitemspaces (osmHorItemSpace wMetrics,osmVerItemSpace wMetrics) wsH+			return (Just marginAtt))+	where+		getitemspaces :: (Int,Int) -> WindowStateHandle ps -> (Int,Int)+		getitemspaces (defHSpace,defVSpace) (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) =+			getWindowItemSpaceAtt (snd (cselect isWindowItemSpace (WindowItemSpace defHSpace defVSpace) (whAtts wH)))+		getitemspaces _ _ = stdWindowFatalError "getWindowItemSpace" "unexpected window placeholder argument"+++--	Setting the SelectState of windows.++enableWindow :: Id -> GUI ps ()+enableWindow id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found || getWindowStateHandleWindowKind wsH/=IsWindow || getWindowStateHandleSelect wsH+	         then return ()+	         else do+			osdInfo <- accIOEnv ioStGetOSDInfo+			wMetrics <- accIOEnv ioStGetOSWindowMetrics+		  	let wsH1 = setWindowStateHandleSelect True wsH+			wsH2 <- liftIO (enableControls osdInfo wMetrics wsH1)+			appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH2 windows1))))+	where+		enableControls :: OSDInfo -> OSWindowMetrics -> WindowStateHandle ps -> IO (WindowStateHandle ps)+		enableControls osdInfo wMetrics (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) = do+			let framePtr = case getOSDInfoOSInfo osdInfo of+				Just info -> osFrame info+		  		Nothing   -> osNoWindowPtr+			wH <- enablecontrols [] True wMetrics (wPtr wids) wH+			let scrollInfo = case whWindowInfo wH of+				info@(WindowInfo {}) -> (isJust (windowHScroll info),isJust (windowVScroll info))+				NoWindowInfo	     -> (False,False)+			osEnableWindow (if getOSDInfoDocumentInterface osdInfo==SDI then framePtr else wPtr wids) scrollInfo False+			osInvalidateWindow (wPtr wids)+			return (WindowStateHandle wids (Just wlsH{wlsHandle=wH}))++disableWindow :: Id -> GUI ps ()+disableWindow id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found || getWindowStateHandleWindowKind wsH/=IsWindow || not (getWindowStateHandleSelect wsH)+		 then return ()+		 else do+			osdInfo <- accIOEnv ioStGetOSDInfo+			wMetrics <- accIOEnv ioStGetOSWindowMetrics+		  	let wsH1 = setWindowStateHandleSelect False wsH+			wsH2 <- liftIO (disableControls osdInfo wMetrics wsH1)+			appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH2 windows1))))+	where+		disableControls :: OSDInfo -> OSWindowMetrics -> WindowStateHandle ps -> IO (WindowStateHandle ps)+		disableControls osdInfo wMetrics (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) = do+			let framePtr = case getOSDInfoOSInfo osdInfo of+				Just info -> osFrame info+		  		Nothing   -> osNoWindowPtr+			wH <- disablecontrols [] True wMetrics (wPtr wids) wH+			let scrollInfo = case whWindowInfo wH of+				info@(WindowInfo {}) -> (isJust (windowHScroll info),isJust (windowVScroll info))+				NoWindowInfo 	     -> (False,False)+			osDisableWindow (if getOSDInfoDocumentInterface osdInfo==SDI then framePtr else wPtr wids) scrollInfo False+			osInvalidateWindow (wPtr wids)+			return (WindowStateHandle wids (Just wlsH{wlsHandle=wH}))++enableWindowMouse  :: Id -> GUI ps ()+enableWindowMouse  id = setWindowMouseSelectState Able   id++disableWindowMouse :: Id -> GUI ps ()+disableWindowMouse id = setWindowMouseSelectState Unable id++setWindowMouseSelectState :: SelectState -> Id -> GUI ps ()+setWindowMouseSelectState selectState id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in+		if not found+		then appIOEnv (ioStSetDevice (WindowSystemState windows))+		else if getWindowStateHandleWindowKind wsH /= IsWindow+		     then appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+		     else+			let wsH1 = setMouseSelectState selectState wsH+			in appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH1 windows1))))+	where+		setMouseSelectState :: SelectState -> WindowStateHandle ps -> WindowStateHandle ps+		setMouseSelectState selectState (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) =+			WindowStateHandle wids (Just wlsH{wlsHandle=wH{whAtts=setMouseSelectStateAtt selectState (whAtts wH)}})+			where+				setMouseSelectStateAtt :: SelectState -> [WindowAttribute ls ps] -> [WindowAttribute ls ps]+				setMouseSelectStateAtt selectState atts+					| not found = atts+					| otherwise =+						let (filter,_,fun) = getWindowMouseAtt mouseAtt+						in (WindowMouse filter selectState fun:atts1)+					where+						(found,mouseAtt,atts1) = remove isWindowMouse undefined atts+		setMouseSelectState _ _ = stdWindowFatalError "setWindowMouseSelectState" "unexpected window placeholder argument"+++enableWindowKeyboard  :: Id -> GUI ps ()+enableWindowKeyboard  id = setWindowKeyboardSelectState Able   id++disableWindowKeyboard :: Id -> GUI ps ()+disableWindowKeyboard id = setWindowKeyboardSelectState Unable id++setWindowKeyboardSelectState :: SelectState -> Id -> GUI ps ()+setWindowKeyboardSelectState selectState id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found || getWindowStateHandleWindowKind wsH /= IsWindow then return ()+	         else do+			let wsH1 = setKeyboardSelectState selectState wsH+			appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH1 windows1))))+	where+		setKeyboardSelectState :: SelectState -> WindowStateHandle ps -> WindowStateHandle ps+		setKeyboardSelectState selectState (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) =+			WindowStateHandle wids (Just wlsH{wlsHandle=wH{whAtts=setKeyboardSelectStateAtt selectState (whAtts wH)}})+			where+				setKeyboardSelectStateAtt :: SelectState -> [WindowAttribute ls ps] -> [WindowAttribute ls ps]+				setKeyboardSelectStateAtt selectState atts					+					| not found = atts+					| otherwise =+						let (filter,_,fun) = getWindowKeyboardAtt keyAtt+						in (WindowKeyboard filter selectState fun:atts1)+					where+						(found,keyAtt,atts1) = remove isWindowKeyboard undefined atts+		setKeyboardSelectState _ _ =+			stdWindowFatalError "setWindowKeyboardSelectState" "unexpected window placeholder argument"+++getWindowSelectState :: Id -> GUI ps (Maybe SelectState)+getWindowSelectState id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return Nothing+	 else let+		windows = windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found || getWindowStateHandleWindowKind wsH/=IsWindow then return Nothing+	 	 else return (Just (if getWindowStateHandleSelect wsH then Able else Unable)))++getWindowMouseSelectState :: Id -> GUI ps (Maybe SelectState)+getWindowMouseSelectState id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return Nothing+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found || getWindowStateHandleWindowKind wsH/=IsWindow then return Nothing+		 else return (fmap snd (getWindowMouseAttInfo wsH)))++getWindowMouseAttInfo :: WindowStateHandle ps -> Maybe (MouseStateFilter,SelectState)+getWindowMouseAttInfo (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH})))	+	| not hasMouseAtt = Nothing+	| otherwise	  = Just (filter, selectState)+	where+		(hasMouseAtt,mouseAtt) = cselect isWindowMouse undefined (whAtts wH)+		(filter,selectState,_) = getWindowMouseAtt mouseAtt+getWindowMouseAttInfo _ = stdWindowFatalError "getWindowMouseAttInfo" "unexpected window placeholder argument"+++getWindowKeyboardSelectState :: Id -> GUI ps (Maybe SelectState)+getWindowKeyboardSelectState id = do+	(found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice);+	(if not found then return Nothing+	 else let +	     	windows = windowSystemStateGetWindowHandles wDevice+	     	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found || getWindowStateHandleWindowKind wsH /= IsWindow then return Nothing+	         else return (fmap snd (getWindowKeyboardAttInfo wsH)))++getWindowKeyboardAttInfo :: WindowStateHandle ps -> Maybe (KeyboardStateFilter,SelectState)+getWindowKeyboardAttInfo (WindowStateHandle wids (Just (WindowLSHandle {wlsHandle=wH@(WindowHandle {whAtts=whAtts})}))) =+	case find isWindowKeyboard whAtts of+	  Just keyAtt -> let (filter,selectState,_)= getWindowKeyboardAtt keyAtt+	  		 in Just (filter,selectState)+	  Nothing -> Nothing+getWindowKeyboardAttInfo _+	= stdWindowFatalError "getWindowKeyboardAttInfo" "unexpected window placeholder argument"++-- | returns the current mouse event filter+getWindowMouseStateFilter :: Id -> GUI ps (Maybe MouseStateFilter)+getWindowMouseStateFilter id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return Nothing+	 else let+		windows = windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found || getWindowStateHandleWindowKind wsH/=IsWindow then return Nothing+	         else return (fmap fst (getWindowMouseAttInfo wsH)))+		++-- | returns the current keyboard filter+getWindowKeyboardStateFilter :: Id -> GUI ps (Maybe KeyboardStateFilter)+getWindowKeyboardStateFilter id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return Nothing+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found || getWindowStateHandleWindowKind wsH/=IsWindow then return Nothing+	         else return (fmap fst (getWindowKeyboardAttInfo wsH)))+++-- | Receiving mouse event can be additionally disabled with state filter+setWindowMouseStateFilter :: Id -> MouseStateFilter -> GUI ps ()+setWindowMouseStateFilter id filter = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found || getWindowStateHandleWindowKind wsH/=IsWindow then return ()+	         else let wsH1 = setMouseFilter filter wsH+		      in appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH1 windows1))))+	where+		setMouseFilter :: MouseStateFilter -> WindowStateHandle ps -> WindowStateHandle ps+		setMouseFilter filter (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH@(WindowHandle {whAtts=atts})}))) =+			(WindowStateHandle wids (Just wlsH{wlsHandle=wH{whAtts=setMouseStateFilterAtt filter atts}}))+			where+				setMouseStateFilterAtt :: MouseStateFilter -> [WindowAttribute ls ps] -> [WindowAttribute ls ps]+				setMouseStateFilterAtt filter atts				+					| not found = atts+					| otherwise = (WindowMouse filter select fun:atts)+					where+						(found,mouseAtt,atts) = remove isWindowMouse undefined atts+						(_,select,fun)	      = getWindowMouseAtt mouseAtt+		setMouseFilter _ _+			= stdWindowFatalError "setWindowMouseStateFilter" "unexpected window placeholder argument"+++-- | Receiving keyboard event can be additionally disabled with state filter+setWindowKeyboardStateFilter :: Id -> KeyboardStateFilter -> GUI ps ()+setWindowKeyboardStateFilter id filter = do+	(found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else let+	 	windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found || getWindowStateHandleWindowKind wsH/=IsWindow then return ()+	      	 else let wsH1 = setKeyboardFilter filter wsH+	      	      in appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH1 windows1))))+	where+		setKeyboardFilter :: KeyboardStateFilter -> WindowStateHandle ps -> WindowStateHandle ps+		setKeyboardFilter filter (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH@(WindowHandle {whAtts=whAtts})}))) =+			(WindowStateHandle wids (Just wlsH{wlsHandle=wH{whAtts=setKeyboardStateFilterAtt filter whAtts}}))+			where+				setKeyboardStateFilterAtt :: KeyboardStateFilter -> [WindowAttribute ls ps] -> [WindowAttribute ls ps]+				setKeyboardStateFilterAtt filter atts					+					| not found = atts+					| otherwise = (WindowKeyboard filter select fun:atts)+					where+						(found,keyAtt,atts) = remove isWindowKeyboard undefined atts+						(_,select,fun)	    = getWindowKeyboardAtt keyAtt+		setKeyboardFilter _ _ = stdWindowFatalError "setWindowKeyboardStateFilter" "unexpected window placeholder argument"+++drawInWindow :: Id -> Draw x -> GUI ps (Maybe x)+drawInWindow id drawf = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return Nothing+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found then do+	     		appIOEnv (ioStSetDevice (WindowSystemState windows))+	     		return Nothing+	      	 else if getWindowStateHandleWindowKind wsH /= IsWindow+	     	      then do+	     	     	appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+	     	        return Nothing+	              else do+	             	wMetrics <- accIOEnv ioStGetOSWindowMetrics+			(x,wsH)	<- liftIO (drawInWindow' wMetrics drawf wsH)+			appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+			return (Just x))+	where+		drawInWindow' :: OSWindowMetrics -> Draw x -> WindowStateHandle ps -> IO (x,WindowStateHandle ps)+		drawInWindow' wMetrics drawf (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) = do+			wH <- validateWindowClipState wMetrics False (wPtr wids) wH+			(x,wH) <- WD.drawInWindow wMetrics (wPtr wids) drawf wH+			return (x, WindowStateHandle wids (Just wlsH{wlsHandle=wH}))+		drawInWindow' _ _ _ = stdWindowFatalError "drawInWindow" "unexpected window placeholder argument"+++updateWindow :: Id -> Maybe ViewFrame -> GUI ps ()+updateWindow id maybeViewFrame = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found || getWindowStateHandleWindowKind wsH/=IsWindow then return ()	+		 else do+			wMetrics <- accIOEnv ioStGetOSWindowMetrics+			wsH <- liftIO (updateWindowBackground wMetrics maybeViewFrame wsH)+			appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1))))+	where+		updateWindowBackground :: OSWindowMetrics -> Maybe ViewFrame -> WindowStateHandle ps -> IO (WindowStateHandle ps)+		updateWindowBackground wMetrics maybeViewFrame wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH})))+			| isEmptyRect updArea = return wsH+			| otherwise = do+				wH <- WU.updateWindow wMetrics updInfo wH+				return (WindowStateHandle wids (Just wlsH{wlsHandle=wH}))+			where+				winSize				= whSize wH+				info				= whWindowInfo wH+				(origin,domainRect,hasScrolls)	= (windowOrigin info,windowDomain info,(isJust (windowHScroll info),isJust (windowVScroll info)))+				visScrolls			= osScrollbarsAreVisible wMetrics domainRect (toTuple winSize) hasScrolls+				contentRect			= getWindowContentRect wMetrics visScrolls (sizeToRect winSize)+				updArea	= case maybeViewFrame of+					Nothing		-> contentRect+					Just rect	-> intersectRects (rectangleToRect (subVector (toVector origin) rect)) contentRect+				updInfo	= UpdateInfo+					{ updWIDS	= wids+					, updWindowArea	= updArea+					, updControls	= []+					, updGContext	= Nothing+					}+		updateWindowBackground _ _ _ = stdWindowFatalError "updateWindow" "unexpected window placeholder argument"+++setWindowLook :: Id -> Bool -> (Bool,Look) -> GUI ps ()+setWindowLook wId redraw (sysLook,lookFun) = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else do+		let windows	= windowSystemStateGetWindowHandles wDevice+	  	let (found,wsH,windows1) = getWindowHandlesWindow (toWID wId) windows+		(if not found+		 then appIOEnv (ioStSetDevice (WindowSystemState windows))+		 else if getWindowStateHandleWindowKind wsH /= IsWindow+		     then appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+		     else do+				wMetrics <- accIOEnv ioStGetOSWindowMetrics+				wsH <- liftIO (setwindowlook wMetrics redraw (sysLook,lookFun) wsH)+				appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))))+	where+		setwindowlook :: OSWindowMetrics -> Bool -> (Bool,Look) -> (WindowStateHandle ps) -> IO (WindowStateHandle ps)+		setwindowlook wMetrics redraw (sysLook,lookFun) wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) =+			let +				lookInfo1 = lookInfo{lookFun=lookFun,lookSysUpdate=sysLook}		+				wH1 = wH{whWindowInfo=windowInfo{windowLook=lookInfo1}}+			in if not redraw+			   then return (WindowStateHandle wids (Just wlsH{wlsHandle=wH1}))+			   else do+					wH2 <- validateWindowClipState wMetrics False (wPtr wids) wH1+					wH3 <- drawWindowLook wMetrics (wPtr wids) (return ()) updState wH2+					return (WindowStateHandle wids (Just wlsH{wlsHandle=wH3}))+			where+				windowInfo				= whWindowInfo wH+				lookInfo				= windowLook windowInfo+				domainRect				= windowDomain windowInfo+				origin					= windowOrigin windowInfo+				hasScrolls				= (isJust (windowHScroll windowInfo),isJust (windowVScroll windowInfo))+				visScrolls				= osScrollbarsAreVisible wMetrics domainRect (toTuple (whSize wH)) hasScrolls+				contentRect				= getWindowContentRect wMetrics visScrolls (sizeToRect (whSize wH))+				wFrame					= posSizeToRectangle origin (rectSize contentRect)+				updState				= rectangleToUpdateState wFrame+		setwindowlook _ _ _ _ = stdWindowFatalError "setWindowLook" "unexpected window placeholder argument"++getWindowLook :: Id -> GUI ps (Maybe (Bool,Look))+getWindowLook id = do+	(found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+	(if not found+	 then return Nothing+	 else let +	 		windows = windowSystemStateGetWindowHandles wDevice+			(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in +	      	if not found+		then do+			appIOEnv (ioStSetDevice (WindowSystemState windows))+			return Nothing+		else if getWindowStateHandleWindowKind wsH/=IsWindow+		     then do+		     	appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+			return Nothing+		     else+			let+				windowInfo = getWindowStateHandleWindowInfo wsH	+		  		LookInfo{lookFun=lookFun,lookSysUpdate=lookSysUpdate} = windowLook windowInfo+			in do+				appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+				return (Just (lookSysUpdate,lookFun)))+++--	Operations that are concerned with the position of windows/dialogues.++-- | The setWindowPos function changes the position the specified window.+-- The position is relative to the upper-left corner of the screen. +setWindowPos :: Id -> ItemPos -> GUI ps ()+setWindowPos id pos = do+	osdInfo <- accIOEnv ioStGetOSDInfo+	wMetrics <- accIOEnv ioStGetOSWindowMetrics+	(found1,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+	let windows	= windowSystemStateGetWindowHandles wDevice+	let (found2,wsH,_) = getWindowHandlesWindow (toWID id) windows+	(if not found1 || not found2 || getWindowStateHandleWindowMode wsH == Modal then return ()+	 else let (okId,pos1) = validateRelativeId id pos windows+	      in if not okId then return ()+	         else let+	        	wids  = getWindowStateHandleWIDS wsH+		  	wSize = getWindowStateHandleSize wsH+		  	wKind = getWindowStateHandleWindowKind wsH+		     	isSDI = getOSDInfoDocumentInterface osdInfo==SDI+		  	(framePtr,clientPtr) = case getOSDInfoOSInfo osdInfo of+		  			Just info -> (osFrame info, osClient info)+		  			_         -> (osNoWindowPtr,osNoWindowPtr)+		      in do+			   pos <- liftIO (exactWindowPos wMetrics wSize (Just pos) wKind Modeless windows)+			   liftIO (osSetWindowPos (if isSDI && wPtr wids==clientPtr then framePtr else wPtr wids) (toTuple pos) True True))+	where+		-- validateRelativeId checks the validity of the ItemPos. +		-- It assumes that the WindowHandles argument is not empty (containing atleast the target window).+		validateRelativeId :: Id -> ItemPos -> WindowHandles ps -> (Bool,ItemPos)+		validateRelativeId id itemPos@(itemLoc,itemOffset) windows+			| isRelative 	 = (hasWindowHandlesWindow (toWID relativeId) windows,itemPos)+			| isRelativePrev =+				let+					wsHs		 = whsWindows windows+					widsstack 	 = map getWindowStateHandleWIDS wsHs+					(found,itemLoc1) =+						case findPrevId (toWID id) widsstack of+							Nothing -> (False, itemLoc)+							Just prevId -> case itemLoc of+								LeftOfPrev  -> (True, LeftOf  prevId)+								RightToPrev -> (True, RightTo prevId)+								AbovePrev   -> (True, Above   prevId)+								BelowPrev   -> (True, Below   prevId)+								+					findPrevId :: WID -> [WIDS] -> Maybe Id+					findPrevId wid [_] = Nothing+					findPrevId wid (wid1:(wid2:wids))+						| identifyWIDS wid wid2	= Just (wId wid1)+						| otherwise		= findPrevId wid (wid2:wids)+				in+					(found,(itemLoc1,itemOffset))+			| otherwise = (True,itemPos)+			where+				(isRelative,relativeId)	= case itemLoc of+					LeftOf  id  -> (True,id)+					RightTo id  -> (True,id)+					Above   id  -> (True,id)+					Below   id  -> (True,id)+					_           -> (False,undefined)+				isRelativePrev		= case itemLoc of+					LeftOfPrev  -> True+					RightToPrev -> True+					AbovePrev   -> True+					BelowPrev   -> True+					_           -> False+++-- | The getWindowPos function retrieves the position of specified window. +getWindowPos :: Id -> GUI ps (Maybe Vector2)+getWindowPos id = do+	(found1,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+	let windows = windowSystemStateGetWindowHandles wDevice+	let (found2,wsH,_) = getWindowHandlesWindow (toWID id) windows+	(if not found1 || not found2 then return Nothing	+	 else do+		osdInfo <- accIOEnv ioStGetOSDInfo+		let di = getOSDInfoDocumentInterface osdInfo+		let isSDI = di==SDI+		let isMDI = di==MDI+		let (framePtr,clientPtr,getParentPos) = case getOSDInfoOSInfo osdInfo of+		  	Just info -> (osFrame info,osClient info,if isMDI then osGetWindowPos (osClient info) else return (0,0))+			Nothing   -> (osNoWindowPtr, osNoWindowPtr,return (0,0))+		let wids = getWindowStateHandleWIDS wsH		+		(wx,wy) <- liftIO (osGetWindowPos (if isSDI && wPtr wids==clientPtr then framePtr else wPtr wids))+		(fx,fy) <- liftIO getParentPos+		return (Just (Vector2{vx=wx-fx,vy=wy-fy})))++--	Operations that are concerned with the ViewFrame of a window.++-- | The function moves view frame through the specified vector.+moveWindowViewFrame :: Id -> Vector2 -> GUI ps ()+moveWindowViewFrame id v = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in +	        if not found then appIOEnv (ioStSetDevice (WindowSystemState windows))+	        else if getWindowStateHandleWindowKind wsH /= IsWindow+	             then appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+	             else do+			wMetrics <- accIOEnv ioStGetOSWindowMetrics+			wsH <- liftIO (moveWindowViewFrame' wMetrics v wsH)+			appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1))))+	where+		moveWindowViewFrame' :: OSWindowMetrics -> Vector2 -> WindowStateHandle ps -> IO (WindowStateHandle ps)+		moveWindowViewFrame' wMetrics v wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) = do+			wH <- CP.moveWindowViewFrame wMetrics v wids wH+			return (WindowStateHandle wids (Just wlsH{wlsHandle=wH}))+		moveWindowViewFrame' _ _ _ = stdWindowFatalError "moveWindowViewFrame" "unexpected window placeholder argument"++-- | 'ViewFrame' is the current visible 'Rectangle' of the window. When there are horizontal+-- and vertical scroll bars, then the changing of the scroller thumb changes the ViewFrame.+-- getWindowViewFrame returns the current ViewFrame+getWindowViewFrame :: Id -> GUI ps ViewFrame+getWindowViewFrame id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return zero+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in+		if not found+		then do+			appIOEnv (ioStSetDevice (WindowSystemState windows))+			return zero+		else do+			wMetrics <- accIOEnv ioStGetOSWindowMetrics+			let viewFrame = getwindowviewframe wMetrics wsH+			appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+			return viewFrame)+++-- getwindowviewframe is also used by getWindowOuterSize.+getwindowviewframe :: OSWindowMetrics -> (WindowStateHandle ps) -> ViewFrame+getwindowviewframe wMetrics (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH})))+	| whKind wH ==IsWindow = rectToRectangle contentRect+	| otherwise = sizeToRectangle (whSize wH)+	where	+		info = whWindowInfo wH+		(origin,domainRect,hasHScroll,hasVScroll) = (windowOrigin info,windowDomain info,isJust (windowHScroll info),isJust (windowVScroll info))+		visScrolls  = osScrollbarsAreVisible wMetrics domainRect (toTuple (whSize wH)) (hasHScroll,hasVScroll)+		contentRect = getWindowContentRect wMetrics visScrolls (posSizeToRect origin (whSize wH))+getwindowviewframe _ _ = stdWindowFatalError "getWindowViewFrame" "unexpected window placeholder argument"+++-- | ViewSize is the current inner size of the window+-- (It doesn\'t include the title bar and the scrollers\' area).+setWindowViewSize :: Id -> Size -> ps -> GUI ps ps+setWindowViewSize wid reqSize ps = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ps+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID wid) windows+	      in+		if not found || getWindowStateHandleWindowKind wsH /= IsWindow then return ps+		else do+			wMetrics <- accIOEnv ioStGetOSWindowMetrics+	  		let (diffSize,viewSize,frameSize) = validateSize wMetrics reqSize wsH+			(if not diffSize then return ps+			 else do+				osdInfo <- accIOEnv ioStGetOSDInfo+		  		let (framePtr,clientPtr,tbHeight) = case getOSDInfoOSInfo osdInfo of+		  			Just info -> (osFrame info,osClient info,maybe 0 toolbarHeight (osToolbar info))+		  			_         -> (osNoWindowPtr,osNoWindowPtr,0)+				let wids = getWindowStateHandleWIDS wsH+				liftIO (osSetWindowViewFrameSize (wPtr wids) (toTuple viewSize))+				liftIO (if getOSDInfoDocumentInterface osdInfo==SDI && wPtr wids==clientPtr+				        then osSetWindowViewFrameSize framePtr (toTuple viewSize{h=h viewSize+tbHeight})+				        else return ())+				let activeWIDS	= getWindowHandlesActiveWindow windows+				(wsH,ps) <- windowStateSizeAction wMetrics (isJust activeWIDS && wId (fromJust activeWIDS)==wid) (WindowSizeActionInfo {wsWIDS=wids,wsSize=frameSize,wsUpdateAll=False}) wsH ps+				appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+				return ps))+	where+		validateSize :: OSWindowMetrics -> Size -> WindowStateHandle ps -> (Bool,Size,Size)+		validateSize wMetrics reqSize (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) =+			let+				(visHScroll,visVScroll) = osScrollbarsAreVisible wMetrics domainRect (toTuple curSize) (hasHScroll,hasVScroll)+				newW = if visVScroll then w okSize+osmVSliderWidth  wMetrics else w okSize	-- Correct newW in case of visible vertical   scrollbar+				newH = if visHScroll then h okSize+osmHSliderHeight wMetrics else h okSize	-- Correct newH in case of visible horizontal scrollbar+			in+				(okSize/=curSize,okSize,Size{w=newW,h=newH})+			where+				(minWidth,minHeight)	= osMinWindowSize+				minSize			= Size{w=minWidth,h=minHeight}+				maxSize			= maxScrollWindowSize+				okSize			= Size{w=setBetween (w reqSize) (w minSize) (w maxSize),h=setBetween (h reqSize) (h minSize) (h maxSize)}+				curSize			= whSize wH+				windowInfo		= whWindowInfo wH+				domainRect		= windowDomain windowInfo+				hasHScroll		= isJust (windowHScroll windowInfo)+				hasVScroll		= isJust (windowVScroll windowInfo)+		validateSize _ _ _ = stdWindowFatalError "setWindowViewSize" "unexpected window placeholder argument"+++-- | ViewSize is the current inner size of the window+-- (It doesn\'t include the title bar and the scrollers\' area).+getWindowViewSize :: Id -> GUI ps Size+getWindowViewSize id = do+	viewFrame <- getWindowViewFrame id+	return (rectangleSize viewFrame)+++-- | The setWindowOuterSize function changes the dimensions of the specified window.+setWindowOuterSize :: Id -> Size -> ps -> GUI ps ps+setWindowOuterSize id (Size{w=w,h=h}) ps = do+	osdInfo <- accIOEnv ioStGetOSDInfo+	let isMDI = getOSDInfoDocumentInterface osdInfo == MDI+	(dw,dh)	<- liftIO (osStripOuterSize isMDI True)+	setWindowViewSize id (Size{w=w-dw,h=h-dh}) ps++-- | The getWindowOuterSize function retrieves the dimensions of the bounding rectangle+-- of the specified window.+getWindowOuterSize :: Id -> GUI ps Size+getWindowOuterSize id = do+	(found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return zero+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found then return zero+	  	 else do+			wMetrics <- accIOEnv ioStGetOSWindowMetrics+			let viewFrame = getwindowviewframe wMetrics wsH+			let viewFrameSize = rectangleSize viewFrame+			let wKind = getWindowStateHandleWindowKind wsH+			(if wKind==IsDialog+			 then return (exactWindowSize undefined undefined viewFrameSize undefined undefined wKind)+			 else+				let+					info = getWindowStateHandleWindowInfo wsH+					(hasHScroll,hasVScroll)	= (isJust (windowHScroll info),isJust (windowVScroll info))+					domain	= rectToRectangle (windowDomain info)+				in do+					osdInfo <- accIOEnv ioStGetOSDInfo+					let isMDI = getOSDInfoDocumentInterface osdInfo == MDI					+					let outerSize	= exactWindowSize wMetrics domain viewFrameSize hasHScroll hasVScroll wKind+					(dw,dh)	<- liftIO (osStripOuterSize isMDI True)+					let windows1	= setWindowHandlesWindow wsH windows					+					appIOEnv (ioStSetDevice (WindowSystemState windows1))+					return (Size{w=w outerSize+dw,h=h outerSize+dh})))+++setWindowViewDomain :: Id -> ViewDomain -> GUI ps ()+setWindowViewDomain wId newDomain = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found+	 then return ()+	 else let+	 	windows = windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID wId) windows+	      in+	      	if not found+		then appIOEnv (ioStSetDevice (WindowSystemState windows))+		else if getWindowStateHandleWindowKind wsH /= IsWindow+		     then appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+		     else do+			wMetrics <- accIOEnv ioStGetOSWindowMetrics+			wsH <- liftIO (setwindowviewdomain wMetrics newDomain wsH)+			appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1))))+	where+		setwindowviewdomain :: OSWindowMetrics -> ViewDomain -> WindowStateHandle ps -> IO (WindowStateHandle ps)+		setwindowviewdomain wMetrics newDomain (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) =+			let+				newDomain1 = validateViewDomain newDomain+				(Rect {rleft=dl,rtop=dt,rright=dr,rbottom=db}) = rectangleToRect newDomain1+				newDomainSize = rectangleSize newDomain+				newDomainRect = rectangleToRect newDomain+				newOrigin = Point2+					{ x = if w1 >= w newDomainSize then rleft newDomainRect else setBetween (x oldOrigin) (rleft newDomainRect) ((rright  newDomainRect)-w1)+					, y = if h1 >= h newDomainSize then rtop  newDomainRect else setBetween (y oldOrigin) (rtop  newDomainRect) ((rbottom newDomainRect)-h1)+					}+				newVisScrolls = osScrollbarsAreVisible wMetrics newDomainRect wSize' hasScrolls+				newContentRect = getWindowContentRect wMetrics newVisScrolls (sizeToRect wSize)+				Rect{rright=w',rbottom=h'} = newContentRect+				osHState = toOSscrollbarRange (rleft newDomainRect,x newOrigin,rright  newDomainRect) w'+				osVState = toOSscrollbarRange (rtop  newDomainRect,y newOrigin,rbottom newDomainRect) h'+				windowInfo1 		= windowInfo{windowDomain=newDomainRect,windowOrigin=newOrigin}+				newViewFrameRect 	= posSizeToRect newOrigin (Size {w=w',h=h'})+				newViewFrame		= rectToRectangle newViewFrameRect+				oldViewFrame		= rectToRectangle oldViewFrameRect+				oldDomainViewMax	= getdomainviewmax oldDomainRect oldViewFrameRect+				newDomainViewMax	= getdomainviewmax newDomainRect newViewFrameRect+				updArea			= if sysLook && oldOrigin==newOrigin && oldDomainViewMax==newDomainViewMax+							  then []+							  else [newViewFrame]+				updState		= UpdateState{oldFrame=oldViewFrame,newFrame=newViewFrame,updArea=updArea}+				(hasCaret,catt)  = cselect isWindowCaret undefined atts+				(Point2 cx cy,Size cw ch) = getWindowCaretAtt catt+			  in do+				setwindowslider hasHScroll wMetrics (wPtr wids) True  osHState wSize'+				setwindowslider hasVScroll wMetrics (wPtr wids) False osVState wSize'+				when hasCaret (osSetCaretPos (wPtr wids) (setBetween cx dl (dr-cw)) (setBetween cy dt (db-ch)))+				(if null oldItems		-- window has no controls+				 then let +					wH1 = wH{whWindowInfo=windowInfo1}+				      in+					if null updArea				-- nothing has to updated+					then return (WindowStateHandle wids (Just wlsH{wlsHandle=wH1}))+					else do+						wH2 <- drawWindowLook wMetrics (wPtr wids) (return ()) updState wH1+						return (WindowStateHandle wids (Just wlsH{wlsHandle=wH2}))+				 else let 			-- window has controls+					hMargins = getWindowHMargins   IsWindow wMetrics atts+					vMargins = getWindowVMargins   IsWindow wMetrics atts+					spaces = getWindowItemSpaces IsWindow wMetrics atts+					reqSize	= Size{w=w'-fst hMargins-snd hMargins,h=h'-fst vMargins-snd vMargins}+				      in do+					(_,newItems) <- layoutControls wMetrics hMargins vMargins spaces reqSize minSize [(newDomain,newOrigin)] oldItems+					let wH1 = wH{whWindowInfo=windowInfo,whItems=newItems}+					wH2 <- forceValidWindowClipState wMetrics True (wPtr wids) wH1+					updRgn <- relayoutControls wMetrics (whSelect wH) (whShow wH) newContentRect newContentRect zero zero (wPtr wids) (whDefaultId wH) oldItems (whItems wH)+					wH3 <- drawWindowLook wMetrics (wPtr wids) (return ()) updState wH2+					wH4 <- updateWindowBackgrounds wMetrics updRgn wids wH3+					return (WindowStateHandle wids (Just wlsH{wlsHandle=wH4})))+			where+				atts			= whAtts wH+				wSize			= whSize wH+				wSize'			= toTuple wSize+				(w1,h1)			= wSize'+				windowInfo		= whWindowInfo wH+				oldDomainRect		= windowDomain windowInfo+				oldOrigin		= windowOrigin windowInfo+				sysLook			= lookSysUpdate (windowLook windowInfo)+				oldItems		= whItems wH+				hasScrolls		= (isJust (windowHScroll windowInfo),isJust (windowVScroll windowInfo))+				(hasHScroll,hasVScroll)	= hasScrolls+				oldVisScrolls		= osScrollbarsAreVisible wMetrics oldDomainRect wSize' hasScrolls+				oldContentRect		= getWindowContentRect wMetrics oldVisScrolls (sizeToRect wSize)+				oldViewFrameRect	= posSizeToRect oldOrigin (rectSize oldContentRect)+				(defMinW,defMinH)	= osMinWindowSize+				minSize			= Size{w=defMinW,h=defMinH}++				setwindowslider :: Bool -> OSWindowMetrics -> OSWindowPtr -> Bool -> (Int,Int,Int,Int) -> (Int,Int) -> IO ()+				setwindowslider hasScroll wMetrics wPtr isHorizontal state maxcoords+					| hasScroll	= osSetWindowSlider wMetrics wPtr isHorizontal state maxcoords+					| otherwise	= return ()++				getdomainviewmax :: Rect -> Rect -> Point2+				getdomainviewmax domainRect viewframeRect =+					Point2 {x=min (rright domainRect) (rright viewframeRect),y=min (rbottom domainRect) (rbottom viewframeRect)}+		setwindowviewdomain _ _ _+			= stdWindowFatalError "setWindowViewDomain" "unexpected window placeholder argument"++getWindowViewDomain :: Id -> GUI ps (Maybe ViewDomain)+getWindowViewDomain id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return Nothing+	 else let +	 	windows = windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in+		if not found then do+			appIOEnv (ioStSetDevice (WindowSystemState windows))+			return Nothing+		else if getWindowStateHandleWindowKind wsH /= IsWindow+		     then do+		     		appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+		     		return Nothing+		     else let +		     		wInfo = getWindowStateHandleWindowInfo wsH	+		  		domain	= rectToRectangle (windowDomain wInfo)+		  	  in do+		  	  	appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1)))+		  	  	return (Just domain))+		  	  	+--	Set and get ScrollFunctions:++setWindowScrollFunction :: Id -> Direction -> ScrollFunction -> GUI ps ()+setWindowScrollFunction wId direction scrollFun = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID wId) windows+	      in if not found || getWindowStateHandleWindowKind wsH /= IsWindow then return ()+		 else let wsH1 = setwindowscrollfunction direction scrollFun wsH+		      in appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH1 windows1))))+	where+		setwindowscrollfunction :: Direction -> ScrollFunction -> WindowStateHandle ps -> WindowStateHandle ps+		setwindowscrollfunction direction scrollFun wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH})))+			| direction==Horizontal && isJust hScroll =+				let info = windowInfo{windowHScroll=fmap (setScrollFun scrollFun) hScroll}+				in WindowStateHandle wids (Just wlsH{wlsHandle=wH{whWindowInfo=info}})+			| direction==Vertical && isJust vScroll =+				let info = windowInfo{windowVScroll=fmap (setScrollFun scrollFun) vScroll}+				in WindowStateHandle wids (Just wlsH{wlsHandle=wH{whWindowInfo=info}})+			| otherwise = wsH+			where+				windowInfo	= whWindowInfo wH+				hScroll		= windowHScroll windowInfo+				vScroll		= windowVScroll windowInfo++				setScrollFun :: ScrollFunction -> ScrollInfo -> ScrollInfo+				setScrollFun f scrollInfo = scrollInfo{scrollFunction=f}+		setwindowscrollfunction _ _ _ =+			stdWindowFatalError "setWindowScrollFunction" "unexpected window placeholder argument"++getWindowScrollFunction :: Id -> Direction -> GUI ps (Maybe ScrollFunction)+getWindowScrollFunction wId direction = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return Nothing+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID wId) windows+	      in+		if not found || getWindowStateHandleWindowKind wsH /= IsWindow then return Nothing+		else return (getwindowscrollfunction direction wsH))+	where+		getwindowscrollfunction :: Direction -> WindowStateHandle ps -> Maybe ScrollFunction+		getwindowscrollfunction direction wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH})))+			| direction==Horizontal && isJust hScroll = fmap scrollFunction hScroll+			| direction==Vertical   && isJust vScroll = fmap scrollFunction vScroll+			| otherwise = Nothing+			where+				windowInfo	= whWindowInfo wH+				hScroll		= windowHScroll windowInfo+				vScroll		= windowVScroll windowInfo+		getwindowscrollfunction _ _ =+			stdWindowFatalError "getWindowScrollFunction" "unexpected window placeholder argument"++--	Operations that are concerned with remaining attributes of windows.++-- | The setWindowTitle function changes the text of the specified window\'s title bar.+setWindowTitle :: Id -> Title -> GUI ps ()+setWindowTitle id title = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found then return ()+		 else do+			osdInfo <- accIOEnv (ioStGetOSDInfo)+		  	let isSDI = getOSDInfoDocumentInterface osdInfo==SDI+		  	let (framePtr,clientPtr) = case (getOSDInfoOSInfo osdInfo) of+				Just info -> (osFrame info, osClient info)+				_         -> (osNoWindowPtr,osNoWindowPtr)+		  	let wids = getWindowStateHandleWIDS wsH+		  	let wsH1 = setWindowStateHandleWindowTitle title wsH+			liftIO (osSetWindowTitle (if isSDI && (wPtr wids) == clientPtr then framePtr else wPtr wids) title)+			appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH1 windows1))))++setWindowCursor :: Id -> CursorShape -> GUI ps ()+setWindowCursor id shape = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found+		 then return ()+		 else do+			wsH1 <- liftIO (setwindowcursor shape wsH)+			appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH1 windows1))))+	where+		setwindowcursor :: CursorShape -> WindowStateHandle ps -> IO (WindowStateHandle ps)+		setwindowcursor shape (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) = do+			osSetWindowCursor (wPtr wids) (toCursorCode shape)+			let cursorAtt = WindowCursor shape+			let (replaced,atts) = creplace isWindowCursor cursorAtt (whAtts wH)+			let atts1 = if replaced then atts else (cursorAtt:atts)+			return (WindowStateHandle wids (Just wlsH{wlsHandle=wH{whAtts=atts1}}))+		setwindowcursor _ _ = stdWindowFatalError "setWindowCursor" "unexpected window placeholder argument"+++-- | The setWindowCaretPos function moves the caret to the specified coordinates. +setWindowCaretPos :: Id -> Point2 -> GUI ps ()+setWindowCaretPos id pos = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return ()+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found+		 then return ()+		 else do+		 	wMetrics <- accIOEnv ioStGetOSWindowMetrics+			wsH <- liftIO (setwindowcaret wMetrics pos wsH)+			appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1))))+	where+		setwindowcaret :: OSWindowMetrics -> Point2 -> WindowStateHandle ps -> IO (WindowStateHandle ps)+		setwindowcaret wMetrics (Point2 cx cy) wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH})))+			| whKind wH == IsWindow && hasCaret = do+				osSetCaretPos (wPtr wids) (cx'-ox) (cy'-oy)+				let viewFrame = getwindowviewframe wMetrics wsH+				let scrollVector =+					if pointInRectangle oldPos viewFrame+					then Vector2 (cx-ocx) (cy-ocy)+					else Vector2 ((max 0 (ocx-ww `div` 2))-ox) ((max 0 (ocy-wh `div` 2))-oy)+				wH <- (if not (pointInRectangle newPos viewFrame)+				       then (CP.moveWindowViewFrame wMetrics scrollVector wids)+				       else return) wH{whAtts=WindowCaret newPos size:atts}+				return (WindowStateHandle wids (Just wlsH{wlsHandle=wH}))+			| otherwise = return (wsH)+			where+				(hasCaret,att,atts) = remove isWindowCaret undefined (whAtts wH)+				WindowCaret oldPos@(Point2 ocx ocy) size@(Size cw ch) = att+				WindowInfo { windowDomain = Rect {rleft=dl,rtop=dt,rright=dr,rbottom=db}+					   , windowOrigin = Point2 ox oy+					   } = whWindowInfo wH+				cx' = setBetween cx dl (dr-cw)+				cy' = setBetween cy dt (db-ch)+				newPos = Point2 cx' cy'+				Size ww wh = whSize wH+		setwindowcaret _ _ _ = stdWindowFatalError "setWindowCursor" "unexpected window placeholder argument"++-- | The getWindowTitle function returns the text of the specified window\'s title bar.+getWindowTitle :: Id -> GUI ps (Maybe Title)+getWindowTitle id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return Nothing+	 else let+	 	windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found+	         then return Nothing+		 else return (Just (getWindowStateHandleWindowTitle wsH)))+++getWindowOk :: Id -> GUI ps (Maybe Id)+getWindowOk id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return Nothing+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found+	         then return Nothing+	     	 else return (getWindowStateHandleDefaultId wsH))+			+getWindowCancel :: Id -> GUI ps (Maybe Id)+getWindowCancel id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return Nothing+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found+	      	 then return Nothing+	     	 else return (getWindowStateHandleCancelId wsH))++getWindowCursor :: Id -> GUI ps (Maybe CursorShape)+getWindowCursor id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return Nothing+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found+	         then return Nothing+	      	 else return (getcursor wsH))+	where+		getcursor :: WindowStateHandle ps -> Maybe CursorShape+		getcursor wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) =+			fmap getWindowCursorAtt (find isWindowCursor (whAtts wH))+		getcursor _ = stdWindowFatalError "getWindowCursor" "unexpected window placeholder argument"++-- | If the window has 'WindowCaret' attribute then the getWindowCaretPos function returns the caret\'s position,+-- otherwise it returns Nothing+getWindowCaretPos :: Id -> GUI ps (Maybe Point2)+getWindowCaretPos id = do+	(found,wDevice)	<- accIOEnv (ioStGetDevice WindowDevice)+	(if not found then return Nothing+	 else let+		windows	= windowSystemStateGetWindowHandles wDevice+	  	(found,wsH,windows1) = getWindowHandlesWindow (toWID id) windows+	      in if not found+	         then return Nothing+	      	 else return (getcaret wsH))+	where+		getcaret :: WindowStateHandle ps -> Maybe Point2+		getcaret wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) =+			fmap (fst . getWindowCaretAtt) (find isWindowCaret (whAtts wH))+		getcaret _ = stdWindowFatalError "getWindowCursor" "unexpected window placeholder argument"
+ Graphics/UI/ObjectIO/StdWindowAttribute.hs view
@@ -0,0 +1,286 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdWindowAttribute+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdWindowAttribute specifies which WindowAttributes are valid for Windows.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.StdWindowAttribute+		( isValidWindowAttribute, isValidDialogAttribute+		, isWindowActivate,   	getWindowActivateFun+		, isWindowCancel,	getWindowCancelAtt+		, isWindowClose,      	getWindowCloseFun+		, isWindowCursor,	getWindowCursorAtt+		, isWindowDeactivate, 	getWindowDeactivateFun+		, isWindowHMargin,	getWindowHMarginAtt+		, isWindowHScroll,	getWindowHScrollFun+		, isWindowId,         	getWindowIdAtt+		, isWindowIndex,	getWindowIndexAtt+		, isWindowInit,       	getWindowInitFun+		, isWindowInitActive, 	getWindowInitActiveAtt+		, isWindowItemSpace,  	getWindowItemSpaceAtt+		, isWindowKeyboard,	getWindowKeyboardAtt+		, isWindowLook,		getWindowLookAtt+		, isWindowMouse,	getWindowMouseAtt+		, isWindowOk,		getWindowOkAtt+		, isWindowOrigin,	getWindowOriginAtt+		, isWindowOuterSize,	getWindowOuterSizeAtt+		, isWindowPen,		getWindowPenAtt+		, isWindowPos,		getWindowPosAtt+		, isWindowSelectState,	getWindowSelectStateAtt+		, isWindowViewDomain, 	getWindowViewDomainAtt+		, isWindowViewSize,   	getWindowViewSizeAtt+		, isWindowVMargin,	getWindowVMarginAtt+		, isWindowVScroll,	getWindowVScrollFun+		, isWindowCaret,	getWindowCaretAtt+		, isWindowResize, 	getWindowResizeAtt+		, isWindowDoubleBuffered+		, module Graphics.UI.ObjectIO.StdWindowDef+		) where+++import Graphics.UI.ObjectIO.StdWindowDef+++isValidWindowAttribute :: WindowAttribute ls ps -> Bool+isValidWindowAttribute att = isAllWindowsAttribute att || isWindowOnlyAttribute att++isValidDialogAttribute :: WindowAttribute ls ps -> Bool+isValidDialogAttribute att = isAllWindowsAttribute att || isDialogOnlyAttribute att++isAllWindowsAttribute :: WindowAttribute ls ps -> Bool+isAllWindowsAttribute (WindowActivate   _) = True+isAllWindowsAttribute (WindowClose      _) = True+isAllWindowsAttribute (WindowDeactivate _) = True+isAllWindowsAttribute (WindowHMargin  _ _) = True+isAllWindowsAttribute (WindowId         _) = True+isAllWindowsAttribute (WindowIndex	_) = True+isAllWindowsAttribute (WindowInit       _) = True+isAllWindowsAttribute (WindowInitActive _) = True+isAllWindowsAttribute (WindowItemSpace _ _)= True+isAllWindowsAttribute (WindowOuterSize	_) = True+isAllWindowsAttribute (WindowPos	_) = True+isAllWindowsAttribute (WindowViewSize   _) = True+isAllWindowsAttribute (WindowVMargin  _ _) = True+isAllWindowsAttribute _                    = False++isWindowOnlyAttribute :: WindowAttribute ls ps -> Bool+isWindowOnlyAttribute (WindowCursor	  _) = True+isWindowOnlyAttribute (WindowHScroll	  _) = True+isWindowOnlyAttribute (WindowKeyboard _ _ _) = True+isWindowOnlyAttribute (WindowLook       _ _) = True+isWindowOnlyAttribute (WindowMouse    _ _ _) = True+isWindowOnlyAttribute (WindowOrigin	  _) = True+isWindowOnlyAttribute (WindowPen          _) = True+isWindowOnlyAttribute (WindowSelectState  _) = True+isWindowOnlyAttribute (WindowViewDomain	  _) = True+isWindowOnlyAttribute (WindowVScroll	  _) = True+isWindowOnlyAttribute (WindowCaret      _ _) = True+isWindowOnlyAttribute (WindowResize       _) = True+isWindowOnlyAttribute (WindowDoubleBuffered) = True+isWindowOnlyAttribute _			     = False++isDialogOnlyAttribute :: WindowAttribute ls ps -> Bool+isDialogOnlyAttribute (WindowCancel	  _) = True+isDialogOnlyAttribute (WindowOk		  _) = True+isDialogOnlyAttribute _			     = False++isWindowActivate :: WindowAttribute ls ps -> Bool+isWindowActivate (WindowActivate _) = True+isWindowActivate _                  = False++isWindowCancel	 :: WindowAttribute ls ps -> Bool+isWindowCancel	(WindowCancel _) = True+isWindowCancel	_		 = False++isWindowClose    :: WindowAttribute ls ps -> Bool+isWindowClose    (WindowClose _)    = True+isWindowClose    _                  = False++isWindowCursor	:: WindowAttribute ls ps -> Bool+isWindowCursor	(WindowCursor _) = True+isWindowCursor	_		 = False++isWindowDeactivate :: WindowAttribute ls ps -> Bool+isWindowDeactivate (WindowDeactivate _) = True+isWindowDeactivate _                    = False++isWindowHMargin	:: WindowAttribute ls ps -> Bool+isWindowHMargin	(WindowHMargin _ _) = True+isWindowHMargin	_		    = False++isWindowHScroll	:: WindowAttribute ls ps -> Bool+isWindowHScroll	(WindowHScroll _) = True+isWindowHScroll	_		  = False++isWindowId :: WindowAttribute ls ps -> Bool+isWindowId (WindowId _) = True+isWindowId _            = False++isWindowIndex :: WindowAttribute ls ps -> Bool+isWindowIndex (WindowIndex _) = True+isWindowIndex _		      = False++isWindowInit :: WindowAttribute ls ps -> Bool+isWindowInit (WindowInit _) = True+isWindowInit _              = False++isWindowInitActive :: WindowAttribute ls ps -> Bool+isWindowInitActive (WindowInitActive _)	= True+isWindowInitActive _			= False++isWindowItemSpace :: WindowAttribute ls ps -> Bool+isWindowItemSpace (WindowItemSpace _ _)	= True+isWindowItemSpace _			= False++isWindowKeyboard :: WindowAttribute ls ps -> Bool+isWindowKeyboard (WindowKeyboard _ _ _)	= True+isWindowKeyboard _						= False++isWindowLook :: WindowAttribute ls ps -> Bool+isWindowLook (WindowLook _ _) = True+isWindowLook _		      = False++isWindowMouse :: WindowAttribute ls ps -> Bool+isWindowMouse (WindowMouse _ _ _) = True+isWindowMouse _			  = False++isWindowOk :: WindowAttribute ls ps -> Bool+isWindowOk (WindowOk _)	= True+isWindowOk _		= False++isWindowOrigin :: WindowAttribute ls ps -> Bool+isWindowOrigin (WindowOrigin _)	= True+isWindowOrigin _		= False++isWindowOuterSize :: WindowAttribute ls ps -> Bool+isWindowOuterSize (WindowOuterSize _) = True+isWindowOuterSize _		      = False++isWindowPen :: WindowAttribute ls ps -> Bool+isWindowPen (WindowPen _) = True+isWindowPen _		  = False++isWindowPos :: WindowAttribute ls ps -> Bool+isWindowPos (WindowPos _) = True+isWindowPos _		  = False++isWindowSelectState :: WindowAttribute ls ps -> Bool+isWindowSelectState (WindowSelectState _) = True+isWindowSelectState _			  = False++isWindowViewDomain :: WindowAttribute ls ps -> Bool+isWindowViewDomain (WindowViewDomain _)	= True+isWindowViewDomain _			= False++isWindowViewSize :: WindowAttribute ls ps -> Bool+isWindowViewSize (WindowViewSize _) = True+isWindowViewSize _                  = False++isWindowVMargin	:: WindowAttribute ls ps -> Bool+isWindowVMargin	(WindowVMargin _ _) = True+isWindowVMargin	_		    = False++isWindowVScroll	:: WindowAttribute ls ps -> Bool+isWindowVScroll	(WindowVScroll _) = True+isWindowVScroll	_		  = False++isWindowCaret :: WindowAttribute ls ps -> Bool+isWindowCaret (WindowCaret _ _) = True+isWindowCaret _			= False++isWindowResize :: WindowAttribute ls ps -> Bool+isWindowResize (WindowResize _) = True+isWindowResize _		= False++isWindowDoubleBuffered :: WindowAttribute ls ps -> Bool+isWindowDoubleBuffered WindowDoubleBuffered 	= True+isWindowDoubleBuffered _			= False++getWindowActivateFun :: WindowAttribute ls ps -> GUIFun ls ps+getWindowActivateFun (WindowActivate f) = f++getWindowCancelAtt :: WindowAttribute ls ps -> Id+getWindowCancelAtt (WindowCancel id) = id++getWindowCloseFun :: WindowAttribute ls ps -> GUIFun ls ps+getWindowCloseFun (WindowClose f) = f++getWindowCursorAtt :: WindowAttribute ls ps -> CursorShape+getWindowCursorAtt (WindowCursor cShape) = cShape++getWindowDeactivateFun :: WindowAttribute ls ps -> GUIFun ls ps+getWindowDeactivateFun (WindowDeactivate f) = f++getWindowHMarginAtt :: WindowAttribute ls ps -> (Int,Int)+getWindowHMarginAtt (WindowHMargin left right) = (left,right)++getWindowHScrollFun :: WindowAttribute ls ps -> ScrollFunction+getWindowHScrollFun (WindowHScroll f) = f++getWindowIdAtt :: WindowAttribute ls ps -> Id+getWindowIdAtt (WindowId id) = id++getWindowIndexAtt :: WindowAttribute ls ps -> Int+getWindowIndexAtt (WindowIndex index) = index++getWindowInitFun :: WindowAttribute ls ps -> GUIFun ls ps+getWindowInitFun (WindowInit init) = init++getWindowInitActiveAtt :: WindowAttribute ls ps -> Id+getWindowInitActiveAtt (WindowInitActive id) = id++getWindowItemSpaceAtt :: WindowAttribute ls ps -> (Int,Int)+getWindowItemSpaceAtt (WindowItemSpace hspace vspace) = (hspace,vspace)++getWindowKeyboardAtt :: WindowAttribute ls ps -> (KeyboardStateFilter,SelectState,KeyboardFunction ls ps)+getWindowKeyboardAtt (WindowKeyboard filter select keysF) = (filter,select,keysF)++getWindowLookAtt :: WindowAttribute ls ps -> (Bool,Look)+getWindowLookAtt (WindowLook systemLook f) = (systemLook,f)++getWindowMouseAtt :: WindowAttribute ls ps  -> (MouseStateFilter,SelectState,MouseFunction ls ps)+getWindowMouseAtt (WindowMouse filter select mouseF) = (filter,select,mouseF)++getWindowOkAtt :: WindowAttribute ls ps -> Id+getWindowOkAtt (WindowOk id) = id++getWindowOriginAtt :: WindowAttribute ls ps -> Point2+getWindowOriginAtt (WindowOrigin origin) = origin++getWindowOuterSizeAtt :: WindowAttribute ls ps -> Size+getWindowOuterSizeAtt (WindowOuterSize size) = size++getWindowPenAtt :: WindowAttribute ls ps -> [PenAttribute]+getWindowPenAtt (WindowPen pen) = pen++getWindowPosAtt :: WindowAttribute ls ps -> ItemPos+getWindowPosAtt (WindowPos pos) = pos++getWindowSelectStateAtt :: WindowAttribute ls ps -> SelectState+getWindowSelectStateAtt (WindowSelectState select) = select++getWindowViewDomainAtt :: WindowAttribute ls ps -> ViewDomain+getWindowViewDomainAtt (WindowViewDomain d) = d++getWindowViewSizeAtt :: WindowAttribute ls ps -> Size+getWindowViewSizeAtt (WindowViewSize size) = size++getWindowVMarginAtt :: WindowAttribute ls ps -> (Int,Int)+getWindowVMarginAtt (WindowVMargin top bottom) = (top,bottom)++getWindowVScrollFun :: WindowAttribute ls ps -> ScrollFunction+getWindowVScrollFun (WindowVScroll f) = f++getWindowCaretAtt :: WindowAttribute ls ps -> (Point2,Size)+getWindowCaretAtt (WindowCaret pos size) = (pos,size)++getWindowResizeAtt :: WindowAttribute ls ps -> WindowResizeFunction ls ps+getWindowResizeAtt (WindowResize f) = f
+ Graphics/UI/ObjectIO/StdWindowDef.hs view
@@ -0,0 +1,75 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  StdWindowDef+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- StdWindowDef contains the types to define the standard set of dialogs.+--+-----------------------------------------------------------------------------+++module Graphics.UI.ObjectIO.StdWindowDef+		(+		-- | Data type definitions+		  module Graphics.UI.ObjectIO.StdWindowDef+		, Look, PenAttribute(..),+		-- A visible modules+		  module Graphics.UI.ObjectIO.StdIOCommon+		, module Graphics.UI.ObjectIO.StdGUI		+		) where+++import Graphics.UI.ObjectIO.StdGUI+import Graphics.UI.ObjectIO.StdIOCommon+import Graphics.UI.ObjectIO.StdPicture(PenAttribute(..), Look)++-- | The dialogs are nonresizable modal or nonmodal windows. They adjust their size to the common size+-- of the contained controls. They usually have two special buttons called \"Ok\" and+-- \"Cancel\". When the user presses Enter or Esc keys, the dialog interprets this event as+-- clicking on \"Ok\" or \"Cancel\".+data	Dialog c ls ps = Dialog Title (c ls ps) [WindowAttribute ls ps]++-- | The windows are resizable and one can draw in the view domain.This can be programmed as a Haskell\'s function.+-- They also can have vertical and horizontal scroll bars, which extend logical view frame of the windows.+data	Window c ls ps = Window Title (c ls ps) [WindowAttribute ls ps]++data	WindowAttribute ls ps                        -- Default:+ --	Attributes for Windows and Dialogs:+ =	WindowActivate   (GUIFun ls ps)              -- id+ |	WindowClose      (GUIFun ls ps)              -- user can't close window+ |	WindowDeactivate (GUIFun ls ps)              -- id+ |	WindowHMargin	 Int Int		     -- system dependent+ |	WindowId         Id                          -- system defined id+ |	WindowIndex	 Int			     -- open front-most+ |	WindowInit       (GUIFun ls ps)              -- no actions after opening window+ |	WindowInitActive Id			     -- system dependent+ |	WindowItemSpace	 Int Int		     -- system dependent+ |	WindowOuterSize	 Size			     -- screen size+ |	WindowPos	 ItemPos		     -- system dependent+ |	WindowViewSize   Size                        -- screen size+ |	WindowVMargin	 Int Int		     -- system dependent+ --	Attributes for Dialog only:	+ |	WindowCancel	 Id			     -- no cancel  (Custom)ButtonControl+ |	WindowOk	 Id			     -- no default (Custom)ButtonControl+ --	Attributes for Windows only:	+ | 	WindowCursor	 CursorShape		     -- no change of cursor+ |	WindowHScroll	 ScrollFunction		     -- no horizontal scrolling+ |	WindowKeyboard	 KeyboardStateFilter SelectState (KeyboardFunction ls ps) -- no keyboard input+ |	WindowLook	 Bool Look		     -- show system dependent background+ |	WindowMouse	 MouseStateFilter SelectState (MouseFunction ls ps) -- no mouse input+ |	WindowOrigin	 Point2			     -- left top of picture domain+ |	WindowPen	 [PenAttribute]		     -- default pen attributes+ |	WindowSelectState	SelectState	     -- Able+ |	WindowViewDomain	ViewDomain	     -- {zero,max range}+ |	WindowVScroll		ScrollFunction	     -- no vertical scrolling+ |	WindowCaret	Point2 Size		     -- no caret+ |	WindowResize    (WindowResizeFunction ls ps) -- no function+ |	WindowDoubleBuffered+ + +type WindowResizeFunction ls ps = Size -> Size -> GUIFun ls ps
+ Graphics/UI/ObjectIO/SystemId.hs view
@@ -0,0 +1,57 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  SystemId+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- SystemId defines the basic identification values to identify GUI objects.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.SystemId where+++data	SystemId = SystemId [Int] Int+++worldSystemId :: Int -> SystemId	-- This systemid is always associated with the World+worldSystemId nrCreated = SystemId [0] nrCreated++worldChildId :: Int -> SystemId		-- This systemid is used for creating systemid from World+worldChildId nrCreated = SystemId [nrCreated,0] 0++initSystemId :: SystemId		-- This systemid is always associated with the initial IOState+initSystemId = SystemId [1] 0++nullSystemId :: SystemId		-- Dummy systemid+nullSystemId = SystemId [] 0++incrSystemId :: SystemId -> (SystemId,SystemId)+incrSystemId id@(SystemId idpath nrCreated)+	= (SystemId idpath idmax,SystemId (idmax:idpath) 0)+	where+		idmax = nrCreated+1++instance Eq SystemId where+	(==) (SystemId idpath1 _) (SystemId idpath2 _) = idpath1 == idpath2++instance Ord SystemId where+	(<) (SystemId idpath1 _) (SystemId idpath2 _)+		= lessidpath ids1 ids2+		where+			(ids1,ids2) = removecommonprefix idpath1 idpath2+			+			removecommonprefix xxs@(x:xs) yys@(y:ys)+				| x==y      = removecommonprefix xs ys+				| otherwise = (xxs,yys)+			removecommonprefix xs ys+				= (xs,ys)+			+			lessidpath (x:xs) (y:ys) = x<y+			lessidpath []     (_:_)  = True+			lessidpath _      _      = False
+ Graphics/UI/ObjectIO/Timer/Access.hs view
@@ -0,0 +1,75 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Timer.Access+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--	+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Timer.Access where+++import  Graphics.UI.ObjectIO.Id+import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.Device.SystemState+import	Graphics.UI.ObjectIO.Timer.Handle+import	Graphics.UI.ObjectIO.Timer.Table+import  Graphics.UI.ObjectIO.Receiver.Handle+import  Data.Map as Map+++timerAccessFatalError :: String -> String -> x+timerAccessFatalError function error = dumpFatalError function "TimerAccess" error+++{-	bindTimerElementIds binds all unbound R(2)Ids and Ids that can be located in the list of TimerElementStates.+	The Boolean result is True only if no bound identification was found, otherwise it is False.+-}+bindTimerElementIds :: SystemId -> Id -> [TimerElementHandle ls ps] -> IdTable -> Maybe IdTable+bindTimerElementIds pid timerid (itemH:itemHs) it =+	bindTimerElementIds' pid timerid itemH it >>= bindTimerElementIds pid timerid itemHs+	where+		bindTimerElementIds' :: SystemId -> Id -> TimerElementHandle ls ps -> IdTable -> Maybe IdTable+		bindTimerElementIds' pid timerid itemH@(TimerReceiverHandle trH _) it+			| Map.member rid it = Nothing+			| otherwise = Just (insert rid (IdParent{idpIOId=pid,idpDevice=TimerDevice,idpId=timerid}) it)+			where+				rid	= rId trH++		bindTimerElementIds' pid timerid (TimerListLSHandle itemHs) it =+			bindTimerElementIds pid timerid itemHs it++		bindTimerElementIds' pid timerid (TimerExtendLSHandle exLS itemHs) it =+			bindTimerElementIds pid timerid itemHs it++		bindTimerElementIds' pid timerid (TimerChangeLSHandle chLS itemHs) it =+			bindTimerElementIds pid timerid itemHs it+		+bindTimerElementIds _ _ itemHs it = Just it+++{-	unbindTimerElementIds unbinds all bound R(2)Ids and Ids that can be located in the list of TimerElementStates. -}++unbindTimerElementIds :: SystemId -> [TimerElementHandle ls ps] -> (TimerTable,IdTable) -> (TimerTable,IdTable)+unbindTimerElementIds pid itemHs tables+	= foldr unbindTimerElementIds' tables itemHs+	where+		unbindTimerElementIds' :: TimerElementHandle ls ps -> (TimerTable,IdTable) -> (TimerTable,IdTable)+		unbindTimerElementIds' (TimerReceiverHandle (ReceiverHandle {rId=rId}) _) (tt,it) =+			(removeTimerFromTimerTable teLoc tt,Map.delete rId it)+			where+				teLoc	= TimerLoc{tlIOId=pid,tlDevice=TimerDevice,tlParentId=rId,tlTimerId=rId}+		unbindTimerElementIds' (TimerListLSHandle itemHs) tables =+			foldr unbindTimerElementIds' tables itemHs+		unbindTimerElementIds' (TimerExtendLSHandle exLS itemHs) tables =+			foldr unbindTimerElementIds' tables itemHs+		unbindTimerElementIds' (TimerChangeLSHandle chLS itemHs) tables =+			foldr unbindTimerElementIds' tables itemHs++identifyTimerStateHandle :: Id -> TimerStateHandle ps -> Bool+identifyTimerStateHandle id (TimerStateHandle (TimerLSHandle {tHandle=tH})) = id == tId tH
+ Graphics/UI/ObjectIO/Timer/DefAccess.hs view
@@ -0,0 +1,50 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Timer.DefAccess+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--	+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Timer.DefAccess where+++import	Graphics.UI.ObjectIO.StdTimerAttribute+import	Graphics.UI.ObjectIO.CommonDef+++timerDefGetAttributes :: Timer t ls ps -> [TimerAttribute ls ps]+timerDefGetAttributes (Timer _ _ atts) = atts++timerDefGetElements :: Timer t ls ps -> t ls ps+timerDefGetElements (Timer _ items _) = items++timerDefSetAbility	:: SelectState -> Timer t ls ps -> Timer t ls ps+timerDefSetAbility select (Timer interval items atts) = Timer interval items (setAbility select atts)+	where+		setAbility :: SelectState -> [TimerAttribute ls ps] -> [TimerAttribute ls ps]+		setAbility select atts+			| done		= atts1+			| otherwise	= att:atts+			where+				att			= TimerSelectState select+				(done,atts1)= creplace isTimerSelectState att atts++timerDefSetInterval	:: TimerInterval -> Timer t ls ps -> Timer t ls ps+timerDefSetInterval interval (Timer _ items atts) = Timer interval items atts++timerDefSetFunction	:: TimerFunction ls ps -> Timer t ls ps -> Timer t ls ps+timerDefSetFunction f (Timer interval items atts) = Timer interval items (setFunction f atts)+	where+		setFunction :: TimerFunction ls ps -> [TimerAttribute ls ps] -> [TimerAttribute ls ps]+		setFunction f atts+			| done		= atts1+			| otherwise	= att:atts+			where+				att		= TimerFunction f+				(done,atts1)	= creplace isTimerFunction att atts
+ Graphics/UI/ObjectIO/Timer/Device.hs view
@@ -0,0 +1,148 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Timer.Device+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--	+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Timer.Device(timerFunctions) where+++import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.Process.IOState+import	Graphics.UI.ObjectIO.Receiver.Handle+import  Graphics.UI.ObjectIO.StdTimerDef(NrOfIntervals)+import	Graphics.UI.ObjectIO.Timer.Access+import	Graphics.UI.ObjectIO.Timer.DefAccess+import	Graphics.UI.ObjectIO.Timer.Handle+import	Graphics.UI.ObjectIO.Timer.Table+import  Graphics.UI.ObjectIO.Id+import	Graphics.UI.ObjectIO.OS.TimerEvent+import  System.IO(fixIO)+import  Data.Map as Map+++timerDeviceFatalError :: String -> String -> x+timerDeviceFatalError function error = dumpFatalError function "TimerDevice" error++timerFunctions :: DeviceFunctions ps+timerFunctions =+	DeviceFunctions +	  {	dDevice	= TimerDevice+	  ,	dShow	= return+	  ,	dHide	= return+	  ,	dEvent	= timerEvent+	  ,	dDoIO	= timerIO+	  ,	dOpen	= timerOpen+	  ,	dClose	= timerClose+	  }++timerOpen :: ps -> GUI ps ps+timerOpen ps = do+	hasTimer <- accIOEnv (ioStHasDevice TimerDevice)+	(if hasTimer then return ps+	 else do+		appIOEnv (ioStSetDevice (TimerSystemState (TimerHandles	{tTimers=[]})))+		appIOEnv (ioStSetDeviceFunctions timerFunctions)+		return ps)+		++timerClose :: ps -> GUI ps ps+timerClose ps = do+	(found,timers) <- accIOEnv (ioStGetDevice TimerDevice)+	(if not found then return ps+	 else do+		tt <- ioStGetTimerTable+		it <- ioStGetIdTable+		pid <- accIOEnv ioStGetIOId+		let tHs	= timerSystemStateGetTimerHandles timers+		let (tt1,it1) = foldr (closeTimerIds pid) (tt,it) (tTimers tHs)+		ioStSetTimerTable tt1+		ioStSetIdTable it1+		appIOEnv (ioStRemoveDevice TimerDevice)+		appIOEnv (ioStRemoveDeviceFunctions TimerDevice)+		return ps)+	where+		closeTimerIds :: SystemId -> TimerStateHandle ps -> (TimerTable,IdTable) -> (TimerTable,IdTable)+		closeTimerIds pid (TimerStateHandle (TimerLSHandle {tHandle=(TimerHandle {tId=tId,tItems=tItems})})) tables =+			let (tt,it)	= unbindTimerElementIds pid tItems tables+			in (removeTimerFromTimerTable teLoc tt,delete tId it)+			where+				teLoc = TimerLoc{tlIOId=pid,tlDevice=TimerDevice,tlParentId=tId,tlTimerId=tId}+++timerIO	:: DeviceEvent -> ps -> GUI ps ps+timerIO deviceEvent ps = do+	hasDevice <- accIOEnv (ioStHasDevice TimerDevice)+	(if (not hasDevice)+	 then timerDeviceFatalError "timerFunctions.dDoIO" "could not retrieve TimerSystemState from IOSt"+	 else timerIO deviceEvent ps)+	where+		timerIO	:: DeviceEvent -> ps -> GUI ps ps+		timerIO (TimerDeviceEvent (TimerEvent {teLoc=TimerLoc{tlParentId=tlParentId,tlTimerId=tlTimerId},teNrInterval=teNrInterval})) ps = do+			(_,timer) <- accIOEnv (ioStGetDevice TimerDevice)+			let timers = timerSystemStateGetTimerHandles timer		  +			toGUI (letOneTimerDoIO tlParentId tlTimerId teNrInterval timers ps)+			where+				letOneTimerDoIO :: Id -> Id -> NrOfIntervals -> TimerHandles ps -> ps -> IOSt ps -> IO (ps, IOSt ps)+				letOneTimerDoIO parent timer nrOfIntervals timers ps ioState = f tsH ioState+					where+						(_,tsH,tsHs) = remove (identifyTimerStateHandle parent) (timerDeviceFatalError "timerIO (TimerEvent _)" "timer could not be found") (tTimers timers)++						f (TimerStateHandle tlsH@(TimerLSHandle {tState=ls,tHandle=tH})) ioState = do+							r <- fixIO (\st -> fromGUI (tFun tH nrOfIntervals (ls,ps))+								(ioStSetDevice (TimerSystemState timers{tTimers=tsHs++[TimerStateHandle tlsH{tState=fst (fst st)}]}) ioState))+							let ((_,ps1), ioState) = r+							return (ps1,ioState)++		timerIO (ReceiverEvent rid) ps = do+			(_,timers) <- accIOEnv (ioStGetDevice TimerDevice)+			let tHs = timerSystemStateGetTimerHandles timers+			toGUI (msgTimerStateHandles (\tsHs st ioState -> ioStSetDevice (TimerSystemState tHs{tTimers=tsHs}) ioState) rid (tTimers tHs) ps)+			where			+				msgTimerStateHandles :: ([TimerStateHandle ps] -> ps -> IOSt ps -> IOSt ps) ->+							  Id -> [TimerStateHandle ps] -> ps -> IOSt ps -> IO (ps,IOSt ps)+				msgTimerStateHandles build rid (tsH@(TimerStateHandle (TimerLSHandle {tState=ls,tHandle=tH@(TimerHandle {tItems=itemHs})})):tsHs) ps ioState = do+					r <- msgTimerElementHandles (\itemHs st ioState -> build (TimerStateHandle (TimerLSHandle {tState=fst st,tHandle=tH{tItems=itemHs}}):tsHs) (snd st) ioState) rid itemHs (ls,ps) ioState+					let (done,(ls,ps),ioState) = r				  +					(if done then return (ps, ioState)+					 else msgTimerStateHandles (\tsHs st ioState -> build (tsH:tsHs) st ioState) rid tsHs ps ioState)+					where+						msgTimerElementHandles :: ([TimerElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IOSt ps) ->+									    Id -> [TimerElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IO (Bool,(ls,ps),IOSt ps)+						msgTimerElementHandles build rid (itemH:itemHs) ls_ps ioState = do+							r <- msgTimerElementHandle (\itemH st ioState -> build (itemH:itemHs) st ioState) rid itemH ls_ps ioState+							let (done,ls_ps,ioState) = r+							(if done then return r+							 else msgTimerElementHandles (\itemHs st ioState -> build (itemH:itemHs) st ioState) rid itemHs ls_ps ioState)+							where+								msgTimerElementHandle :: (TimerElementHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+											   Id -> TimerElementHandle ls ps -> (ls,ps) -> IOSt ps -> IO (Bool,(ls,ps),IOSt ps)+								msgTimerElementHandle build rid (TimerListLSHandle itemHs) ls_ps ioState =+									msgTimerElementHandles (\itemHs st ioState -> build (TimerListLSHandle itemHs) st ioState) rid itemHs ls_ps ioState++								msgTimerElementHandle build rid (TimerExtendLSHandle exLS itemHs) (ls,ps) ioState = do+									r <- msgTimerElementHandles (\itemHs st ioState -> build (TimerExtendLSHandle (fst (fst st)) itemHs) (snd (fst st), snd st) ioState) rid itemHs ((exLS,ls),ps) ioState+									let (done,((_,ls),ps),ioState) = r+									return (done,(ls,ps),ioState)++								msgTimerElementHandle build rid (TimerChangeLSHandle chLS itemHs) (ls,ps) ioState = do+									r <- msgTimerElementHandles (\itemHs st ioState -> build (TimerChangeLSHandle (fst st) itemHs) (ls,snd st) ioState) rid itemHs (chLS,ps) ioState+									let (done,(_,ps),ioState) = r+									return (done,(ls,ps),ioState)++								msgTimerElementHandle build rid itemH@(TimerReceiverHandle rH@(ReceiverHandle {rFun=rFun}) atts) ls_ps ioState+									| receiverIdentified rid rH = do+										r <- fixIO (\st -> fromGUI (rFun ls_ps) (build (TimerReceiverHandle rH atts) (fst st) ioState))+										let (ls_ps, ioState) = r+										return (True, ls_ps, ioState)+									| otherwise = return (False,ls_ps, ioState)++						msgTimerElementHandles _ _ _ ps ioState = return (False,ps,ioState)+				msgTimerStateHandles _ _ _ ps ioState = return (ps,ioState)
+ Graphics/UI/ObjectIO/Timer/Handle.hs view
@@ -0,0 +1,67 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Timer.Handle+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--	+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Timer.Handle where+++import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.Receiver.Handle+import	Graphics.UI.ObjectIO.StdTimerDef+++type TimerElementState ls ps =							-- The internal implementation of a timer+	TimerElementHandle ls ps						-- is a TimerElementHandle++data TimerHandles ps+   = TimerHandles+   	{ tTimers	:: ![TimerStateHandle ps]				-- The timers of a process+	}+	+data TimerStateHandle ps+   = forall ls . TimerStateHandle (TimerLSHandle ls ps)			-- A timer with local state+   +data TimerLSHandle ls ps+   = TimerLSHandle+	{ tState	:: ls							-- The local state of this timer+	, tHandle	:: TimerHandle ls ps					-- The timer implementation+	}+	+data TimerHandle ls ps+   = TimerHandle+   	{ tId		:: !Id							-- The Id attribute or generated system Id of the timer+	, tSelect	:: !Bool						-- The TimerSelect==Able (by default True)+	, tPeriod	:: !Int							-- The interval time in ticks+	, tFun		:: !(TimerFunction ls ps)				-- The TimerFunction, optionally with local state+	, tItems	:: [TimerElementHandle ls ps]				-- The elements of the timer+	}++data TimerElementHandle ls ps+   	= TimerReceiverHandle+   		{ tReceiverHandle :: !(ReceiverHandle ls ps)+		, tReceiverAtts	  :: ![TimerAttribute ls ps]+		}+	| TimerListLSHandle	[TimerElementHandle	ls ps]+	| forall exLS .+	  TimerExtendLSHandle	exLS  [TimerElementHandle (exLS,ls) ps]+	| forall chLS .+	  TimerChangeLSHandle	chLS  [TimerElementHandle chLS ps]+	+++--	Conversion functions from TimerElementState to TimerElementHandle, and vice versa:++timerElementHandleToTimerElementState :: TimerElementHandle ls ps -> TimerElementState ls ps+timerElementHandleToTimerElementState tHs = tHs++timerElementStateToTimerElementHandle :: TimerElementState ls ps -> TimerElementHandle ls ps+timerElementStateToTimerElementHandle tHs = tHs
+ Graphics/UI/ObjectIO/Timer/Table.hs view
@@ -0,0 +1,126 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Timer.Table+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--	+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Timer.Table where+++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.SystemId+import Graphics.UI.ObjectIO.Device.Types+import Graphics.UI.ObjectIO.StdTimerDef+++type TimerTable = [TimerTableEntry]				-- The currently active timers+data TimerTableEntry+   = TimerTableEntry+	{ tteInterval	:: !Int					-- The TimerInterval of the positive timer+	, tteElapse	:: !Int					-- The elapsed timer interval (may be negative)+	, tteLoc	:: !TimerLoc				-- The location of the positive timer+	}+data TimerLoc+   = TimerLoc+   	{ tlIOId	:: !SystemId				-- Id of parent process+	, tlDevice	:: !Device				-- Device kind of parent+	, tlParentId	:: !Id					-- Id of parent device instance+	, tlTimerId	:: !Id					-- Id of the timer itself+	} deriving Eq+data TimerEvent+   = TimerEvent+   	{ teLoc		:: !TimerLoc				-- The timer that should be evaluated+	, teNrInterval  :: !NrOfIntervals			-- The nr of timer intervals that have elapsed+	}++initialTimerTable :: TimerTable					-- initialTimerTable yields an empty TimerTable+initialTimerTable = []++{-	addTimerToTimerTable adds a new timer entry to the TimerTable.+	The Boolean result is True iff no duplicate timer entry was found, otherwise it is False.+	The TimerInterval argument is set to zero if it less than zero. +-}+addTimerToTimerTable :: TimerLoc -> TimerInterval -> TimerTable -> TimerTable+addTimerToTimerTable loc interval timers = add loc (max 0 interval) timers+	where+		entry = TimerTableEntry {tteInterval=interval,tteElapse=interval,tteLoc=loc}+		+		add :: TimerLoc -> TimerInterval -> [TimerTableEntry] -> [TimerTableEntry]+		add loc interval (tte:ttes)+			| loc == tteLoc tte = entry : ttes+			| otherwise         = tte : add loc interval ttes+		add loc interval []         = [entry]++{-	removeTimerFromTimerTable removes a timer from the TimerTable. -}+removeTimerFromTimerTable :: TimerLoc -> TimerTable -> TimerTable+removeTimerFromTimerTable loc timers = filter (\tte -> tteLoc tte /= loc) timers++{-	setIntervalInTimerTable changes the timerinterval of the given timer in the TimerTable.+	If the timer was not present in the table, then nothing happens (the Boolean result is False).+	If the timer was present, its entry has been changed (the Boolean result is True).+-}+setIntervalInTimerTable :: TimerLoc -> TimerInterval -> TimerTable -> (Bool,TimerTable)+setIntervalInTimerTable loc interval timers = set loc (max 0 interval) timers+	where+		set :: TimerLoc -> TimerInterval -> [TimerTableEntry] -> (Bool,[TimerTableEntry])+		set loc interval (tte:ttes)+			| loc==tteLoc tte =+				let tte1 = if interval == 0 then tte{tteInterval=interval,tteElapse=0} else tte{tteInterval=interval}+				in (True,tte:ttes)+			| otherwise =+				let (found,ttes1) = set loc interval ttes+				in (found,tte:ttes1)+		set _ _ ttes = (False,ttes)++{-	shiftTimeInTimerTable dt shifts the TimerTable dt (>0) ticks forward in time.  -}+shiftTimeInTimerTable :: Int -> TimerTable -> TimerTable+shiftTimeInTimerTable dt timers+	| dt<=0     = timers+	| otherwise = shiftTimes dt timers+	where+	  shiftTimes :: Int -> [TimerTableEntry] -> [TimerTableEntry]+	  shiftTimes dt (tte@(TimerTableEntry {tteInterval=tteInterval,tteElapse=tteElapse}) : ttes)+		  | tteInterval==0 = tte : shiftTimes dt ttes+		  | otherwise = tte{tteElapse=tteElapse-dt} : shiftTimes dt ttes+	  shiftTimes _ ttes = ttes++{-	getActiveTimerInTimerTable determines the next timer that should be evaluated given the current+	TimerTable. Such a timer is any timer with a negative or zero elapsed time. +	If such a timer could be found, then getActiveTimerInTimerTable returns its timer location and +		number of fully elapsed timer intervals. The timer in question is placed behind all further+		timers, creating a round-robin evaluation order.+	If such a timer could not be found, then Nothing is returned. +-}+getActiveTimerInTimerTable :: TimerTable -> (Maybe TimerEvent,TimerTable)+getActiveTimerInTimerTable (tte@(TimerTableEntry {tteElapse=tteElapse,tteInterval=tteInterval,tteLoc=tteLoc}) : ttes)+	| tteElapse <= 0 =+	 	let+	 		nrTimeInterval	= if tteInterval==0 then 1 else (abs tteElapse) `div` tteInterval+1+			tEvent		= TimerEvent {teLoc=tteLoc,teNrInterval=nrTimeInterval}+			tte'		= tte{tteElapse=tteElapse+nrTimeInterval*tteInterval}+		in (Just tEvent,ttes++[tte'])+	| otherwise =+		let (active,ttes') = getActiveTimerInTimerTable ttes+		in (active,tte:ttes')+getActiveTimerInTimerTable _ = (Nothing,[])++{-	getTimeIntervalFromTimerTable returns the (Just time) interval that can be waited for the next timer to+	become active.+	If there are no timers, then Nothing is returned.+-}+getTimeIntervalFromTimerTable :: TimerTable -> Maybe Int+getTimeIntervalFromTimerTable [] = Nothing+getTimeIntervalFromTimerTable timers = Just (getSleepTime (2^31-1) timers)+	where+		getSleepTime :: Int -> [TimerTableEntry] -> Int+		getSleepTime sleep (tte@(TimerTableEntry {tteElapse=tteElapse}):ttes)+			| tteElapse<=0 = 0+			| otherwise    = getSleepTime (min sleep tteElapse) ttes+		getSleepTime sleep _ = sleep
+ Graphics/UI/ObjectIO/Window/Access.hs view
@@ -0,0 +1,579 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Window.Access+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Window.Access defines access operations to Window(State)Handle(s).+--	+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Window.Access+		( module Graphics.UI.ObjectIO.Window.Access+		, module Graphics.UI.ObjectIO.Window.Handle+		) where++++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.OS.System+import Graphics.UI.ObjectIO.Window.Handle+import Graphics.UI.ObjectIO.KeyFocus+import Graphics.UI.ObjectIO.StdControlAttribute(isControlKeyboard)+import Graphics.UI.ObjectIO.StdWindowAttribute(isWindowInitActive, getWindowInitActiveAtt)+import Graphics.UI.ObjectIO.OS.WindowCrossCall_12+import Data.List(find)+import GHC.Base(unsafeCoerce#)+++windowaccessFatalError :: String -> String -> x+windowaccessFatalError function error+	= dumpFatalError function "WindowAccess" error+++--	Dummy values for window handles.++dummyWindowHandles :: WindowHandles ps+dummyWindowHandles+	= WindowHandles+		{ whsWindows       = undefined+		, whsNrWindowBound = Infinite+		, whsFinalModalLS  = []+		, whsModal	   = False+		}++dummyWindowStateHandle :: WindowStateHandle ps+dummyWindowStateHandle+	= WindowStateHandle undefined undefined++dummyWindowLSHandle :: WindowLSHandle ls ps+dummyWindowLSHandle+	= WindowLSHandle+		{ wlsState    = undefined+		, wlsHandle   = undefined+		}++dummyWindowHandle :: WindowHandle ls ps+dummyWindowHandle+	= WindowHandle+		{ whMode      = undefined+		, whKind      = undefined+		, whTitle     = undefined+		, whItemNrs   = undefined+		, whKeyFocus  = undefined+		, whWindowInfo= undefined+		, whItems     = undefined+		, whShow      = undefined+		, whAtts      = undefined+		, whSelect    = undefined+		, whDefaultId = undefined+		, whCancelId  = undefined+		, whSize      = undefined+		, whClosing   = undefined+		}++initWindowHandle :: Title -> WindowMode -> WindowKind -> WindowInfo -> [WElementHandle ls ps] -> [WindowAttribute ls ps] -> WindowHandle ls ps+initWindowHandle title mode kind info itemHs atts+	= WindowHandle+		{ whMode      = mode+		, whKind      = kind+		, whTitle     = title+		, whItemNrs   = [1..]+		, whKeyFocus  = KeyFocus {kfItem=Nothing,kfItems=[]}+		, whWindowInfo= info+		, whItems     = itemHs+		, whShow      = True+		, whAtts      = atts+		, whSelect    = True+		, whDefaultId = Nothing+		, whCancelId  = Nothing+		, whSize      = zero+		, whClosing   = False+		}+		++--	Access to the additional WItemInfo field of a WItemHandle (partial functions!).++getWItemRadioInfo :: WItemInfo ls ps -> RadioInfo ls ps+getWItemRadioInfo (WRadioInfo info) = info++getWItemCheckInfo :: WItemInfo ls ps -> CheckInfo ls ps+getWItemCheckInfo (WCheckInfo info) = info++getWItemPopUpInfo :: WItemInfo ls ps -> PopUpInfo ls ps+getWItemPopUpInfo (WPopUpInfo info) = info++getWItemListBoxInfo :: WItemInfo ls ps -> ListBoxInfo ls ps+getWItemListBoxInfo (WListBoxInfo info) = info++getWItemSliderInfo :: WItemInfo ls ps -> SliderInfo ls ps+getWItemSliderInfo (WSliderInfo info) = info++getWItemTextInfo :: WItemInfo ls ps -> TextInfo+getWItemTextInfo (WTextInfo info) = info++getWItemEditInfo :: WItemInfo ls ps -> EditInfo+getWItemEditInfo (WEditInfo info) = info++getWItemButtonInfo :: WItemInfo ls ps -> ButtonInfo+getWItemButtonInfo (WButtonInfo info) = info++getWItemCustomButtonInfo :: WItemInfo ls ps -> CustomButtonInfo+getWItemCustomButtonInfo (WCustomButtonInfo info) = info++getWItemCustomInfo :: WItemInfo ls ps -> CustomInfo+getWItemCustomInfo (WCustomInfo info) = info++getWItemCompoundInfo :: WItemInfo ls ps -> CompoundInfo+getWItemCompoundInfo (WCompoundInfo info) = info++++--	For internal identification of windows/dialogs Id and OSWindowPtr (Integer) can be used.++data	WID				-- Identify a window/dialog either+	= ById  !Id			-- by its Id, or+	| ByPtr !OSWindowPtr		-- by its OSWindowPtr++class ToWID x where+	toWID :: x -> WID++instance ToWID Id where+	toWID id = ById id+instance ToWID Int where+	toWID wPtr = ByPtr wPtr+instance ToWID WIDS where+	toWID wids = ByPtr (wPtr wids)++widbyId :: WID -> Bool+widbyId (ById _) = True+widbyId _        = False++widbyPtr :: WID -> Bool+widbyPtr (ByPtr _) = True+widbyPtr _         = False++widgetId :: WID -> Id+widgetId (ById id) = id++widgetPtr :: WID -> OSWindowPtr+widgetPtr (ByPtr ptr) = ptr++identifyWIDS :: WID -> WIDS -> Bool+identifyWIDS (ById  id)  (WIDS {wId=wId})   = id==wId+identifyWIDS (ByPtr ptr) (WIDS {wPtr=wPtr}) = ptr==wPtr++identifyMaybeId :: Id -> Maybe Id -> Bool+identifyMaybeId id (Just id') = id==id'+identifyMaybeId _ _ = False+++--	Transforming CursorShape to OS cursor codes:+toCursorCode :: CursorShape -> Int+toCursorCode StandardCursor	= cursARROW+toCursorCode BusyCursor		= cursBUSY+toCursorCode IBeamCursor	= cursIBEAM+toCursorCode CrossCursor	= cursCROSS+toCursorCode FatCrossCursor	= cursFATCROSS+toCursorCode ArrowCursor	= cursARROW+toCursorCode HiddenCursor	= cursHIDDEN+++--	Calculating the view frame of window/compound with visibility of scrollbars.++getCompoundContentRect :: OSWindowMetrics -> (Bool,Bool) -> Rect -> Rect+getCompoundContentRect wMetrics (visHScroll,visVScroll) itemRect+	| visHScroll && visVScroll = itemRect {rright=r',rbottom=b'}+	| visHScroll               = itemRect {          rbottom=b'}+	| visVScroll               = itemRect {rright=r'           }+	| otherwise                = itemRect+	where+		r'                 = rright  itemRect - osmVSliderWidth  wMetrics+		b'                 = rbottom itemRect - osmHSliderHeight wMetrics++getCompoundHScrollRect :: OSWindowMetrics -> (Bool,Bool) -> Rect -> Rect+getCompoundHScrollRect wMetrics (visHScroll,visVScroll) itemRect+	| not visHScroll = zero+	| visVScroll     = itemRect {rtop=b',rright=r'}+	| otherwise      = itemRect {rtop=b'}+	where+		r'       = rright  itemRect - osmVSliderWidth  wMetrics+		b'       = rbottom itemRect - osmHSliderHeight wMetrics++getCompoundVScrollRect :: OSWindowMetrics -> (Bool,Bool) -> Rect -> Rect+getCompoundVScrollRect wMetrics (visHScroll,visVScroll) itemRect+	| not visVScroll = zero+	| visHScroll     = itemRect {rleft=r',rbottom=b'}+	| otherwise      = itemRect {rleft=r'}+	where+		r'       = rright  itemRect - osmVSliderWidth  wMetrics+		b'       = rbottom itemRect - osmHSliderHeight wMetrics+++getWindowContentRect :: OSWindowMetrics -> (Bool,Bool) -> Rect -> Rect+getWindowContentRect wMetrics (visHScroll,visVScroll) itemRect+	| visHScroll && visVScroll = itemRect {rright=r',rbottom=b'}+	| visHScroll               = itemRect {          rbottom=b'}+	| visVScroll               = itemRect {rright=r'           }+	| otherwise                = itemRect+	where+		r'                 = rright  itemRect - osmVSliderWidth  wMetrics+		b'                 = rbottom itemRect - osmHSliderHeight wMetrics++getWindowHScrollRect :: OSWindowMetrics -> (Bool,Bool) -> Rect -> Rect+getWindowHScrollRect wMetrics (visHScroll,visVScroll) (Rect {rleft=rleft,rtop=rtop,rright=rright,rbottom=rbottom})+	| not visHScroll = zero+	| otherwise      = Rect {rleft=rleft-1, rtop=b', rright=if visVScroll then r'+1 else rright+1, rbottom=rbottom+1}+	where+		r'       = rright  - osmVSliderWidth  wMetrics + 1+		b'       = rbottom - osmHSliderHeight wMetrics + 1++getWindowVScrollRect :: OSWindowMetrics -> (Bool,Bool) -> Rect -> Rect+getWindowVScrollRect wMetrics (visHScroll,visVScroll) (Rect {rleft=rleft,rtop=rtop,rright=rright,rbottom=rbottom})+	| not visVScroll = zero+	| otherwise      = Rect {rleft=r', rtop=rtop-1, rright=rright+1, rbottom=if visHScroll then b'+1 else rbottom+1}+	where+		r'       = rright  - osmVSliderWidth  wMetrics + 1+		b'       = rbottom - osmHSliderHeight wMetrics + 1+++--	Access operations on WindowStateHandles:++isModalWindow :: WindowStateHandle ps -> Bool+isModalWindow wsH = getWindowStateHandleWindowMode wsH == Modal+		+getWindowStateHandleWIDS :: WindowStateHandle ps -> WIDS+getWindowStateHandleWIDS wsH@(WindowStateHandle wshIds _) = wshIds++getWindowStateHandleWindowMode :: WindowStateHandle ps -> WindowMode+getWindowStateHandleWindowMode wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=WindowHandle {whMode=whMode}}))) = whMode+	+getWindowStateHandleWindowKind :: WindowStateHandle ps -> WindowKind+getWindowStateHandleWindowKind wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=WindowHandle {whKind=whKind}}))) = whKind++getWindowStateHandleWindowTitle :: WindowStateHandle ps -> Title+getWindowStateHandleWindowTitle wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=WindowHandle {whTitle=whTitle}}))) = whTitle++getWindowStateHandleItemNrs :: WindowStateHandle ps -> [Int]+getWindowStateHandleItemNrs wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=WindowHandle {whItemNrs=whItemNrs}}))) = whItemNrs++getWindowStateHandleKeyFocus :: WindowStateHandle ps -> KeyFocus+getWindowStateHandleKeyFocus wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=WindowHandle {whKeyFocus=whKeyFocus}}))) = whKeyFocus++getWindowStateHandleWindowInfo :: WindowStateHandle ps -> WindowInfo+getWindowStateHandleWindowInfo wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=WindowHandle {whWindowInfo=whWindowInfo}}))) = whWindowInfo++getWindowStateHandleShow :: WindowStateHandle ps -> Bool+getWindowStateHandleShow wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=WindowHandle {whShow=whShow}}))) = whShow++getWindowStateHandleActive :: WindowStateHandle ps -> Bool+getWindowStateHandleActive wsH@(WindowStateHandle (WIDS {wActive=wActive}) _) = wActive++getWindowStateHandleDefaultId :: WindowStateHandle ps -> Maybe Id+getWindowStateHandleDefaultId wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=WindowHandle{whDefaultId=whDefaultId}})))+	= whDefaultId++getWindowStateHandleCancelId :: WindowStateHandle ps -> Maybe Id+getWindowStateHandleCancelId wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=WindowHandle{whCancelId=whCancelId}})))+	= whCancelId++getWindowStateHandleSelect :: WindowStateHandle ps -> Bool+getWindowStateHandleSelect wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=WindowHandle {whSelect=whSelect}}))) = whSelect++getWindowStateHandleSize :: WindowStateHandle ps -> Size+getWindowStateHandleSize wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=WindowHandle {whSize=whSize}}))) = whSize++getWindowStateHandleClosing :: WindowStateHandle ps -> Bool+getWindowStateHandleClosing wsH@(WindowStateHandle _ (Just (WindowLSHandle {wlsHandle=WindowHandle {whClosing=whClosing}}))) = whClosing++isWindowStateHandlePlaceHolder :: WindowStateHandle ps -> Bool+isWindowStateHandlePlaceHolder wsH@(WindowStateHandle _ Nothing) = True+isWindowStateHandlePlaceHolder wsH = False++identifyWindowStateHandle :: WID -> WindowStateHandle ps -> Bool+identifyWindowStateHandle wid wsH = identifyWIDS wid (getWindowStateHandleWIDS wsH)++setWindowStateHandleWIDS :: WIDS -> WindowStateHandle ps -> WindowStateHandle ps+setWindowStateHandleWIDS wids (WindowStateHandle _ wlsH) = WindowStateHandle wids wlsH++setWindowStateHandleWindowTitle :: Title -> WindowStateHandle ps -> WindowStateHandle ps+setWindowStateHandleWindowTitle title (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH})))+	= WindowStateHandle wids (Just (wlsH {wlsHandle=wH {whTitle=title}}))++setWindowStateHandleItemNrs :: [Int] -> WindowStateHandle ps -> WindowStateHandle ps+setWindowStateHandleItemNrs itemNrs (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH})))+	= WindowStateHandle wids (Just (wlsH {wlsHandle=wH {whItemNrs=itemNrs}}))++setWindowStateHandleActive :: Bool -> WindowStateHandle ps -> WindowStateHandle ps+setWindowStateHandleActive active (WindowStateHandle wids wlsH)+	= WindowStateHandle (wids {wActive=active}) wlsH++setWindowStateHandleSelect :: Bool -> WindowStateHandle ps -> WindowStateHandle ps+setWindowStateHandleSelect select (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH})))+	= WindowStateHandle wids (Just (wlsH {wlsHandle=wH {whSelect=select}}))+	+setWindowStateHandleSize :: Size -> WindowStateHandle ps -> WindowStateHandle ps+setWindowStateHandleSize size (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH})))+	= WindowStateHandle wids (Just (wlsH {wlsHandle=wH {whSize=size}}))++setWindowStateHandleClosing :: Bool -> WindowStateHandle ps -> WindowStateHandle ps+setWindowStateHandleClosing closing (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH})))+	= WindowStateHandle wids (Just (wlsH {wlsHandle=wH {whClosing=closing}}))+++{-	Access operations on the margins and item space attributes of the window attributes.+	getWindow((H/V)Margin/ItemSpace)s type metrics atts+		retrieves the indicated attribute if present from the attribute list. If the attribute+		could not be found, the appropriate default value is returned. +-}+getWindowHMargins :: WindowKind -> OSWindowMetrics -> [WindowAttribute ls ps] -> (Int,Int)+getWindowHMargins wKind wMetrics atts+	= (defaultLeft,defaultRight)+--	= getWindowHMarginAtt (snd (cselect isWindowHMargin (WindowHMargin defaultLeft defaultRight) atts))+	where+		(defaultLeft,defaultRight) = case wKind of+						IsDialog -> (osmHorMargin wMetrics,osmHorMargin wMetrics)+						other    -> (0,0)++getWindowVMargins :: WindowKind -> OSWindowMetrics -> [WindowAttribute ls ps] -> (Int,Int)+getWindowVMargins wKind wMetrics atts+	= (defaultTop,defaultBottom)+--	= getWindowVMarginAtt (snd (cselect isWindowVMargin (WindowVMargin defaultTop defaultBottom) atts))+	where+		(defaultTop,defaultBottom) = case wKind of+						IsDialog -> (osmVerMargin wMetrics,osmVerMargin wMetrics)+						other    -> (0,0)++getWindowItemSpaces :: WindowKind -> OSWindowMetrics -> [WindowAttribute ls ps] -> (Int,Int)+getWindowItemSpaces wKind wMetrics atts+	= (defaultHor,defaultVer)+--	= getWindowItemSpaceAtt (snd (cselect isWindowItemSpace (WindowItemSpace defaultHor defaultVer) atts))+	where+		(defaultHor,defaultVer) = case wKind of+						IsDialog -> (osmHorItemSpace wMetrics,osmVerItemSpace wMetrics)+						other    -> (0,0)+++--	Search, get, and set WindowStateHandles.++getWindowHandlesActiveWindow :: WindowHandles ps -> Maybe WIDS+getWindowHandlesActiveWindow wHs@(WindowHandles {whsWindows=wsHs})+	= fmap getWindowStateHandleWIDS (find (wActive . getWindowStateHandleWIDS) wsHs)+		++--	getWindowHandlesActiveModalDialog assumes that all modal dialogues are at the front of the list+getWindowHandlesActiveModalDialog :: WindowHandles ps -> Maybe WIDS+getWindowHandlesActiveModalDialog wHs@(WindowHandles {whsWindows=[]})+	= Nothing+getWindowHandlesActiveModalDialog wHs@(WindowHandles {whsWindows=(wsH:wsHs)})	+	| mode /= Modal = Nothing+	| otherwise    	= Just wids+	where+		mode = getWindowStateHandleWindowMode wsH+		wids = getWindowStateHandleWIDS wsH++hasWindowHandlesWindow :: WID -> WindowHandles ps -> Bool+hasWindowHandlesWindow wid wHs@(WindowHandles {whsWindows=whsWindows})+	= haswindow wid whsWindows+	where		+		haswindow :: WID -> [WindowStateHandle ps] -> Bool+		haswindow wid (wsH:wsHs) = identifyWIDS wid wIds || haswindow wid wsHs+			where wIds = getWindowStateHandleWIDS wsH+		haswindow _ _ = False++getWindowHandlesWindow :: WID -> WindowHandles ps -> (Bool,WindowStateHandle ps,WindowHandles ps)+getWindowHandlesWindow wid wHs@(WindowHandles {whsWindows=whsWindows})+	= (ok,wsH,wHs {whsWindows=whsWindows1})+	where+		(ok,wsH,whsWindows1) = getwindow wid whsWindows+		+		getwindow :: WID -> [WindowStateHandle ps] -> (Bool,WindowStateHandle ps,[WindowStateHandle ps])+		getwindow wid (wsH:wsHs)+			| identifyWIDS wid wIds+			      = (True,wsH,(WindowStateHandle wIds Nothing):wsHs)+			| otherwise+			      = let (found,wsH1,wsHs1) = getwindow wid wsHs+			        in  (found,wsH1,wsH:wsHs1)+			where+				wIds = getWindowStateHandleWIDS wsH+		getwindow _ _+			= (False,dummyWindowStateHandle,[])++removeWindowHandlesWindow :: WID -> WindowHandles ps -> (Bool,WindowStateHandle ps,WindowHandles ps)+removeWindowHandlesWindow wid wHs@(WindowHandles {whsWindows=whsWindows})+	= (ok,wsH,wHs {whsWindows=whsWindows1})+	where+		(ok,wsH,whsWindows1) = remove (identifyWindowStateHandle wid) dummyWindowStateHandle whsWindows+		+		identifyWindowStateHandle :: WID -> WindowStateHandle ps -> Bool+		identifyWindowStateHandle wid wsH = identifyWIDS wid wIds+			where wIds = getWindowStateHandleWIDS wsH++setWindowHandlesWindow :: WindowStateHandle ps -> WindowHandles ps -> WindowHandles ps+setWindowHandlesWindow wsH wHs@(WindowHandles {whsWindows=whsWindows})+	| isWindowStateHandlePlaceHolder wsH+		= windowaccessFatalError "setWindowHandlesWindow" "WindowStateHandle argument should not be a place holder"+	| otherwise+		= wHs{whsWindows=setwindow (getWindowStateHandleWIDS wsH) wsH whsWindows}+	where		+		setwindow :: WIDS -> WindowStateHandle ps -> [WindowStateHandle ps] -> [WindowStateHandle ps]+		setwindow wids' wsH' (wsH:wsHs)+			| wids/=wids'+				= wsH:setwindow wids' wsH' wsHs+			| isWindowStateHandlePlaceHolder wsH+				= wsH':wsHs+			| otherwise+				= windowaccessFatalError "setWindowHandlesWindow" "place holder expected instead of WindowStateHandle"+			where+				wids = getWindowStateHandleWIDS wsH+		setwindow _ _ _+			= windowaccessFatalError "setWindowHandlesWindow" "place holder not found"++addBehindWindowHandlesWindow :: WID -> WindowStateHandle ps -> WindowHandles ps -> (WIDS,WindowHandles ps)+addBehindWindowHandlesWindow behindWID wsH wHs@(WindowHandles {whsWindows=whsWindows})+	| isWindowStateHandlePlaceHolder wsH+		= windowaccessFatalError "addBehindWindowHandlesWindow" "WindowStateHandle argument should not be a place holder"+	| otherwise+		= let (behindWIDS,whsWindows1) = stackBehind behindWID wsH whsWindows+	          in  (behindWIDS,wHs {whsWindows=whsWindows1})+	where		+		stackBehind :: WID -> WindowStateHandle ps -> [WindowStateHandle ps] -> (WIDS,[WindowStateHandle ps])+		stackBehind behindWID wsH (wsH':wsHs)+			| not (identifyWIDS behindWID wids')+				= let (behindWIDS,wsHs1) = stackBehind behindWID wsH wsHs+			          in  (behindWIDS,wsH':wsHs1)+			| otherwise+				= (wids',wsH':wsH:wsHs)+			where+				wids' = getWindowStateHandleWIDS wsH'+		stackBehind _ _ _+			= windowaccessFatalError "addBehindWindowHandlesWindow" "behind window could not be found"++addWindowHandlesWindow :: Index -> WindowStateHandle ps -> WindowHandles ps -> WindowHandles ps+addWindowHandlesWindow index wsH wHs@(WindowHandles {whsWindows=whsWindows})+	= wHs {whsWindows=insert (max 0 index) wsH whsWindows}+	where+		insert :: Index -> x -> [x] -> [x]+		insert 0 x ys+			= x:ys+		insert i x (y:ys)+			= y:insert (i-1) x ys+		insert _ x _+			= [x]++addWindowHandlesActiveWindow :: WindowStateHandle ps -> WindowHandles ps -> WindowHandles ps+addWindowHandlesActiveWindow wsH wHs@(WindowHandles {whsWindows=whsWindows})+	= wHs {whsWindows=wsH:whsWindows}+++{-	Checking WindowBounds:+-}+checkZeroWindowHandlesBound :: WindowHandles ps -> Bool+checkZeroWindowHandlesBound (WindowHandles {whsNrWindowBound=whsNrWindowBound})+	= zeroBound whsNrWindowBound++decreaseWindowHandlesBound :: WindowHandles ps -> WindowHandles ps+decreaseWindowHandlesBound wHs@(WindowHandles {whsNrWindowBound=whsNrWindowBound})+	= wHs {whsNrWindowBound=decBound whsNrWindowBound}+++{-	getInitActiveControl retrieves the OSWindowPtr of the control that has the initial input focus.+	It is assumed that the control identified by the WindowInitActive attribute exists.+-}+getInitActiveControl :: WindowHandle ls ps -> OSWindowPtr+getInitActiveControl wH@(WindowHandle {whItems=itemHs,whAtts=whAtts}) = accessWElementHandles itemHs+	where+		initActiveId = fmap getWindowInitActiveAtt (find isWindowInitActive whAtts)++		condition itemH = +			case initActiveId of+				Just _	-> wItemId   itemH==initActiveId+				Nothing -> wItemKind itemH==IsEditControl+		+		accessWElementHandles :: [WElementHandle ls ps] -> OSWindowPtr+		accessWElementHandles (itemH:itemHs)+			= let wPtr = accessWElementHandle itemH+			  in  if wPtr /= osNoWindowPtr then wPtr else accessWElementHandles itemHs+			where+				accessWElementHandle :: WElementHandle ls ps -> OSWindowPtr+				accessWElementHandle (WListLSHandle itemHs)+					= accessWElementHandles itemHs+				accessWElementHandle (WExtendLSHandle addLS itemHs)+					= accessWElementHandles itemHs+				accessWElementHandle (WChangeLSHandle newLS itemHs)+					= accessWElementHandles itemHs+				accessWElementHandle itemH+					| condition itemH = wItemPtr itemH+					| otherwise       = accessWElementHandles (wItems itemH)+		accessWElementHandles [] = osNoWindowPtr+++{-	Determine the list of window items that can obtain the keyboard input focus. -}++getWElementKeyFocusIds :: Bool -> [WElementHandle ls ps] -> [FocusItem]+getWElementKeyFocusIds shownContext (itemH:itemHs) =+	(getWElementKeyFocusIds' shownContext itemH)   +++	(getWElementKeyFocusIds  shownContext itemHs)+	where+		getWElementKeyFocusIds' :: Bool -> WElementHandle ls ps -> [FocusItem]+		getWElementKeyFocusIds' shownContext itemH@(WItemHandle {wItemNr=wItemNr,wItemKind=wItemKind,wItemShow=wItemShow,wItemAtts=wItemAtts,wItems=wItems})+			| wItemKind==IsEditControl   	= focus+			| keySensitive && hasKeyAtt  	= focus+			| otherwise 			= getWElementKeyFocusIds (shownContext && wItemShow) wItems			+			where+				focus		= [FocusItem {focusNr=wItemNr,focusShow=shownContext}]+				hasKeyAtt	= any isControlKeyboard wItemAtts+				keySensitive	= wItemKind==IsCustomControl++		getWElementKeyFocusIds' shownContext (WListLSHandle itemHs) =+			getWElementKeyFocusIds shownContext itemHs++		getWElementKeyFocusIds' shownContext (WExtendLSHandle ls1 itemHs) =+			getWElementKeyFocusIds shownContext itemHs			++		getWElementKeyFocusIds' shownContext (WChangeLSHandle ls1 itemHs) =+			getWElementKeyFocusIds shownContext itemHs			+++getWElementKeyFocusIds _ _ = []+++{-	Generate internal numbers for all WElementHandles which wItemNr==0. -}++genWElementItemNrs :: [Int] -> [WElementHandle ls ps] -> ([Int],[WElementHandle ls ps])+genWElementItemNrs nrs (itemH:itemHs)+	= (nrs2,itemH1:itemHs1)+	where+		(nrs1,itemH1)  = genWElementNrs     nrs  itemH+		(nrs2,itemHs1) = genWElementItemNrs nrs1 itemHs+		+		genWElementNrs :: [Int] -> WElementHandle ls ps -> ([Int],WElementHandle ls ps)+		genWElementNrs nrs wItemH@(WItemHandle {wItemNr=wItemNr,wItems=wItems})+			= let (nrs1,itemHs)	= genWElementItemNrs nrs wItems+			  in if wItemNr/=0 then (nrs1,wItemH{wItems=itemHs})+			     else (tail nrs1,wItemH{wItemNr=head nrs1,wItems=itemHs})+		+		genWElementNrs nrs (WListLSHandle itemHs)+			= let (nrs1,itemHs1)  = genWElementItemNrs nrs itemHs+			  in  (nrs1,WListLSHandle itemHs1)+		+		genWElementNrs nrs (WExtendLSHandle addLS itemHs)+			= let (nrs1,itemHs1) = genWElementItemNrs nrs itemHs+			  in  (nrs1,WExtendLSHandle addLS itemHs1)+		+		genWElementNrs nrs (WChangeLSHandle newLS itemHs)+			= let (nrs1,itemHs1) = genWElementItemNrs nrs itemHs+			  in  (nrs1,WChangeLSHandle newLS itemHs1)++genWElementItemNrs nrs _+	= (nrs,[])++getFinalModalLS :: WID -> FinalModalLS -> Maybe ls+getFinalModalLS wid (FinalModalLS wids ls)+	| identifyWIDS wid wids = Just (unsafeCoerce# ls)+	| otherwise		= Nothing
+ Graphics/UI/ObjectIO/Window/ClipState.hs view
@@ -0,0 +1,285 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Window.ClipState+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Window.ClipState+		( validateWindowClipState, validateCompoundClipState+	        , forceValidWindowClipState, forceValidCompoundClipState		      +		, invalidateWindowClipState, invalidateCompoundClipState+		, disposeClipState+		) where+++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Window.Access(getWItemRadioInfo,  getWItemCheckInfo,  getWItemCompoundInfo,+		    			  getCompoundContentRect, getCompoundHScrollRect, getCompoundVScrollRect, getWindowContentRect)+import Graphics.UI.ObjectIO.Window.Handle+import Graphics.UI.ObjectIO.OS.Rgn+import Graphics.UI.ObjectIO.OS.Window+import Graphics.UI.ObjectIO.OS.Cutil_12(addr2int)+import Foreign.Ptr(nullPtr)+++{-	createClipState wMetrics allClipStates validate wPtr clipRect defId isVisible items+		calculates the ClipState that corresponds with items.+		If the Boolean argument is True, also the invalid ClipStates are recalculated of CompoundControls+			that are inside the window frame. +-}+createClipState :: OSWindowMetrics -> Bool -> Bool -> OSWindowPtr -> Rect -> Maybe Id -> Bool -> [WElementHandle ls ps] -> IO (ClipState,[WElementHandle ls ps])+createClipState wMetrics allClipStates validate wPtr clipRect defId isVisible itemHs = do	+	clipRgn <- osNewRectRgn clipRect+	(itemHs,clipRgn) <- createWElementsClipState wMetrics allClipStates validate wPtr clipRect defId isVisible itemHs clipRgn+	return (ClipState{clipRgn=clipRgn,clipOk=True},itemHs)+	where+	    createWElementsClipState :: OSWindowMetrics -> Bool -> Bool -> OSWindowPtr -> Rect -> Maybe Id -> Bool -> [WElementHandle ls ps] -> OSRgnHandle -> IO ([WElementHandle ls ps],OSRgnHandle)+	    createWElementsClipState wMetrics allClipStates validate wPtr clipRect defId isVisible (itemH:itemHs) clipRgn = do+		(itemH, clipRgn1) <- createWElementClipState  wMetrics allClipStates validate wPtr clipRect defId isVisible itemH  clipRgn+		(itemHs,clipRgn2) <- createWElementsClipState wMetrics allClipStates validate wPtr clipRect defId isVisible itemHs clipRgn1+		return (itemH:itemHs,clipRgn2)+		where+		  createWElementClipState :: OSWindowMetrics -> Bool -> Bool -> OSWindowPtr -> Rect -> Maybe Id -> Bool -> WElementHandle ls ps -> OSRgnHandle -> IO (WElementHandle ls ps, OSRgnHandle)+		  createWElementClipState wMetrics allClipStates validate wPtr clipRect defId isVisible itemH@(WItemHandle {wItemShow=wItemShow,wItemKind=wItemKind}) clipRgn+		      | not itemVisible || disjointRects clipRect itemClipRect =+			      if not allClipStates || not (isRecursiveControl wItemKind) then	-- PA:<>IsCompoundControl+				      return (itemH, clipRgn)+			      else if wItemKind==IsLayoutControl then do				-- PA: this alternative added				      +				      (itemHs,clipRgn1) <- createWElementsClipState wMetrics allClipStates validate wPtr itemClipRect defId False (wItems itemH) clipRgn+				      return (itemH{wItems=itemHs},clipRgn1)+			      else if validate then do+				      itemH1 <- validateCompoundClipState wMetrics allClipStates wPtr defId itemVisible itemH+				      return (itemH1,clipRgn)+			      else do			      	      +				      itemH1 <- forceValidCompoundClipState wMetrics allClipStates wPtr defId itemVisible itemH+				      return (itemH1,clipRgn)+		      | otherwise = do+			      (itemH,clipRgn1) <- createWItemClipState wMetrics allClipStates validate wPtr clipRect defId itemH clipRgn+			      return (itemH,clipRgn1)+		      where+			  itemVisible  = isVisible && wItemShow+			  itemClipRect = posSizeToRect (wItemPos itemH) (wItemSize itemH)++			  createWItemClipState :: OSWindowMetrics -> Bool -> Bool -> OSWindowPtr -> Rect -> Maybe Id -> WElementHandle ls ps -> OSRgnHandle -> IO (WElementHandle ls ps, OSRgnHandle)+			  createWItemClipState _ _ _ wPtr clipRect _ itemH@(WItemHandle {wItemKind=IsRadioControl,wItemInfo=wItemInfo}) clipRgn = do+			      clipRgn1 <- foldrM (createRadioClipState wPtr clipRect) clipRgn (radioItems (getWItemRadioInfo wItemInfo))+			      return (itemH,clipRgn1)+			      where+				  createRadioClipState :: OSWindowPtr -> Rect -> RadioItemInfo ls ps -> OSRgnHandle -> IO OSRgnHandle+				  createRadioClipState wPtr clipRect (RadioItemInfo{radioItemPos=radioItemPos,radioItemSize=radioItemSize}) clipRgn = do+				      radioRgn <- osClipRadioControl wPtr (0,0) clipRect (toTuple radioItemPos) (toTuple radioItemSize)+				      diffRgn <- osDiffRgn clipRgn radioRgn+				      osDisposeRgn clipRgn				      +				      osDisposeRgn radioRgn+				      return diffRgn++			  createWItemClipState _ _ _ wPtr clipRect defId itemH@(WItemHandle {wItemKind=IsCheckControl,wItemInfo=wItemInfo}) clipRgn = do+			      clipRgn <- foldrM (createCheckClipState wPtr clipRect) clipRgn (checkItems (getWItemCheckInfo wItemInfo))+			      return (itemH,clipRgn)+			      where+				  createCheckClipState :: OSWindowPtr -> Rect -> CheckItemInfo ls ps -> OSRgnHandle -> IO OSRgnHandle+				  createCheckClipState wPtr clipRect (CheckItemInfo{checkItemPos=checkItemPos,checkItemSize=checkItemSize}) clipRgn = do+				      checkRgn <- osClipCheckControl wPtr (0,0) clipRect (toTuple checkItemPos) (toTuple checkItemSize)+				      diffRgn <- osDiffRgn clipRgn checkRgn+				      osDisposeRgn clipRgn+				      osDisposeRgn checkRgn+				      return diffRgn++			  createWItemClipState wMetrics allClipStates validate wPtr clipRect defId itemH@(WItemHandle {wItemKind=IsCompoundControl,wItems=wItems}) clipRgn = do+			      rectRgn <- osClipCompoundControl wPtr (0,0) clipRect (toTuple itemPos) (toTuple itemSize)+			      diffRgn <- osDiffRgn clipRgn rectRgn+			      osDisposeRgn clipRgn+			      osDisposeRgn rectRgn+			      (if allClipStates then+			         if validate then do+			           itemH1 <- validateCompoundClipState wMetrics allClipStates wPtr defId True itemH+				   return (itemH1,diffRgn)+				 else do+				   itemH1 <- forceValidCompoundClipState wMetrics allClipStates wPtr defId True itemH				   +				   return (itemH1,diffRgn)+			       else+				 return (itemH,diffRgn))+			      where+				 itemPos	= wItemPos itemH+				 itemSize	= wItemSize itemH++			  createWItemClipState wMetrics allClipStates validate wPtr clipRect defId itemH@(WItemHandle {wItemKind=IsLayoutControl,wItems=wItems}) clipRgn = do+			      (itemHs,clipRgn) <- createWElementsClipState wMetrics allClipStates validate wPtr clipRect1 defId True wItems clipRgn+			      return (itemH{wItems=itemHs},clipRgn)+			      where+				  clipRect1 = intersectRects (posSizeToRect (wItemPos itemH) (wItemSize itemH)) clipRect++			  createWItemClipState _ _ _ wPtr clipRect defId itemH@(WItemHandle {wItemKind=wItemKind,wItemPos=wItemPos,wItemSize=wItemSize}) clipRgn+				  | Just clipItem <- mb_item = do+					  itemRgn <- clipItem wPtr (0,0) clipRect (toTuple wItemPos) (toTuple wItemSize)+					  diffRgn <- osDiffRgn clipRgn itemRgn					  +					  osDisposeRgn clipRgn+					  osDisposeRgn itemRgn+					  return (itemH,diffRgn)+			  		  where+					    mb_item = case wItemKind of+						IsPopUpControl		-> Just osClipPopUpControl+						IsListBoxControl	-> Just osClipListBoxControl+						IsSliderControl		-> Just osClipSliderControl+						IsTextControl		-> Just osClipTextControl+						IsEditControl		-> Just osClipEditControl+						IsButtonControl		-> Just osClipButtonControl+						IsCustomButtonControl	-> Just osClipCustomButtonControl+						IsCustomControl		-> Just osClipCustomControl+						_			-> Nothing++			  createWItemClipState _ _ _ _ _ _ itemH clipRgn = return (itemH,clipRgn)++		  createWElementClipState wMetrics allClipStates validate wPtr clipRect defId isVisible (WListLSHandle itemHs) clipRgn = do+			  (itemHs1,clipRgn1) <- createWElementsClipState wMetrics allClipStates validate wPtr clipRect defId isVisible itemHs clipRgn+			  return (WListLSHandle itemHs1,clipRgn1)++		  createWElementClipState wMetrics allClipStates validate wPtr clipRect defId isVisible (WExtendLSHandle exLS itemHs) clipRgn = do+			  (itemHs1,clipRgn1) <- createWElementsClipState wMetrics allClipStates validate wPtr clipRect defId isVisible itemHs clipRgn+			  return (WExtendLSHandle exLS itemHs1,clipRgn1)++		  createWElementClipState wMetrics allClipStates validate wPtr clipRect defId isVisible (WChangeLSHandle chLS itemHs) clipRgn = do+			  (itemHs1,clipRgn1) <- createWElementsClipState wMetrics allClipStates validate wPtr clipRect defId isVisible itemHs clipRgn+			  return (WChangeLSHandle chLS itemHs1,clipRgn1)+	+	    createWElementsClipState _ _ _ _ _ _ _ itemHs clipRgn =+		return (itemHs,clipRgn)+++disposeClipState :: ClipState -> IO ()+disposeClipState (ClipState{clipRgn=clipRgn})+	| clipRgn==nullPtr = return ()+	| otherwise        = osDisposeRgn clipRgn+++{-	validateAllClipStates(`) validate wPtr defaultId isVisible items+		checks for all items if the ClipState of CompoundControls is valid.+		If validate holds, then the ClipState is checked, otherwise the ClipState is disposed and recalculated(!!).+-}+validateAllClipStates :: OSWindowMetrics -> Bool -> OSWindowPtr -> Maybe Id -> Bool -> [WElementHandle ls ps] -> IO [WElementHandle ls ps]+validateAllClipStates wMetrics validate wPtr defaultId isVisible itemHs =+    mapM (validateClipState wMetrics validate wPtr defaultId isVisible) itemHs+    where+	validateClipState :: OSWindowMetrics -> Bool -> OSWindowPtr -> Maybe Id -> Bool -> WElementHandle ls ps -> IO (WElementHandle ls ps)+	validateClipState wMetrics validate wPtr defaultId isVisible itemH@(WItemHandle {wItemKind=wItemKind})+	    | wItemKind /= IsCompoundControl =+		    if isRecursiveControl wItemKind then do		-- PA: added for LayoutControls+			itemHs <- mapM (validateClipState wMetrics validate wPtr defaultId itemVisible) (wItems itemH)+			return (itemH{wItems=itemHs})+		    else+			return itemH+	    | validate = validateCompoundClipState wMetrics True wPtr defaultId itemVisible itemH+	    | otherwise = forceValidCompoundClipState wMetrics True wPtr defaultId itemVisible itemH+	    where+		itemVisible			= isVisible && wItemShow itemH+	+	validateClipState wMetrics validate wPtr defaultId isVisible (WListLSHandle itemHs) = do+		itemHs <- mapM (validateClipState wMetrics validate wPtr defaultId isVisible) itemHs+		return (WListLSHandle itemHs)++	validateClipState wMetrics validate wPtr defaultId isVisible (WExtendLSHandle exLS itemHs) = do+		itemHs <- mapM (validateClipState wMetrics validate wPtr defaultId isVisible) itemHs+		return (WExtendLSHandle exLS itemHs)++	validateClipState wMetrics validate wPtr defaultId isVisible (WChangeLSHandle chLS itemHs) = do+		itemHs <- mapM (validateClipState wMetrics validate wPtr defaultId isVisible) itemHs+		return (WChangeLSHandle chLS itemHs)+++validateWindowClipState :: OSWindowMetrics -> Bool -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+validateWindowClipState wMetrics allClipStates wPtr wH@(WindowHandle {whKind=whKind,whWindowInfo=windowInfo,whItems=whItems,whSize=whSize,whDefaultId=whDefaultId,whShow=whShow})+	| whKind==IsDialog =+		if not allClipStates then return wH+		else do+		  itemHs <- validateAllClipStates wMetrics True wPtr whDefaultId whShow whItems+		  return (wH{whItems=itemHs})+	| clipOk clipState =+		if not allClipStates then return wH+		else do+		  itemHs <- validateAllClipStates wMetrics True wPtr whDefaultId whShow whItems+		  return (wH{whItems=itemHs})+	| otherwise = do		+		disposeClipState clipState+		(newClipState,itemHs) <- createClipState wMetrics allClipStates True wPtr contentRect whDefaultId whShow whItems		+		return (wH{whItems=itemHs,whWindowInfo=windowInfo{windowClip=newClipState}})+	where+	  clipState	= windowClip windowInfo+	  domainRect	= windowDomain windowInfo+	  hasScrolls	= (isJust (windowHScroll windowInfo), isJust (windowVScroll windowInfo))+	  visScrolls	= osScrollbarsAreVisible wMetrics domainRect (toTuple whSize) hasScrolls+	  contentRect	= getWindowContentRect wMetrics visScrolls (sizeToRect whSize)++forceValidWindowClipState :: OSWindowMetrics -> Bool -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+forceValidWindowClipState wMetrics allClipStates wPtr wH@(WindowHandle {whKind=whKind,whWindowInfo=windowInfo,whItems=whItems,whSize=whSize,whDefaultId=whDefaultId,whShow=whShow})+	| whKind == IsDialog =+		if not allClipStates then return wH+		else do+		  itemHs <- validateAllClipStates wMetrics False wPtr whDefaultId whShow whItems+		  return (wH{whItems=itemHs})+	| otherwise = do		+		disposeClipState (windowClip windowInfo)+		(clipState,itemHs) <- createClipState wMetrics allClipStates False wPtr contentRect whDefaultId whShow whItems		+		return (wH{whItems=itemHs,whWindowInfo=windowInfo{windowClip=clipState}})+	where+	  domainRect	= windowDomain windowInfo+	  hasScrolls	= (isJust (windowHScroll windowInfo), isJust (windowVScroll windowInfo))+	  visScrolls	= osScrollbarsAreVisible wMetrics domainRect (toTuple whSize) hasScrolls+	  contentRect	= getWindowContentRect wMetrics visScrolls (sizeToRect whSize)++invalidateWindowClipState :: WindowHandle ls ps -> WindowHandle ls ps+invalidateWindowClipState wH@(WindowHandle {whKind=whKind,whWindowInfo=windowInfo})+	| whKind==IsWindow =+		let clipState  = windowClip windowInfo+		in wH{whWindowInfo=windowInfo {windowClip=clipState{clipOk=False}}}+	| otherwise = wH++validateCompoundClipState :: OSWindowMetrics -> Bool -> OSWindowPtr -> Maybe Id -> Bool -> WElementHandle ls ps -> IO (WElementHandle ls ps)+validateCompoundClipState wMetrics allClipStates wPtr defId isVisible itemH@(WItemHandle {wItemShow=wItemShow,wItemPos=wItemPos,wItemSize=wItemSize,wItemInfo=wItemInfo,wItems=wItems})+	| clipOk clipState =+		if not allClipStates then return itemH+		else do+		   itemHs <- validateAllClipStates wMetrics True wPtr defId itemVisible wItems+		   return (itemH{wItems=itemHs})+	| otherwise = do		+		disposeClipState clipState+		(newClipState,itemHs) <- createClipState wMetrics allClipStates True wPtr contentRect defId itemVisible wItems		+		let compoundInfo1 = compoundInfo{compoundLookInfo=compoundLook{compoundClip=newClipState}}+		return (itemH{wItemInfo=WCompoundInfo compoundInfo1,wItems=itemHs})+	where+	  itemVisible		= isVisible && wItemShow+	  compoundInfo		= getWItemCompoundInfo wItemInfo+	  compoundLook		= compoundLookInfo compoundInfo+	  clipState		= compoundClip compoundLook+	  domainRect		= compoundDomain compoundInfo+	  hasScrolls		= (isJust (compoundHScroll compoundInfo), isJust (compoundVScroll compoundInfo))+	  visScrolls		= osScrollbarsAreVisible wMetrics domainRect (toTuple wItemSize) hasScrolls+	  contentRect		= getCompoundContentRect wMetrics visScrolls (posSizeToRect wItemPos wItemSize)++forceValidCompoundClipState :: OSWindowMetrics -> Bool -> OSWindowPtr -> Maybe Id -> Bool -> WElementHandle ls ps -> IO (WElementHandle ls ps)+forceValidCompoundClipState wMetrics allClipStates wPtr defId isVisible itemH@(WItemHandle {wItemShow=wItemShow,wItemPos=wItemPos,wItemSize=wItemSize,wItemInfo=wItemInfo,wItems=wItems}) = do	+	disposeClipState (compoundClip compoundLook)+	(clipState,itemHs) <- createClipState wMetrics allClipStates False wPtr contentRect defId itemVisible wItems	+	let compoundInfo1 = compoundInfo{compoundLookInfo=compoundLook{compoundClip=clipState}}+	return (itemH{wItemInfo=WCompoundInfo compoundInfo1,wItems=itemHs})+	where+	  itemVisible		= isVisible && wItemShow+	  compoundInfo		= getWItemCompoundInfo wItemInfo+	  compoundLook		= compoundLookInfo compoundInfo	  +	  domainRect		= compoundDomain compoundInfo+	  hasScrolls		= (isJust (compoundHScroll compoundInfo), isJust (compoundVScroll compoundInfo))+	  visScrolls		= osScrollbarsAreVisible wMetrics domainRect (toTuple wItemSize) hasScrolls+	  contentRect		= getCompoundContentRect wMetrics visScrolls (posSizeToRect wItemPos wItemSize)++invalidateCompoundClipState :: WElementHandle ls ps -> WElementHandle ls ps+invalidateCompoundClipState itemH@(WItemHandle {wItemInfo=wItemInfo}) =+	let compoundInfo = getWItemCompoundInfo wItemInfo+	    compoundLook = compoundLookInfo compoundInfo+	    clipState	 = compoundClip compoundLook+	in (itemH{wItemInfo=WCompoundInfo compoundInfo{compoundLookInfo=compoundLook{compoundClip=clipState{clipOk=False}}}})
+ Graphics/UI/ObjectIO/Window/Controls.hs view
@@ -0,0 +1,411 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Window.Controls+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Window.Controls+		( opencontrols,  opencompoundcontrols+		, closecontrols, closeallcontrols+		, setcontrolpositions+		) where++++import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.Control.Create+import	Graphics.UI.ObjectIO.Control.Layout(layoutControls)+import	Graphics.UI.ObjectIO.Control.Relayout(relayoutControls)+import	Graphics.UI.ObjectIO.StdControlAttribute(isControlPos)+import	Graphics.UI.ObjectIO.Window.ClipState+import	Graphics.UI.ObjectIO.Window.Access(identifyMaybeId, genWElementItemNrs, getWindowContentRect,+					   getWindowHMargins, getWindowVMargins, getWindowItemSpaces)+import	Graphics.UI.ObjectIO.Window.Dispose(disposeWElementHandle)+import	Graphics.UI.ObjectIO.Window.Draw(drawWindowLook)+import	Graphics.UI.ObjectIO.Window.Update(updateWindowBackgrounds)+import	Graphics.UI.ObjectIO.Window.ClipState(invalidateWindowClipState)+import	Graphics.UI.ObjectIO.Window.Handle+import	Graphics.UI.ObjectIO.OS.DocumentInterface+import	Graphics.UI.ObjectIO.OS.Window+++windowControlsFatalError :: String -> String -> x+windowControlsFatalError function error = dumpFatalError function "WindowControls" error+++--	Auxiliary functions:++{-	opencontrols adds the given controls to the window. +	It is assumed that the new controls do not conflict with the current controls.+-}+opencontrols :: OSWindowMetrics -> ls -> [WElementHandle ls ps] -> WindowStateHandle ps -> IO (WindowStateHandle ps)+opencontrols wMetrics ls newItems wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH@(WindowHandle {whItems=curItems,whSize=winSize})}))) =+	let+		(itemNrs1,newItems1) 	= genWElementItemNrs itemNrs newItems+		newItems2 		= [WChangeLSHandle ls newItems1]+		allItems		= curItems++newItems2+		visScrolls		= osScrollbarsAreVisible wMetrics domainRect (toTuple winSize) (hasHScroll,hasVScroll)+		Rect{rright=curw,rbottom=curh} = getWindowContentRect wMetrics visScrolls (sizeToRect winSize)+		hMargins		= getWindowHMargins   winKind wMetrics atts+		vMargins		= getWindowVMargins   winKind wMetrics atts+		spaces			= getWindowItemSpaces winKind wMetrics atts+		reqSize			= Size{w=curw-fst hMargins-snd hMargins,h=curh-fst vMargins-snd vMargins}+	in do+		(_,allItems) <- layoutControls wMetrics hMargins vMargins spaces reqSize zero [(domain,origin)] allItems+		let (updCurItems,updNewItems)	= split (length curItems) allItems+		newItems <- createControls wMetrics defaultId cancelId select winPtr newItems+		let updAllItems = updCurItems++updNewItems+		let wH1 = wH{whItemNrs=itemNrs1,whItems=updAllItems}+		let wH2 = invalidateWindowClipState wH1+		return (WindowStateHandle wids (Just wlsH{wlsHandle=wH}))+	where+		winPtr		= wPtr wids+		atts		= whAtts wH+		defaultId	= whDefaultId wH+		cancelId	= whCancelId wH+		select		= whSelect wH+		itemNrs		= whItemNrs wH+		winKind		= whKind wH+		info		= whWindowInfo wH+		(origin,hasHScroll,hasVScroll,domainRect) = case info of+			info@(WindowInfo {}) -> (windowOrigin info,isJust (windowHScroll info),isJust (windowVScroll info),windowDomain info)+			NoWindowInfo         -> (zero,             False,                      False,                      sizeToRect winSize)+		domain		= rectToRectangle domainRect+opencontrols _ _ _ _ = windowControlsFatalError "opencontrols" "unexpected window placeholder argument"+++{-	opencompoundcontrols adds the given controls to the compound control of the given window. +	It is assumed that the new controls do not conflict with the current controls.+-}+opencompoundcontrols :: OSDInfo -> OSWindowMetrics -> Id -> ls -> [WElementHandle ls ps] -> WindowStateHandle ps -> IO (Bool,WindowStateHandle ps)+opencompoundcontrols osdInfo wMetrics compoundId ls newItems wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH@(WindowHandle {whItems=itemHs})}))) =+	let (found,nrSkip,_,_,itemNrs1,oldItemHs) = addControlsToCompound compoundId ls newItems itemNrs itemHs+	in if not found then return (False,WindowStateHandle wids (Just wlsH{wlsHandle=wH{whItems=oldItemHs}}))+	   else let+	   		curSize@(Size {w=curw,h=curh}) = Size{w=w winSize-(if visVScroll then osmVSliderWidth wMetrics else 0),h=h winSize-(if visHScroll then osmHSliderHeight wMetrics else 0)}+		  	wFrame	= sizeToRect curSize+		  	hMargins = getWindowHMargins winKind wMetrics atts+		  	vMargins = getWindowVMargins winKind wMetrics atts+		  	spaces	= getWindowItemSpaces winKind wMetrics atts+		  	reqSize	= Size{w=curw-fst hMargins-snd hMargins,h=curh-fst vMargins-snd vMargins}+		in do+			(derSize,newItemHs) <- layoutControls wMetrics hMargins vMargins spaces reqSize zero [(domain,origin)] oldItemHs+			newItemHs <- createCompoundControls wMetrics compoundId nrSkip defaultId cancelId select winPtr newItemHs+		  	let wH1 = wH{whItemNrs=itemNrs,whItems=newItemHs}+			wH2 <- forceValidWindowClipState wMetrics True winPtr wH1+			updRgn <- relayoutControls wMetrics select show wFrame wFrame zero zero winPtr defaultId oldItemHs (whItems wH2)+			wH3 <- updateWindowBackgrounds wMetrics updRgn wids wH2+			return (True,WindowStateHandle wids (Just wlsH{wlsHandle=wH}))+	where+		winPtr		= wPtr wids+		atts		= whAtts wH+		defaultId	= whDefaultId wH+		cancelId	= whCancelId wH+		select		= whSelect wH+		show		= whShow wH+		itemNrs		= whItemNrs wH+		winKind		= whKind wH+		winSize		= whSize wH+		domain		= rectToRectangle domainRect+		(origin,domainRect,hasHScroll,hasVScroll) = case whWindowInfo wH of+			info@(WindowInfo {}) -> (windowOrigin info,windowDomain info,isJust (windowHScroll info),isJust (windowVScroll info))+			NoWindowInfo         -> (zero,             sizeToRect winSize,False,False)+		(visHScroll,visVScroll)	 = osScrollbarsAreVisible wMetrics domainRect (toTuple winSize) (hasHScroll,hasVScroll)++		addControlsToCompound :: Id -> ls1 -> [WElementHandle ls1 ps] -> [Int] -> [WElementHandle ls ps] -> (Bool,Int,ls1,[WElementHandle ls1 ps],[Int],[WElementHandle ls ps])+		addControlsToCompound compoundId ls newItems itemNrs [] = (False,0,ls,newItems,itemNrs,[])+		addControlsToCompound compoundId ls newItems itemNrs (itemH:itemHs) =+			let (found,nrSkip,ls1,newItems1,itemNrs1,itemH1) = addControlsToCompound' compoundId ls newItems itemNrs itemH+			in if found then (found,nrSkip,ls1,newItems1,itemNrs1,itemH1:itemHs)+			   else let (found,nrSkip,ls2,newItems2,itemNrs2,itemHs1) = addControlsToCompound compoundId ls1 newItems1 itemNrs1 itemHs+				in (found,nrSkip,ls2,newItems2,itemNrs2,itemH1:itemHs1)+			where+				addControlsToCompound' :: Id -> ls1 -> [WElementHandle ls1 ps] -> [Int] -> WElementHandle ls ps -> (Bool,Int,ls1,[WElementHandle ls1 ps],[Int], WElementHandle ls ps)+				addControlsToCompound' compoundId ls newItems itemNrs itemH@(WItemHandle {wItemKind=itemKind,wItemId=itemId,wItems=itemHs})+					| not (isRecursiveControl itemKind) =+						(False,0,ls,newItems,itemNrs,itemH)+					| itemKind==IsLayoutControl =+						let (found,nrSkip,ls1,newItems1,itemNrs1,itemHs1) = addControlsToCompound compoundId ls newItems itemNrs itemHs+						in (found,nrSkip,ls1,newItems1,itemNrs1,itemH{wItems=itemHs1})+					| not (identifyMaybeId compoundId itemId) =+						let+							(found,nrSkip,ls1,newItems1,itemNrs1,itemHs1) = addControlsToCompound compoundId ls newItems itemNrs itemHs+							itemH1 = itemH{wItems=itemHs1}+							itemH2 = if found then invalidateCompoundClipState itemH1 else itemH1+						in+							(found,nrSkip,ls1,newItems1,itemNrs1,itemH2)+					| otherwise =+						let+							nrSkip 			= length itemHs+							(itemNrs1,newItems1) 	= genWElementItemNrs itemNrs newItems+							newItems2		= [WChangeLSHandle ls newItems1]+							itemH1			= itemH{wItems=itemHs++newItems2}+							itemH2			= invalidateCompoundClipState itemH1+						in+							(True,nrSkip,undefined,[],itemNrs,itemH2)++				addControlsToCompound' compoundId ls newItems itemNrs (WListLSHandle itemHs) =+					let (found,nrSkip,ls1,newItems1,itemNrs1,itemHs1) = addControlsToCompound compoundId ls newItems itemNrs itemHs+					in (found,nrSkip,ls1,newItems1,itemNrs1,WListLSHandle itemHs1)++				addControlsToCompound' compoundId ls newItems itemNrs (WExtendLSHandle exLS itemHs) =+					let (found,nrSkip,ls1,newItems1,itemNrs1,itemHs1) = addControlsToCompound compoundId ls newItems itemNrs itemHs+					in (found,nrSkip,ls1,newItems1,itemNrs1,WExtendLSHandle exLS itemHs1)++				addControlsToCompound' compoundId ls newItems itemNrs (WChangeLSHandle chLS itemHs) =+					let (found,nrSkip,ls1,newItems1,itemNrs1,itemHs1) = addControlsToCompound compoundId ls newItems itemNrs itemHs+					in (found,nrSkip,ls1,newItems1,itemNrs1,WChangeLSHandle chLS itemHs1)+opencompoundcontrols _ _ _ _ _ _+	= windowControlsFatalError "opencompoundcontrols" "unexpected window placeholder argument"+++{-	closecontrols closes the indicated controls and returns their R(2)Ids (first result [Id]) and+	Ids (second result [Id]) if appropriate.+	When closecontrols returns, the indicated controls will have been hidden. To actually dispose of them,+	the return (IdFun *OSToolbox) function should be applied.+-}+closecontrols :: OSWindowMetrics -> [Id] -> Bool -> WindowStateHandle ps -> IO ([Id],IO (),WindowStateHandle ps)+closecontrols wMetrics closeIds relayout (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH@(WindowHandle {whItems=curItems})}))) = do+	(freeIds,disposeFun,_,itemNrs,oldItemHs) <- closeWElementHandles winPtr closeIds itemNrs curItems+	(if not relayout+	 then let wH1 = invalidateWindowClipState wH{whItemNrs=itemNrs,whItems=oldItemHs}+	      in return (freeIds,disposeFun,WindowStateHandle wids (Just wlsH{wlsHandle=wH1}))+	 else let+		curw = w winSize-(if visVScroll then osmVSliderWidth  wMetrics else 0)+		curh = h winSize-(if visHScroll then osmHSliderHeight wMetrics else 0)+		wFrame = sizeToRect (Size{w=curw,h=curh})+		hMargins = getWindowHMargins   winKind wMetrics atts+		vMargins = getWindowVMargins   winKind wMetrics atts+		spaces	 = getWindowItemSpaces winKind wMetrics atts+		reqSize	 = Size{w=curw-fst hMargins-snd hMargins,h=curh-fst vMargins-snd vMargins}+	     in do+		(_,newItemHs) <- layoutControls wMetrics hMargins vMargins spaces reqSize zero [(domain,origin)] oldItemHs+		let wH1 = wH{whItemNrs=itemNrs, whItems=newItemHs}+		wH2 <- forceValidWindowClipState wMetrics True winPtr wH1+		updRgn <- relayoutControls wMetrics select show wFrame wFrame zero zero winPtr defaultId oldItemHs (whItems wH2)+		wH3 <- updateWindowBackgrounds wMetrics updRgn wids wH2+		return (freeIds,disposeFun,WindowStateHandle wids (Just wlsH{wlsHandle=wH})))+	where+		winPtr		= wPtr wids+		itemNrs		= whItemNrs wH+		atts		= whAtts wH+		winKind		= whKind wH+		winSize		= whSize wH+		select		= whSelect wH+		show		= whShow wH+		defaultId	= whDefaultId wH+		domain		= rectToRectangle domainRect+		(origin,domainRect,hasHScroll,hasVScroll) = case whWindowInfo wH of+			info@(WindowInfo {}) -> (windowOrigin info,windowDomain info,isJust (windowHScroll info),isJust (windowVScroll info))+			NoWindowInfo         -> (zero,             sizeToRect winSize,False,False)+		(visHScroll,visVScroll)	= osScrollbarsAreVisible wMetrics domainRect (toTuple winSize) (hasHScroll,hasVScroll)++		closeWElementHandles :: OSWindowPtr -> [Id] -> [Int] -> [WElementHandle ls ps] -> IO ([Id],IO (),[Id],[Int],[WElementHandle ls ps])+		closeWElementHandles parentPtr ids itemNrs [] = return ([],return (),ids,itemNrs,[])+		closeWElementHandles parentPtr ids itemNrs (itemH:itemHs)+			| null ids = return ([],return (),ids,itemNrs,itemHs)+			| otherwise = do+				(close,freeIds1,f1,ids,itemNrs,itemH ) <- closeWElementHandle  parentPtr ids itemNrs itemH+				(      freeIds2,f2,ids,itemNrs,itemHs) <- closeWElementHandles parentPtr ids itemNrs itemHs			  	+			  	let freeIds  = freeIds1 ++freeIds2+				return (freeIds,f1 >> f2,ids,itemNrs, if close then itemHs else itemH:itemHs)+			where+				closeWElementHandle :: OSWindowPtr -> [Id] -> [Int] -> WElementHandle ls ps -> IO (Bool,[Id],IO (),[Id],[Int],WElementHandle ls ps)+				closeWElementHandle parentPtr ids itemNrs itemH@(WItemHandle {wItemKind=itemKind,wItems=itemHs}) =+					let (close,ids) = case wItemId itemH of+						Just id	-> removeCheck id ids+						_	-> (False,ids)+					in if isRecursiveControl itemKind+					   then do+						(freeIds,f1,ids,itemNrs,itemHs) <- closeWElementHandles parentPtr ids itemNrs itemHs+						let itemH1 = itemH{wItems=itemHs}+						(if not close+						 then let itemH2 = if itemKind==IsCompoundControl then invalidateCompoundClipState itemH1 else itemH1+						      in return (close,freeIds,f1,ids,itemNrs,itemH)+						 else do+							(freeIds1,f2) <- disposeWElementHandle parentPtr itemH+							osInvalidateWindowRect parentPtr (posSizeToRect (wItemPos itemH) (wItemSize itemH))+							return (close,freeIds1++freeIds,f1 >> f2,ids,itemNrs,itemH))+					   else+						if not close+						then return (close,[],return (),ids,itemNrs,itemH)+						else do+							(freeIds,f) <- disposeWElementHandle parentPtr itemH+							osInvalidateWindowRect parentPtr (posSizeToRect (wItemPos itemH) (wItemSize itemH))+							return (close,freeIds,f,ids,wItemNr itemH:itemNrs,itemH)++				closeWElementHandle parentPtr ids itemNrs (WListLSHandle itemHs) = do+					(freeIds,f,ids,itemNrs,itemHs)	<- closeWElementHandles parentPtr ids itemNrs itemHs+					return (null itemHs,freeIds,f,ids,itemNrs,WListLSHandle itemHs)++				closeWElementHandle parentPtr ids itemNrs (WExtendLSHandle exLS itemHs) = do+					(freeIds,f,ids,itemNrs,itemHs)	<- closeWElementHandles parentPtr ids itemNrs itemHs+					return (null itemHs,freeIds,f,ids,itemNrs,WExtendLSHandle exLS itemHs)++				closeWElementHandle parentPtr ids itemNrs (WChangeLSHandle chLS itemHs) = do+					(freeIds,f,ids,itemNrs,itemHs)	<- closeWElementHandles parentPtr ids itemNrs itemHs+					return (null itemHs,freeIds,f,ids,itemNrs,WChangeLSHandle chLS itemHs)+closecontrols _ _ _ _ = windowControlsFatalError "closecontrols" "unexpected window placeholder argument"+++{-	closeallcontrols closes all controls and returns their R(2)Ids (first result [Id]) and Ids (second result [Id]).+	When closeallcontrols returns, the indicated controls will have been hidden. To actually dispose of them,+	the return (IdFun *OSToolbox) function should be applied.+-}+closeallcontrols :: WindowStateHandle ps -> IO ([Id],IO (),WindowStateHandle ps)+closeallcontrols (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH@(WindowHandle {whItems=curItems,whItemNrs=itemNrs})}))) = do+	(freeIds,disposeFun,itemNrs) <- closeWElementHandles (wPtr wids) curItems itemNrs+	let wH1 = invalidateWindowClipState wH{whItemNrs=itemNrs,whItems=[]}+	return (freeIds,disposeFun,WindowStateHandle wids (Just wlsH{wlsHandle=wH1}))+	where+		closeWElementHandles :: OSWindowPtr -> [WElementHandle ls ps] -> [Int] -> IO ([Id],IO (),[Int])+		closeWElementHandles parentPtr [] itemNrs = return ([],return (),itemNrs)+		closeWElementHandles parentPtr (itemH:itemHs) itemNrs = do+			(freeIds1,f1,itemNrs) <- closeWElementHandle  parentPtr itemH  itemNrs+			(freeIds2,f2,itemNrs) <- closeWElementHandles parentPtr itemHs itemNrs+			return (freeIds1++freeIds2,f1 >> f2,itemNrs)+			where+				closeWElementHandle :: OSWindowPtr -> WElementHandle ls ps -> [Int] -> IO ([Id],IO (),[Int])+				closeWElementHandle parentPtr itemH@(WItemHandle {wItemKind=itemKind,wItems=itemHs}) itemNrs+					| isRecursiveControl itemKind = do+						(freeIds1,f1,itemNrs) <- closeWElementHandles parentPtr itemHs itemNrs+						(freeIds2,f2) <- disposeWElementHandle parentPtr itemH{wItems=[]}+						osInvalidateWindowRect parentPtr (posSizeToRect (wItemPos itemH) (wItemSize itemH))+						return (freeIds2++freeIds1,f1 >> f2,itemNrs)+					| otherwise = do+						(freeIds,f) <- disposeWElementHandle parentPtr itemH+						osInvalidateWindowRect parentPtr (posSizeToRect (wItemPos itemH) (wItemSize itemH))+						return (freeIds,f,wItemNr itemH:itemNrs)++				closeWElementHandle parentPtr (WListLSHandle itemHs) itemNrs =+					closeWElementHandles parentPtr itemHs itemNrs++				closeWElementHandle parentPtr (WExtendLSHandle exLS itemHs) itemNrs =+					closeWElementHandles parentPtr itemHs itemNrs++				closeWElementHandle parentPtr (WChangeLSHandle chLS itemHs) itemNrs =+					closeWElementHandles parentPtr itemHs itemNrs+closeallcontrols _ = windowControlsFatalError "closeallcontrols" "unexpected window placeholder argument"+++{-	setcontrolpositions changes the position of the indicated controls.+	It is assumed that the argument WindowStateHandle is either a Window or a Dialog. +-}+setcontrolpositions :: OSWindowMetrics -> [(Id,ItemPos)] -> WindowStateHandle ps -> IO (Bool,WindowStateHandle ps)+setcontrolpositions wMetrics newPoss wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH@(WindowHandle {whItems=oldItems})})))+	| not (validateNewItemPoss newPoss oldItems) = return (False,wsH)+	| otherwise =+		let+			curw = w winSize-(if visVScroll then osmVSliderWidth  wMetrics else 0)+			curh = h winSize-(if visHScroll then osmHSliderHeight wMetrics else 0)+		  	wFrame = sizeToRect (Size{w=curw,h=curh})+		  	hMargins = getWindowHMargins winKind wMetrics atts+		  	vMargins = getWindowVMargins winKind wMetrics atts+		  	spaces = getWindowItemSpaces winKind wMetrics atts+		  	reqSize	= Size{w=curw-fst hMargins-snd hMargins,h=curh-fst vMargins-snd vMargins}+		  	(_,newItems) = setNewItemPoss newPoss oldItems+		  in do+		  	(_,newItems) <- layoutControls wMetrics hMargins vMargins spaces reqSize zero [(domain,origin)] newItems+		  	let wH1 = wH{whItems=newItems}+			wH2 <- forceValidWindowClipState wMetrics True winPtr wH1+		  	let viewFrame = posSizeToRectangle origin (Size{w=curw,h=curh})+		  	let updState = rectangleToUpdateState viewFrame+		  	let drawbackground = if winKind==IsDialog then return else drawWindowLook wMetrics winPtr (return ()) updState+			wH3 <- drawbackground wH2+			updRgn <- relayoutControls wMetrics select show wFrame wFrame zero zero winPtr defaultId oldItems (whItems wH3)+			wH4 <- updateWindowBackgrounds wMetrics updRgn wids wH3+			osValidateWindowRect winPtr (sizeToRect winSize)+		  	return (True,WindowStateHandle wids (Just wlsH{wlsHandle=wH4}))+	where+		winPtr		= wPtr wids+		atts		= whAtts wH+		winKind		= whKind wH+		winSize		= whSize wH+		select		= whSelect wH+		show		= whShow wH+		defaultId	= whDefaultId wH+		domain		= rectToRectangle domainRect+		(origin,domainRect,hasHScroll,hasVScroll) = case whWindowInfo wH of+			info@(WindowInfo {}) -> (windowOrigin info,windowDomain info,isJust (windowHScroll info),isJust (windowVScroll info))+			NoWindowInfo         -> (zero,             sizeToRect winSize,False,False)+		(visHScroll,visVScroll)	= osScrollbarsAreVisible wMetrics domainRect (toTuple winSize) (hasHScroll,hasVScroll)++		validateNewItemPoss :: [(Id,ItemPos)] -> [WElementHandle ls ps] -> Bool+		validateNewItemPoss idPoss itemHs = null (controlsExist (getids idPoss) itemHs)+			where+				getids :: [(Id,ItemPos)] -> [Id]+				getids ((controlId,(itemLoc,_)):idPoss) = case itemLoc of+					LeftOf	id	-> id:ids+					RightTo	id	-> id:ids+					Above	id	-> id:ids+					Below	id	-> id:ids+					_		-> ids+					where+						ids	= controlId:getids idPoss+				getids _ = []++				controlsExist :: [Id] -> [WElementHandle ls ps] -> [Id]+				controlsExist ids [] = ids+				controlsExist ids (itemH:itemHs)+					| null ids  = []+					| otherwise = controlsExist (controlsExist' ids itemH) itemHs+					where+						controlsExist' :: [Id] -> WElementHandle ls ps -> [Id]+						controlsExist' ids (WItemHandle {wItemId=wItemId,wItems=itemHs}) =+							controlsExist (if isJust wItemId then filter ((==) (fromJust wItemId)) ids else ids) itemHs+						controlsExist' ids (WListLSHandle itemHs) = controlsExist ids itemHs+						controlsExist' ids (WExtendLSHandle exLS itemHs) = controlsExist ids itemHs+						controlsExist' ids (WChangeLSHandle chLS itemHs) = controlsExist ids itemHs++		setNewItemPoss :: [(Id,ItemPos)] -> [WElementHandle ls ps] -> ([(Id,ItemPos)],[WElementHandle ls ps])+		setNewItemPoss idPoss [] = (idPoss,[])+		setNewItemPoss idPoss (itemH:itemHs)+			| null idPoss = (idPoss,itemH:itemHs)+			| otherwise =+				let+				  	(idPoss1,itemH1)  = setNewItemPos' idPoss  itemH+				  	(idPoss2,itemHs1) = setNewItemPoss idPoss1 itemHs+				in+					(idPoss2,itemH1:itemHs1)+			where+				setNewItemPos' :: [(Id,ItemPos)] -> WElementHandle ls ps -> ([(Id,ItemPos)],WElementHandle ls ps)+				setNewItemPos' idPoss itemH@(WItemHandle {wItemKind=itemKind,wItemAtts=atts,wItems=itemHs}) =+					case wItemId itemH of+						Nothing ->+							if isRecursiveControl itemKind+							then let (idPoss1,itemHs1) = setNewItemPoss idPoss itemHs+							     in (idPoss1,itemH{wItems=itemHs1})+							else (idPoss,itemH)+						Just itemId ->+							let+								(found,idPos1,idPoss1) = remove ((==) itemId . fst) undefined idPoss+					  			itemH1 = itemH{wItemAtts=if found then snd (creplace isControlPos (ControlPos (snd idPos1)) atts) else atts}+					  		in+								if isRecursiveControl itemKind+								then let+									(idPoss2,itemHs1) = setNewItemPoss idPoss1 itemHs+						  			itemH2 = itemH1{wItems=itemHs1}+						  			itemH3 = if found && itemKind==IsCompoundControl then invalidateCompoundClipState itemH2 else itemH2+								     in (idPoss2,itemH3)+								else (idPoss1,itemH1)++				setNewItemPos' idPoss (WListLSHandle itemHs) =+					let (idPoss1,itemHs1) = setNewItemPoss idPoss itemHs+					in (idPoss1,WListLSHandle itemHs1)++				setNewItemPos' idPoss (WExtendLSHandle exLS itemHs) =+					let (idPoss1,itemHs1) = setNewItemPoss idPoss itemHs+					in (idPoss1,WExtendLSHandle exLS itemHs1)++				setNewItemPos' idPoss (WChangeLSHandle chLS itemHs) =+					let (idPoss1,itemHs1) = setNewItemPoss idPoss itemHs+					in (idPoss1,WChangeLSHandle chLS itemHs1)++setcontrolpositions _ _ _ = windowControlsFatalError "setcontrolpositions" "unexpected window placeholder argument"
+ Graphics/UI/ObjectIO/Window/Create.hs view
@@ -0,0 +1,316 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Window.Create+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Window.Create contains the window creation functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Window.Create+		( openwindow+		, openModalWindow+		, bufferDelayedEvents+		, checkZeroWindowBound+		, decreaseWindowBound+		) where++++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Control.Create+import Graphics.UI.ObjectIO.Control.Pos(moveWindowViewFrame)+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.Process.Scheduler(handleContextOSEvent)+import Graphics.UI.ObjectIO.StdWindowAttribute+import Graphics.UI.ObjectIO.Window.Access+import Graphics.UI.ObjectIO.Window.Handle+import Graphics.UI.ObjectIO.Window.Validate+import Graphics.UI.ObjectIO.Window.Update(updateWindow)+import Graphics.UI.ObjectIO.OS.Event+import Graphics.UI.ObjectIO.OS.Window+import Control.Monad(unless)+import System.IO(fixIO)++++windowcreateFatalError :: String -> String -> x+windowcreateFatalError function error+    = dumpFatalError function "WindowCreate" error++++{-  Open a modal dialogue.  -}++openModalWindow :: Id -> WindowLSHandle ls ps -> ps -> GUI ps (ps, (Maybe ls))+openModalWindow wId (WindowLSHandle {wlsState=wlsState,wlsHandle=wH}) ps = do+    (found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+    					-- This condition should never occur: WindowDevice must have been 'installed'+    unless found (windowcreateFatalError "openModalWindow" "could not retrieve WindowSystemState from IOSt")+    let windows = windowSystemStateGetWindowHandles wDevice+    osdinfo <- accIOEnv ioStGetOSDInfo+    wMetrics <- accIOEnv ioStGetOSWindowMetrics+    (_,_,_,_,wH) <- liftIO (validateWindow wMetrics osdinfo wH windows)+    let title = whTitle wH+    let closable = any isWindowClose (whAtts wH)+    let wlsH            = WindowLSHandle{wlsState=wlsState,wlsHandle=wH}+    let wIds            = WIDS{wId=wId,wPtr=0,wActive=True}             -- wPtr=0 is assumed by system+    let wsH             = WindowStateHandle wIds (Just wlsH)+    let modalWIDS       = getWindowHandlesActiveModalDialog windows+    let windows1       	= addWindowHandlesActiveWindow wsH windows  -- frontmost position is assumed by system+    appIOEnv (ioStSetDevice (WindowSystemState windows1))+    inputTrack <- ioStGetInputTrack+    ioStSetInputTrack Nothing         	-- clear input track information+    (noError,ps1) <- liftContextIO (\context -> osCreateModalDialog closable title osdinfo (fmap wPtr modalWIDS) (handleOSEvent context)) ps+    let (delayMouse,delayKey) = case inputTrack of      -- after handling modal dialog, generate proper (Mouse/Key)Lost events+	    Nothing -> ([],[])+	    Just it@(InputTrack {itWindow=itWindow,itControl=itControl,itKind=itKind}) ->+		( if (itkMouse itKind)    then [createOSLooseMouseEvent itWindow (if itControl==0 then itWindow else itControl)] else []+		, if (itkKeyboard itKind) then [createOSLooseKeyEvent   itWindow (if itControl==0 then itWindow else itControl)] else []+		)    +    ioStAppendEvents (delayMouse++delayKey)+    finalLS <- getFinalModalDialogLS noError (toWID wId)+    unless noError (throwGUI (OtherError "could not create modal dialog"))+    return (ps, finalLS)+    where+	    handleOSEvent :: Context -> OSEvent -> IO [Int]+	    handleOSEvent context osEvent = handleContextOSEvent context (ScheduleOSEvent osEvent [])++{-  getFinalModalDialogLS retrieves the final local state of the modal dialog. This value has been stored in the window handles.+    This MUST have been done by disposeWindow (windowdispose). +-}+	    getFinalModalDialogLS :: Bool -> WID -> GUI ps (Maybe ls)+	    getFinalModalDialogLS False wid = return Nothing+	    getFinalModalDialogLS True  wid = do+		(found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+		unless found (windowcreateFatalError "getFinalModalDialogLS" "could not retrieve WindowSystemState from IOSt")+		let windows = windowSystemStateGetWindowHandles wDevice+		let (final,windows1) = getFinalLS wid windows+		appIOEnv (ioStSetDevice (WindowSystemState windows1))+		(case final of+			Nothing    -> windowcreateFatalError "getFinalModalDialogLS" "final local modal dialog state not found"+			Just final -> return (getFinalModalLS wid final))+		where+			getFinalLS :: WID -> WindowHandles ps -> (Maybe FinalModalLS,WindowHandles ps)+			getFinalLS wid windows@(WindowHandles {whsFinalModalLS=whsFinalModalLS}) =+			    let (removed,finalLS,finalLSs)    = remove (\(FinalModalLS wids _)->identifyWIDS wid wids) undefined whsFinalModalLS+			    in+				if not removed then (Nothing,windows)+				else (Just finalLS,windows{whsFinalModalLS=finalLSs})++            +{-  Open a modeless window/dialogue.  -}+openwindow :: Id -> WindowLSHandle ls ps -> ps -> GUI ps ps+openwindow wId (WindowLSHandle {wlsState=wlsState,wlsHandle=wH}) ps+    = do {+        (found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice);+        if  not found      -- This condition should never occur: WindowDevice must have been 'installed'+        then    windowcreateFatalError "openwindow" "could not retrieve WindowSystemState from IOSt"+        else+        let windows        = windowSystemStateGetWindowHandles wDevice+        in+        do {+            (delayinfo,wPtr,index,wH1) <- openAnyWindow wId wH windows;+            let+                (windowInit,wH2) = getWindowHandleInit wH1+                wIds       = WIDS {wId=wId,wPtr=wPtr,wActive=False}+            in+            do {+                ps1 <- toGUI (doInitIO (windowInit (wlsState,ps))+                                       (\ls ioState -> ioStSetDevice+                                                           (WindowSystemState+                                                                (addWindowHandlesWindow index +                                                                (WindowStateHandle wIds (Just (WindowLSHandle {wlsState=ls,wlsHandle=wH2})))+                                                                windows))+                                                           ioState));+                bufferDelayedEvents delayinfo;+                return ps1+            }+        };      +      }+    where+        doInitIO :: GUI ps (ls,ps) -> (ls -> IOSt ps -> IOSt ps) -> IOSt ps -> IO (ps,IOSt ps)+        doInitIO initGUI setWindowLS ioState+            = do {+                r <- fixIO (\st -> fromGUI initGUI (setWindowLS (fst (fst st)) ioState));+                let ((_,ps1),ioState1) = r+                in  return (ps1,ioState1)+              }+        +        getWindowHandleInit :: WindowHandle ls ps -> (GUIFun ls ps,WindowHandle ls ps)+        getWindowHandleInit wH+            = (getWindowInitFun (snd (cselect isWindowInit (WindowInit return) (whAtts wH))),wH)+    +    {-  openAnyWindow creates a window.+            After validating the window and its controls, the window and its controls are created.+            The return OSWindowPtr is the OSWindowPtr of the newly created window.+            The return Index is the proper insert position in the WindowHandles list.+    -}+        openAnyWindow :: Id -> WindowHandle ls ps -> WindowHandles ps+                      -> GUI ps ([DelayActivationInfo],OSWindowPtr,Index,WindowHandle ls ps)+        openAnyWindow wId wH windows+            = do {                +                osdinfo  <- accIOEnv ioStGetOSDInfo;+                wMetrics <- accIOEnv ioStGetOSWindowMetrics;+                (index,pos,size,originv,wH1) <- liftIO (validateWindow wMetrics osdinfo wH windows);+                let behindPtr = getStackBehindWindow index windows+                in  do {+                    (delayinfo,wPtr,osdinfo1,wH2) <- liftIO (createAnyWindow wMetrics behindPtr wId pos size originv osdinfo wH1);+                --  wH3                           <- validateWindowClipState wMetrics True wPtr wH2;+                    appIOEnv (ioStSetOSDInfo osdinfo1);+                    liftIO (osInvalidateWindow wPtr);+                    return (delayinfo,wPtr,index,wH2)+                    }+              }++{-  In this implementation, Windows are not taken into account. +-}++createAnyWindow :: OSWindowMetrics -> OSWindowPtr -> Id -> Point2 -> Size -> Vector2 -> OSDInfo -> WindowHandle ls ps+                                                  -> IO ([DelayActivationInfo],OSWindowPtr,OSDInfo,WindowHandle ls ps)+createAnyWindow wMetrics behindPtr wId point' size' originv osdinfo wH+    | whKind wH==IsWindow = +        let+	    isResizable			= True+	    windowInfo			= whWindowInfo wH+	    viewDomain			= windowDomain windowInfo+	    viewOrigin			= windowOrigin windowInfo+	    hScroll			= windowHScroll windowInfo+	    vScroll			= windowVScroll windowInfo+	    visScrolls			= osScrollbarsAreVisible wMetrics viewDomain size (isJust hScroll,isJust vScroll)+	    Rect{rright=w',rbottom=h'}	= getWindowContentRect wMetrics visScrolls (sizeToRect size')+	    hInfo			= toScrollbarInfo hScroll (rleft viewDomain,x viewOrigin,rright  viewDomain, w')+	    vInfo			= toScrollbarInfo vScroll (rtop viewDomain, y viewOrigin,rbottom viewDomain, h')+	    minSize			= osMinWindowSize+	    maxSize			= rectSize viewDomain+	    (_,cursorAtt)		= cselect isWindowCursor (WindowCursor StandardCursor) (whAtts wH)++	    toScrollbarInfo :: Maybe ScrollInfo -> (Int,Int,Int,Int) -> ScrollbarInfo+	    toScrollbarInfo Nothing scrollState =+		ScrollbarInfo{cbiHasScroll=False,cbiPos=undefined,cbiSize=undefined,cbiState=undefined}+	    toScrollbarInfo (Just (ScrollInfo{scrollItemPos=scrollItemPos,scrollItemSize=scrollItemSize})) (min,origin,max,size) =+		ScrollbarInfo{cbiHasScroll=True,cbiPos=toTuple scrollItemPos,cbiSize=toTuple scrollItemSize,cbiState=osScrollState}+		where+		    osScrollState		= toOSscrollbarRange (min,origin,max) size++	    setScrollInfoPtr :: Maybe ScrollInfo -> OSWindowPtr -> Maybe ScrollInfo+	    setScrollInfoPtr (Just info) scrollPtr	= Just info{scrollItemPtr=scrollPtr}+            setScrollInfoPtr Nothing     _		= Nothing+        in do+	      (delay_info,wPtr,hPtr,vPtr,osdinfo,wH) <- osCreateWindow wMetrics isResizable hInfo vInfo minSize (toTuple maxSize)+										      isClosable (whTitle wH) pos size getInitActiveControl (createWindowControls wMetrics)+										       (updateWindowControl wMetrics wId size)+										      osdinfo behindPtr wH+	      let windowInfo1 = windowInfo{windowHScroll = setScrollInfoPtr hScroll hPtr+					  ,windowVScroll = setScrollInfoPtr vScroll vPtr}+		  wH1         = wH{whWindowInfo=windowInfo1}+	      wH2 <- moveWindowViewFrame wMetrics originv (WIDS{wPtr=wPtr,wId=wId,wActive=False}) wH1	-- PA: check WIDS value+	      delay_info' <- osShowWindow wPtr False+	      osSetWindowCursor wPtr (toCursorCode (getWindowCursorAtt cursorAtt))+	      return (delay_info++delay_info',wPtr,osdinfo,wH2)++    | whKind wH==IsDialog+        = do {+            (delay_info,wPtr,wH1) <- osCreateDialog (whMode wH == Modal) isClosable (whTitle wH) pos size behindPtr+                                                    getInitActiveControl+                                                    (createWindowControls wMetrics)+                                                    (updateWindowControl wMetrics wId size)+                                                    osdinfo wH;+            return (delay_info,wPtr,osdinfo,wH1)+          }+    where+        isClosable = any isWindowClose (whAtts wH)+        pos        = toTuple point'+        size       = toTuple size'+        +    --  createWindowControls creates the controls.+        createWindowControls :: OSWindowMetrics -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+        createWindowControls wMetrics wPtr wH = do+            itemHs <- createControls wMetrics Nothing Nothing (whSelect wH) wPtr (whItems wH)+            return wH{whItems=itemHs}+        +    --  updateWindowControl updates customised controls.+        updateWindowControl :: OSWindowMetrics -> Id -> (Int,Int) -> OSWindowPtr -> OSWindowPtr -> OSPictContext -> WindowHandle ls ps+                                                                                                                 -> IO (WindowHandle ls ps)+--        updateWindowControl wMetrics wId (w,h) wPtr cPtr osPict wH+--            = return wH            +            +					       +	updateWindowControl wMetrics wId (w,h) wPtr cPtr osPict wH@(WindowHandle {whItems=itemHs}) =+	    let +		(_,controls) = getUpdateControls cPtr (sizeToRect (Size{w=w,h=h})) itemHs+		wH1 = wH{whItems=itemHs}+		updateInfo = UpdateInfo{ updWIDS	= WIDS{wPtr=wPtr,wId=wId,wActive=False}	-- PA: check WIDS value+				       , updWindowArea	= zero+				       , updControls	= controls+				       , updGContext	= Just osPict+				       }+	    in updateWindow wMetrics updateInfo wH1+	    where+		getUpdateControls :: OSWindowPtr -> Rect -> [WElementHandle ls ps] -> (Bool,[ControlUpdateInfo])+		getUpdateControls cPtr clipRect (itemH:itemHs)			    +		    | found	= (found,controls)+		    | otherwise	= getUpdateControls cPtr clipRect itemHs+		    where+			(found,controls) = getUpdateControl cPtr clipRect itemH++			getUpdateControl :: OSWindowPtr -> Rect -> WElementHandle ls ps -> (Bool,[ControlUpdateInfo])+			getUpdateControl cPtr clipRect itemH@(WItemHandle {wItemPtr=wItemPtr})+			    | cPtr==wItemPtr = (True, [ControlUpdateInfo {cuItemNr=wItemNr itemH,cuItemPtr=wItemPtr,cuArea=clipRect1}])+			    | otherwise	 = getUpdateControls cPtr clipRect1 (wItems itemH)+			    where+				clipRect1 = intersectRects clipRect (posSizeToRect (wItemPos itemH) (wItemSize itemH))+			getUpdateControl cPtr clipRect (WListLSHandle itemHs) =+			    getUpdateControls cPtr clipRect itemHs+			getUpdateControl cPtr clipRect (WExtendLSHandle exLS itemHs) =+			    getUpdateControls cPtr clipRect itemHs+			getUpdateControl cPtr clipRect (WChangeLSHandle chLS itemHs) =+			    getUpdateControls cPtr clipRect itemHs+		getUpdateControls _ _ [] = (False,[])++getStackBehindWindow :: Index -> WindowHandles ps -> OSWindowPtr+getStackBehindWindow     0 wsHs = osNoWindowPtr+getStackBehindWindow index wsHs = wPtr (getWindowStateHandleWIDS wsH)+    where wsH = (whsWindows wsHs) !! (index-1)+        +++{-  bufferDelayedEvents buffers the events in the OSEvents environment. -}+bufferDelayedEvents :: [DelayActivationInfo] -> GUI ps ()+bufferDelayedEvents delayinfo = ioStAppendEvents (map toOSEvent delayinfo)+    where+        toOSEvent :: DelayActivationInfo -> SchedulerEvent+        toOSEvent (DelayActivatedWindow wPtr)+            = createOSActivateWindowEvent wPtr+        toOSEvent (DelayDeactivatedWindow wPtr)+            = createOSDeactivateWindowEvent wPtr+        toOSEvent (DelayActivatedControl wPtr cPtr)+            = createOSActivateControlEvent wPtr cPtr+        toOSEvent (DelayDeactivatedControl wPtr cPtr)+            = createOSDeactivateControlEvent wPtr cPtr+++{-  WindowBound-checks for normal windows. -}++checkZeroWindowBound :: IOSt ps -> Bool+checkZeroWindowBound ioState = found && checkZeroWindowHandlesBound wHs+    where+        (found,wDevice) = ioStGetDevice WindowDevice ioState+        wHs             = windowSystemStateGetWindowHandles wDevice++decreaseWindowBound :: IOSt ps -> IOSt ps+decreaseWindowBound ioState+    | not found+        = ioState+    | otherwise+        = ioStSetDevice (WindowSystemState wHs1) ioState+    where+        (found,wDevice) = ioStGetDevice WindowDevice ioState+        wHs             = windowSystemStateGetWindowHandles wDevice+        wHs1            = decreaseWindowHandlesBound wHs
+ Graphics/UI/ObjectIO/Window/Device.hs view
@@ -0,0 +1,1338 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Window.Device+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Window.Device defines the window device event handlers+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Window.Device+		( windowFunctions+		, windowStateSizeAction -- used from StdWindow.setWindowViewSize+		) where++++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Control.Create+import Graphics.UI.ObjectIO.Control.Draw(drawCompoundLook)+import Graphics.UI.ObjectIO.Control.Layout(layoutControls)+import Graphics.UI.ObjectIO.Control.Relayout(relayoutControls)+import Graphics.UI.ObjectIO.Control.Resize(resizeControls)+import Graphics.UI.ObjectIO.Device.Events+import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.StdControlAttribute+import Graphics.UI.ObjectIO.StdWindowAttribute+import Graphics.UI.ObjectIO.Window.Access+import Graphics.UI.ObjectIO.Window.ClipState (forceValidWindowClipState)+import Graphics.UI.ObjectIO.Window.Create (bufferDelayedEvents)+import Graphics.UI.ObjectIO.Window.Dispose+import Graphics.UI.ObjectIO.Window.Draw (drawWindowLook')+import Graphics.UI.ObjectIO.Window.Handle+import Graphics.UI.ObjectIO.Window.Update (updateWindow, updateWindowBackgrounds)+import Graphics.UI.ObjectIO.KeyFocus (setNewFocusItem, setNoFocusItem)+import Graphics.UI.ObjectIO.Receiver.Handle+import Graphics.UI.ObjectIO.OS.WindowEvent+import Graphics.UI.ObjectIO.OS.Window+import Graphics.UI.ObjectIO.OS.Event (createOSLooseMouseEvent, createOSLooseKeyEvent, createOSDeactivateControlEvent)+import Graphics.UI.ObjectIO.OS.Rgn (osGetRgnBox)+import Graphics.UI.ObjectIO.OS.Picture (Draw(..), pictScroll)+import System.IO(fixIO)+import Control.Monad(when)+import qualified Data.Map as Map++windowdeviceFatalError :: String -> String -> x+windowdeviceFatalError function error+	= dumpFatalError function "WindowDevice" error++checkErrorIO :: Bool -> String -> String -> GUI ps ()+checkErrorIO flag function error+	| flag 	    = return ()+	| otherwise = dumpFatalError function "WindowDevice" error++windowFunctions :: DeviceFunctions ps+windowFunctions+	= DeviceFunctions+		{ dDevice = WindowDevice+		, dShow	  = return+		, dHide	  = return+		, dEvent  = windowEvent+		, dDoIO   = windowIO+		, dOpen   = windowOpen+		, dClose  = windowClose+		}++{-	windowOpen initialises the window device for this interactive process.+-}+windowOpen :: ps -> GUI ps ps+windowOpen ps+	= do {+		hasWindow <- accIOEnv (ioStHasDevice WindowDevice);+		if   hasWindow+		then return ps+		else do {+			xDI <- accIOEnv ioStGetDocumentInterface;+			let bound   = case xDI of+			                NDI -> Finite 0+			                SDI -> Finite 1+			                MDI -> Infinite+			    windows = WindowHandles {whsWindows=[],whsNrWindowBound=bound, whsModal=False, whsFinalModalLS = []}+			in  appIOEnv ( ioStSetDevice (WindowSystemState windows) . ioStSetDeviceFunctions windowFunctions ) >> return ps+		     }+	  }+++{-	windowClose closes all windows associated with this interactive process.+	System resources are released.+	Note that the window device is not removed from the IOSt because there still might be+	a modal dialog which final state has to be retrieved.+-}+windowClose :: ps -> GUI ps ps+windowClose ps+	= do {	(found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice);+		if   not found+		then return ps+		else+		do+			osdinfo <- accIOEnv ioStGetOSDInfo+			let windows = windowSystemStateGetWindowHandles wDevice+			oldInputTrack <- ioStGetInputTrack+			(disposeInfo,(newInputTrack,ps1)) <- stateMapM (disposeWindowStateHandle' osdinfo) (whsWindows windows) (oldInputTrack, ps)+			ioStSetInputTrack newInputTrack+			let (freeIdss, _, finalLS) = unzip3 disposeInfo+			idtable <- ioStGetIdTable+			ioStSetIdTable (foldr Map.delete idtable (concat freeIdss))+			let windows1 = windows {whsWindows=[], whsFinalModalLS=(whsFinalModalLS windows)++(concat finalLS)}+			appIOEnv (ioStSetDevice (WindowSystemState windows1))+			return ps1+	  }+	  where+		disposeWindowStateHandle' :: OSDInfo -> WindowStateHandle ps -> (Maybe InputTrack, ps) -> GUI ps (([Id],[DelayActivationInfo],[FinalModalLS]),(Maybe InputTrack, ps))+		disposeWindowStateHandle' osdinfo wsH (inputTrack, ps) = do+			(a,b,c,inputTrack,ps) <- disposeWindowStateHandle osdinfo inputTrack wsH ps+			return ((a,b,c),(inputTrack,ps))++{-	windowIO handles the DeviceEvents that have been filtered by windowEvent.+	The only events that are handled in this implementation are:+		ControlKeyboardAction+		ControlSelection+		WindowActivation+		WindowDeactivation+		WindowInitialise+		WindowRequestClose+-}+windowIO :: DeviceEvent -> ps -> GUI ps ps+windowIO deviceEvent ps+	= do {+		hasDevice <- accIOEnv (ioStHasDevice WindowDevice);+		if   not hasDevice+		then windowdeviceFatalError "dDoIO windowFunctions" "could not retrieve WindowSystemState from IOSt"+		else windowIO' deviceEvent ps+	  }+	where+		windowIO' :: DeviceEvent -> ps -> GUI ps ps+		windowIO' (ReceiverEvent rId) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows = windowSystemStateGetWindowHandles wDevice+			it <- ioStGetIdTable+			let Just idParent = Map.lookup rId it+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (idpId idParent)) windows+			checkErrorIO found  "windowIO (ReceiverEvent _) _" "window could not be found"+			toGUI (windowStateMsgIO rId wsH windows1 ps)+		+		windowIO' (CompoundScrollAction info) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)			+			let windows = windowSystemStateGetWindowHandles wDevice			+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId (csaWIDS info))) windows+			checkErrorIO found "windowIO (CompoundScrollAction _) _" "window could not be found"+			wMetrics <- accIOEnv ioStGetOSWindowMetrics+			wsH <- liftIO (windowStateCompoundScrollActionIO wMetrics info wsH)+			let windows2 = setWindowHandlesWindow wsH windows1+			appIOEnv (ioStSetDevice (WindowSystemState windows2))+			return ps+			+		windowIO' (ControlGetKeyFocus info) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows		 = windowSystemStateGetWindowHandles wDevice+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId (ckfWIDS info))) windows+			checkErrorIO found "windowIO (ControlGetKeyFocus _) _" "window could not be found"+			toGUI (windowStateControlKeyFocusActionIO True info wsH windows1 ps)++		windowIO' (ControlKeyboardAction info) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows              = windowSystemStateGetWindowHandles wDevice+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId (ckWIDS info))) windows+			checkErrorIO found "windowIO (ControlKeyboardAction _) _" "window could not be found"+			toGUI (windowStateControlKeyboardActionIO info wsH windows1 ps)++		windowIO' (ControlLooseKeyFocus info) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows 	= windowSystemStateGetWindowHandles wDevice+			let wids	= ckfWIDS info+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId wids)) windows+			checkErrorIO found "windowIO (ControlLooseKeyFocus _) _" "window could not be found"+			oldInputTrack <- ioStGetInputTrack+			let (newInputTrack,lostMouse,lostKey) =+				case oldInputTrack of+					Just it@(InputTrack {itWindow=itWindow,itControl=itControl,itKind=itKind}) ->+						if (itWindow==(wPtr wids) && itControl==(ckfItemNr info))+						then ( Nothing+						     , if (itkMouse    itKind) then [createOSLooseMouseEvent itWindow itControl] else []+						     , if (itkKeyboard itKind) then [createOSLooseKeyEvent   itWindow itControl] else []+						     )+						else (oldInputTrack,[],[])+					Nothing	-> (Nothing,[],[])+			let lostInputEvents = lostMouse ++ lostKey+			ioStSetInputTrack newInputTrack+			(if null lostInputEvents		-- no input was being tracked: simply evaluate control deactivate function+			 then toGUI (windowStateControlKeyFocusActionIO False info wsH windows1 ps)				+			 else do				-- handle control deactivate function AFTER lost input events+				ioStInsertEvents (lostInputEvents ++ [createOSDeactivateControlEvent (wPtr wids) (ckfItemPtr info)])+				return ps)++		windowIO' (ControlMouseAction info) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+		  	let windows = windowSystemStateGetWindowHandles wDevice+		  	let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId (cmWIDS info))) windows+		  	checkErrorIO found  "windowIO (ControlMouseAction _) _" "window could not be found"+		  	toGUI (windowStateControlMouseActionIO info wsH windows1 ps)		  	++		windowIO' (ControlSelection info) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows = windowSystemStateGetWindowHandles wDevice+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId (csWIDS info))) windows+			checkErrorIO found "windowIO (ControlSelection _) _" "window could not be found"+			toGUI (windowStateControlSelectionIO info wsH windows1 ps)++		windowIO' (ControlSliderAction info) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows = windowSystemStateGetWindowHandles wDevice+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId (cslWIDS info))) windows+			checkErrorIO found "windowIO (ControlSliderAction _) _" "window could not be found"+			toGUI (windowStateControlSliderActionIO info wsH windows1 ps)++		windowIO' (WindowActivation wids) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows              = windowSystemStateGetWindowHandles wDevice+			let wid                  = toWID (wId wids)+			let (found,wsH,windows1) = getWindowHandlesWindow wid windows+			checkErrorIO found "windowIO (WindowActivation _)" "window could not be found"+			let (_,_,windows2)  = removeWindowHandlesWindow wid windows1	-- Remove the placeholder from windows1+			toGUI (windowStateActivationIO wsH windows2 ps)++		windowIO' (WindowCreateControls wids) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows              = windowSystemStateGetWindowHandles wDevice+			let (found,wsH,windows1) = removeWindowHandlesWindow (toWID (0::OSWindowPtr)) windows+			checkErrorIO found "windowIO (WindowCreateControls _)" "window could not be found"+			wMetrics        <- accIOEnv ioStGetOSWindowMetrics+			let wsH1         = setWindowStateHandleWIDS wids wsH+			cPtr     <- liftIO (createDialogControls wMetrics wsH1)+			when (cPtr /= osNoWindowPtr)+				(liftIO (osActivateControl (wPtr wids) cPtr) >>= bufferDelayedEvents)+			let windows2     = addWindowHandlesActiveWindow wsH1 windows1+			appIOEnv (ioStSetDevice (WindowSystemState windows2))+			return ps+			where+				createDialogControls :: OSWindowMetrics -> WindowStateHandle ps -> IO OSWindowPtr+				createDialogControls wMetrics wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) = do+					itemHs <- createControls wMetrics (whDefaultId wH) (whCancelId wH) True (wPtr wids) (whItems wH)+					return (getInitActiveControl (wH {whItems=itemHs}))+				createDialogControls _ _+					= windowdeviceFatalError "windowIO (WindowCreateControls _)" "placeholder not expected"++		windowIO' (WindowDeactivation wids) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows              = windowSystemStateGetWindowHandles wDevice+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId wids)) windows+			checkErrorIO found "windowIO (WindowDeactivation _)" "window could not be found"+			toGUI (windowStateDeactivationIO wsH windows1 ps)++		windowIO' (WindowInitialise wids) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows              = windowSystemStateGetWindowHandles wDevice+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId wids)) windows+			checkErrorIO found "windowIO (WindowInitialise _)" "window could not be found"+			toGUI (windowStateInitialiseIO wsH windows1 ps)++		windowIO' (WindowKeyboardAction action) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows = windowSystemStateGetWindowHandles wDevice+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId (wkWIDS action))) windows+			checkErrorIO found "windowIO (WindowKeyboardAction _)" "window could not be found"+			toGUI (windowStateWindowKeyboardActionIO action wsH windows1 ps)++		windowIO' (WindowMouseAction action) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows = windowSystemStateGetWindowHandles wDevice+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId (wmWIDS action))) windows+			checkErrorIO found "windowIO (WindowMouseAction _)" "window could not be found"+			toGUI (windowStateWindowMouseActionIO action wsH windows1 ps)++		windowIO' (WindowCANCEL wids) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows = windowSystemStateGetWindowHandles wDevice+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId wids)) windows+			checkErrorIO found "windowIO (WindowCANCEL _)" "window could not be found"+			toGUI (windowStateCANCELIO wsH windows1 ps)+			+		windowIO' (WindowOK wids) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows = windowSystemStateGetWindowHandles wDevice+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId wids)) windows+			checkErrorIO found "windowIO (WindowOK _)" "window could not be found"+			toGUI (windowStateOKIO wsH windows1 ps)++		windowIO' (WindowRequestClose wids) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows              = windowSystemStateGetWindowHandles wDevice+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId wids)) windows+			checkErrorIO found "windowIO (WindowRequestClose _)" "window could not be found"+			toGUI (windowStateRequestCloseIO wsH windows1 ps)++		windowIO' (WindowScrollAction info) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows = windowSystemStateGetWindowHandles wDevice+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId (wsaWIDS info))) windows+			checkErrorIO found "windowIO (WindowScrollAction _)" "window could not be found"+			wMetrics <- accIOEnv (ioStGetOSWindowMetrics)+			wsH1 <- liftIO (windowStateScrollActionIO wMetrics info wsH)+			let windows2 = setWindowHandlesWindow wsH1 windows1+			appIOEnv (ioStSetDevice (WindowSystemState windows2))				+			return ps++		windowIO' (WindowSizeAction info) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows = windowSystemStateGetWindowHandles wDevice+			let winId = wId (wsWIDS info)+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID winId) windows			+			checkErrorIO found "windowIO (WindowSizeAction _)" "window could not be found"+			let activeWIDS = getWindowHandlesActiveWindow windows1+			wMetrics <- accIOEnv (ioStGetOSWindowMetrics)+			(wsH,ps) <- windowStateSizeAction wMetrics (isJust activeWIDS && (wId (fromJust activeWIDS)) == winId) info wsH ps+			let windows2 = setWindowHandlesWindow wsH windows1+			appIOEnv (ioStSetDevice (WindowSystemState windows2))+			return ps+		+		windowIO' (WindowUpdate info) ps = do+			(_,wDevice) <- accIOEnv (ioStGetDevice WindowDevice)+			let windows 		 = windowSystemStateGetWindowHandles wDevice+			let (found,wsH,windows1) = getWindowHandlesWindow (toWID (wId (updWIDS info))) windows+			checkErrorIO found "windowIO (WindowUpdate _)" "window could not be found"+			wMetrics        <- accIOEnv ioStGetOSWindowMetrics+			wsH <- liftIO (windowStateUpdateIO wMetrics info wsH)+			let windows2 = setWindowHandlesWindow wsH windows1+			appIOEnv (ioStSetDevice (WindowSystemState windows2))+			return ps+			where+				windowStateUpdateIO :: OSWindowMetrics -> UpdateInfo -> WindowStateHandle ps -> IO (WindowStateHandle ps)+				windowStateUpdateIO wMetrics info wsH@(WindowStateHandle wids (Just wlsHandle@(WindowLSHandle {wlsHandle=wH}))) = do+					wH <- updateWindow wMetrics info wH+					return (WindowStateHandle wids (Just wlsHandle{wlsHandle=wH}))+				windowStateUpdateIO _ _ _+					= windowdeviceFatalError "windowIO (WindowUpdate _) _" "unexpected placeholder argument"++++{-	windowStateMsgIO handles all message events. -}++windowStateMsgIO :: Id -> WindowStateHandle ps -> WindowHandles ps -> ps -> IOSt ps -> IO (ps, IOSt ps)+windowStateMsgIO rId wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsState=ls,wlsHandle=wH}))) windows ps ioState = do+	r <- windowControlMsgIO  (\wH st ioState -> ioStSetDevice+					(WindowSystemState+						(setWindowHandlesWindow+							(WindowStateHandle wids (Just (WindowLSHandle {wlsState=fst st,wlsHandle=wH})))+							 windows))+						 ioState) rId wH (ls,ps) ioState+	let ((_,ps1), ioState) = r+	return (ps1,ioState)+	where+	--	windowControlASyncIO handles the first asynchronous message in the message queue of the indicated receiver control.+		windowControlMsgIO :: (WindowHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) -> +					Id -> WindowHandle ls ps -> (ls,ps) -> IOSt ps -> IO ((ls,ps), IOSt ps)+		windowControlMsgIO build rId wH@(WindowHandle {whItems=itemHs}) ls_ps ioState = do+			r <- elementsControlMsgIO (\itemHs st ioState -> build (wH {whItems=itemHs}) st ioState) rId itemHs ls_ps ioState+			let (_,ls_ps1,ioState) = r+			return (ls_ps1,ioState)+			where+				elementsControlMsgIO :: ([WElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IOSt ps) -> +							  Id -> [WElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IO (Bool,(ls,ps),IOSt ps)+				elementsControlMsgIO build rId (itemH:itemHs) ls_ps ioState = do+					r <- elementControlMsgIO (\itemH st ioState -> build (itemH:itemHs) st ioState) rId itemH ls_ps ioState+					let (done,ls_ps,ioState) = r+					(if done then return r+					 else elementsControlMsgIO (\itemHs st ioState -> build (itemH:itemHs) st ioState) rId itemHs ls_ps ioState)+					where+						elementControlMsgIO :: (WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) -> +									 Id -> WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IO (Bool,(ls,ps),IOSt ps)+						elementControlMsgIO build rId itemH@(WItemHandle {}) ls_ps ioState+							| not (identifyMaybeId rId (wItemId itemH)) =+								if not (isRecursiveControl itemKind)+								then return (False,ls_ps,build itemH ls_ps ioState)+								else elementsControlMsgIO (\itemHs st ioState -> build (itemH{wItems = itemHs}) st ioState) rId (wItems itemH) ls_ps ioState+							| itemKind /= IsReceiverControl =+								return (True,ls_ps,ioState)+							| otherwise = itemControlMsgIO build rId itemH ls_ps ioState+								where+									itemKind = wItemKind itemH++									itemControlMsgIO :: (WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) -> +									 			Id -> WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IO (Bool,(ls,ps),IOSt ps)+									itemControlMsgIO build rId itemH@(WItemHandle {wItemInfo=WReceiverInfo (ReceiverHandle {rFun=f})}) ls_ps ioState = do+										r <- fixIO (\st -> fromGUI (f ls_ps) (build itemH (fst st) ioState))+										let (ls_ps1, ioState1) = r+										return (True, ls_ps1, ioState1)++						elementControlMsgIO build rId (WListLSHandle itemHs) ls_ps ioState = do+							elementsControlMsgIO (\itemHs st ioState -> build (WListLSHandle itemHs) st ioState) rId itemHs ls_ps ioState++						elementControlMsgIO build rId (WExtendLSHandle exLS itemHs) (ls,ps) ioState = do+							r <- elementsControlMsgIO (\itemHs st ioState -> build (WExtendLSHandle (fst (fst st)) itemHs) (snd (fst st),snd st) ioState) rId itemHs ((exLS,ls),ps) ioState+							let (done,((exLS,ls),ps),ioState) = r+							return (done,(ls,ps),ioState)++						elementControlMsgIO build rId (WChangeLSHandle chLS itemHs) (ls,ps) ioState = do+							r <- elementsControlMsgIO (\itemHs st ioState -> build (WChangeLSHandle (fst st) itemHs) (ls,snd st) ioState) rId itemHs (chLS,ps) ioState+							let (done,(chLS,ps),ioState) = r+							return (done,(ls,ps),ioState)++				elementsControlMsgIO _ _ _ ls_ps ioState = return (False,ls_ps,ioState)+++windowStateMsgIO  _ _ _ _ _ = windowdeviceFatalError "windowStateMsgIO" "unexpected window placeholder"++{-	windowStateCompoundScrollActionIO handles the mouse actions of CompoundControl scrollbars.  -}++windowStateCompoundScrollActionIO :: OSWindowMetrics -> CompoundScrollActionInfo -> WindowStateHandle ps -> IO (WindowStateHandle ps)+windowStateCompoundScrollActionIO wMetrics info@(CompoundScrollActionInfo {csaWIDS=WIDS{wPtr=wPtr}})+			wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) = +    let +    	WindowHandle{whKind=whKind,whItems=itemHs,whSize=whSize,whAtts=whAtts,whSelect=whSelect} = wH+	windowInfo		= whWindowInfo wH+	(origin,domainRect,hasHScroll,hasVScroll) = +		if (whKind==IsWindow)+		then (windowOrigin windowInfo,windowDomain windowInfo,isJust (windowHScroll windowInfo),isJust (windowVScroll windowInfo))+		else (zero,sizeToRect whSize,False,False)+	domain			= rectToRectangle domainRect+	visScrolls		= osScrollbarsAreVisible wMetrics domainRect (toTuple whSize) (hasHScroll,hasVScroll)+	wFrame			= getWindowContentRect wMetrics visScrolls (sizeToRect whSize)+	contentSize		= rectSize wFrame+	(defMinW,  defMinH)	= osMinWindowSize+	minSize			= Size{w=defMinW,h=defMinH}+	hMargins		= getWindowHMargins   whKind wMetrics whAtts+	vMargins		= getWindowVMargins   whKind wMetrics whAtts+	spaces			= getWindowItemSpaces whKind wMetrics whAtts+    in do    	    +	    (done,originChanged,itemHs1) <- calcNewCompoundOrigin wMetrics info itemHs	    +	    (if not done then windowdeviceFatalError "windowStateCompoundScrollActionIO" "could not locate CompoundControl"+	     else+		(if not originChanged then return (WindowStateHandle wids (Just wlsH{wlsHandle=wH{whItems=itemHs1}}))+		 else do+		    (_,newItems) <- layoutControls wMetrics hMargins vMargins spaces contentSize minSize [(domain,origin)] itemHs1		    +		    wH <- forceValidWindowClipState wMetrics True wPtr (wH{whItems=newItems})+		    updRgn <- relayoutControls wMetrics whSelect (whShow wH) wFrame wFrame zero zero wPtr (whDefaultId wH) itemHs (whItems wH)+		    wH <- updateWindowBackgrounds wMetrics updRgn (csaWIDS info) wH+		    wH <- drawcompoundlook wMetrics whSelect wFrame (csaItemNr info) wPtr wH	-- PA: this might be redundant now because of updateWindowBackgrounds+		    return (WindowStateHandle wids (Just wlsH{wlsHandle=wH}))))+    where	+	drawcompoundlook :: OSWindowMetrics -> Bool -> Rect -> Int -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+	drawcompoundlook wMetrics ableContext clipRect itemNr wPtr wH = do+	    (_,itemHs) <- drawcompoundlook' wMetrics ableContext clipRect itemNr wPtr (whItems wH)+	    return (wH{whItems=itemHs})+	    where+		drawcompoundlook' :: OSWindowMetrics -> Bool -> Rect -> Int -> OSWindowPtr -> [WElementHandle ls ps] -> IO (Bool,[WElementHandle ls ps])+		drawcompoundlook' wMetrics ableContext clipRect itemNr wPtr (itemH:itemHs) = do+		    (done,itemH) <- drawWElementLook wMetrics ableContext clipRect itemNr wPtr itemH+		    (if done then return (done,itemH:itemHs)+		     else do+		        (done,itemHs) <- drawcompoundlook' wMetrics ableContext clipRect itemNr wPtr itemHs+		        return (done,itemH:itemHs))+		    where+			drawWElementLook :: OSWindowMetrics -> Bool -> Rect -> Int -> OSWindowPtr -> WElementHandle ls ps -> IO (Bool,WElementHandle ls ps)+			drawWElementLook wMetrics ableContext clipRect itemNr wPtr itemH@(WItemHandle {wItemKind=wItemKind,wItemSelect=wItemSelect})+				| csaItemNr info /= wItemNr itemH =+					if not (isRecursiveControl wItemKind) then+						return (False,itemH)+					else+					   if wItemKind==IsLayoutControl then do+						(done,itemHs) <- drawcompoundlook' wMetrics isAble (intersectRects clipRect itemRect) itemNr wPtr (wItems itemH)+						return (done,itemH{wItems=itemHs})+					   else do+					       (done,itemHs) <- drawcompoundlook' wMetrics isAble clipRect1 itemNr wPtr (wItems itemH)+					       return (done,itemH{wItems=itemHs})+				| wItemKind /= IsCompoundControl+					= windowdeviceFatalError "drawWElementLook (windowStateCompoundScrollActionIO)" "argument control is not a CompoundControl"+				| otherwise = do+					itemH <- drawCompoundLook wMetrics isAble wPtr clipRect1 itemH+					osValidateWindowRect (wItemPtr itemH) clipRect1+					return (True,itemH)+				where+					isAble		= ableContext && wItemSelect+					itemPos		= wItemPos itemH+					itemSize	= wItemSize itemH+					itemInfo	= getWItemCompoundInfo (wItemInfo itemH)+					domainRect	= compoundDomain itemInfo+					hasScrolls	= (isJust (compoundHScroll itemInfo),isJust (compoundVScroll itemInfo))+					visScrolls	= osScrollbarsAreVisible wMetrics domainRect (toTuple itemSize) hasScrolls+					itemRect	= posSizeToRect itemPos itemSize+					contentRect	= getCompoundContentRect wMetrics visScrolls itemRect +					clipRect1	= intersectRects clipRect contentRect+		+			drawWElementLook wMetrics ableContext clipRect itemNr wPtr (WListLSHandle itemHs) = do+				(done,itemHs) <- drawcompoundlook' wMetrics ableContext clipRect itemNr wPtr itemHs+				return (done,WListLSHandle itemHs)+			+			drawWElementLook wMetrics ableContext clipRect itemNr wPtr (WExtendLSHandle exLS itemHs) = do+				(done,itemHs) <- drawcompoundlook' wMetrics ableContext clipRect itemNr wPtr itemHs+				return (done,WExtendLSHandle exLS itemHs)+			+			drawWElementLook wMetrics ableContext clipRect itemNr wPtr (WChangeLSHandle chLS itemHs) = do+				(done,itemHs) <- drawcompoundlook' wMetrics ableContext clipRect itemNr wPtr itemHs+				return (done,WChangeLSHandle chLS itemHs)+		+		drawcompoundlook' _ _ _ _ _ itemHs = return (False,itemHs)+	+	calcNewCompoundOrigin :: OSWindowMetrics -> CompoundScrollActionInfo -> [WElementHandle ls ps] -> IO (Bool,Bool,[WElementHandle ls ps])+	calcNewCompoundOrigin wMetrics info (itemH:itemHs) = do+	    (done,changed,itemH) <- calcNewWElementOrigin wMetrics info itemH+	    (if done then return (done,changed,(itemH:itemHs))+ 	     else do+			(done,changed,itemHs) <- calcNewCompoundOrigin wMetrics info itemHs+			return (done,changed,itemH:itemHs))+	    where+		calcNewWElementOrigin :: OSWindowMetrics -> CompoundScrollActionInfo -> WElementHandle ls ps -> IO (Bool,Bool,WElementHandle ls ps)+		calcNewWElementOrigin wMetrics info itemH@(WItemHandle {wItemKind=wItemKind,wItemAtts=wItemAtts})+			| csaItemNr info /= wItemNr itemH =+				if not (isRecursiveControl wItemKind) then+					return (False,False,itemH)+				else do+					(done,changed,itemHs) <- calcNewCompoundOrigin wMetrics info (wItems itemH)+					return (done,changed,itemH{wItems=itemHs})+			| wItemKind /= IsCompoundControl		-- This alternative should never occur+				= windowdeviceFatalError "windowStateCompoundScrollActionIO" "CompoundScrollAction does not correspond with CompoundControl"+			| newThumb == oldThumb =+				return (True,False,itemH)+			| otherwise = do+				osSetCompoundSliderThumb wMetrics itemPtr isHorizontal newOSThumb (toTuple compoundSize) True+				let itemH1 = itemH{ wItemInfo=WCompoundInfo compoundInfo{compoundOrigin=newOrigin}+						  , wItemAtts=replaceOrAppend isControlViewSize (ControlViewSize rsize) wItemAtts+						  }+				return (True,True,itemH1)+			where+				itemPtr	= csaItemPtr info+				compoundSize = wItemSize itemH+				compoundInfo = getWItemCompoundInfo (wItemInfo itemH)+				(domainRect,origin,hScroll,vScroll)	= (compoundDomain compoundInfo,compoundOrigin compoundInfo,compoundHScroll compoundInfo,compoundVScroll compoundInfo)+				visScrolls = osScrollbarsAreVisible wMetrics domainRect (toTuple compoundSize) (isJust hScroll,isJust vScroll)+				rsize@(Size {w=w,h=h}) = rectSize (getCompoundContentRect wMetrics visScrolls (sizeToRect compoundSize))+				isHorizontal = csaDirection info==Horizontal+				scrollInfo = fromJust (if isHorizontal then hScroll else vScroll)+				scrollFun = scrollFunction scrollInfo+				viewFrame = posSizeToRectangle origin rsize+				(min',oldThumb,max',viewSize) = +					if isHorizontal+					then (rleft domainRect,x origin,rright  domainRect,w)+					else (rtop  domainRect,y origin,rbottom domainRect,h)+				sliderState = SliderState {sliderMin=min',sliderThumb=oldThumb,sliderMax=max min' (max'-viewSize)}+				newThumb' = scrollFun viewFrame sliderState (csaSliderMove info)+				newThumb  = setBetween newThumb' min' (max min' (max'-viewSize))+				(_,newOSThumb,_,_) = toOSscrollbarRange (min',newThumb,max') viewSize+				newOrigin = if isHorizontal then origin{x=newThumb} else origin{y=newThumb}+		+		calcNewWElementOrigin wMetrics info (WListLSHandle itemHs) = do+			(done,changed,itemHs) <- calcNewCompoundOrigin wMetrics info itemHs+			return (done,changed,WListLSHandle itemHs)+		+		calcNewWElementOrigin wMetrics info (WExtendLSHandle extLS itemHs) = do+			(done,changed,itemHs) <- calcNewCompoundOrigin wMetrics info itemHs+			return (done,changed,WExtendLSHandle extLS itemHs)+		+		calcNewWElementOrigin wMetrics info (WChangeLSHandle chLS itemHs) = do+			(done,changed,itemHs) <- calcNewCompoundOrigin wMetrics info itemHs+			return (done,changed,WChangeLSHandle chLS itemHs)+	+	calcNewCompoundOrigin _ _ _ = return (False,False,[])+	+windowStateCompoundScrollActionIO _ _ _+	= windowdeviceFatalError "windowStateCompoundScrollActionIO" "unexpected window placeholder"++{-	windowStateControlKeyFocusActionIO handles the keyboard focus actions of (Compound/Custom/Edit/PopUp)Controls.+	The Bool argument indicates whether the control has obtained key focus (True) or lost key focus (False).+-}++windowStateControlKeyFocusActionIO :: Bool -> ControlKeyFocusInfo -> WindowStateHandle ps -> WindowHandles ps -> ps -> IOSt ps -> IO (ps, IOSt ps)++windowStateControlKeyFocusActionIO activated info wsH@(WindowStateHandle wids (Just (WindowLSHandle {wlsState=ls,wlsHandle=wH}))) windows ps ioState = do+	r <- windowControlKeyFocusActionIO (\wH st ioState -> ioStSetDevice+							  (WindowSystemState+							      (setWindowHandlesWindow+								  (WindowStateHandle wids (Just (WindowLSHandle {wlsState=fst st,wlsHandle=wH})))+								  windows))+							  ioState) activated info wH (ls,ps) ioState+	let ((ls1, ps1), ioState) = r+	return (ps1, ioState)+	where+		windowControlKeyFocusActionIO :: (WindowHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+						Bool -> ControlKeyFocusInfo -> WindowHandle ls ps -> (ls, ps) -> IOSt ps -> IO ((ls, ps), IOSt ps)+		windowControlKeyFocusActionIO build activated info wH@(WindowHandle {whItems=whItems,whKeyFocus=whKeyFocus}) ls_ps ioState = do+			r <- elementsControlKeyFocusActionIO (\itemHs st ioState -> build wH{whItems=itemHs, whKeyFocus=keyfocus} st ioState) activated info whItems ls_ps ioState+			let (_, ls_ps1, ioState) = r+			return (ls_ps1, ioState)+			where+				keyfocus =+				   if activated then setNewFocusItem (ckfItemNr info) whKeyFocus+				   else setNoFocusItem whKeyFocus++				elementsControlKeyFocusActionIO :: ([WElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IOSt ps) ->+								   Bool -> ControlKeyFocusInfo -> [WElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IO (Bool, (ls,ps), IOSt ps)+				elementsControlKeyFocusActionIO build activated info (itemH:itemHs) ls_ps ioState = do+					r <- elementControlKeyFocusActionIO (\itemH st ioState -> build (itemH:itemHs) st ioState) activated info itemH ls_ps ioState+					let (done, ls_ps1, ioState) = r+					(if done then return r+					 else elementsControlKeyFocusActionIO (\itemHs st ioState -> build (itemH:itemHs) st ioState) activated info itemHs ls_ps1 ioState)+					where+						elementControlKeyFocusActionIO :: (WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+										  Bool -> ControlKeyFocusInfo -> WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IO (Bool, (ls,ps), IOSt ps)+						elementControlKeyFocusActionIO build activated info itemH@(WItemHandle {wItemAtts=wItemAtts, wItems=itemHs, wItemKind=wItemKind}) ls_ps ioState+							| (ckfItemNr info) /= (wItemNr itemH) =+								if not (isRecursiveControl wItemKind) then return (False, ls_ps, ioState)+								else elementsControlKeyFocusActionIO (\itemHs st ioState -> build itemH{wItems=itemHs} st ioState) activated info itemHs ls_ps ioState+									+							| otherwise = do+								r <- fixIO (\st -> fromGUI (f ls_ps) (build itemH (fst st) ioState))+								let (ls_ps1, ioState) = r+								return (True, ls_ps1, ioState)+							where+								f = getAtt (snd (cselect reqAtt undefined wItemAtts))+								(reqAtt,getAtt)	=+									if activated+									then (isControlActivate,  getControlActivateFun  )+									else (isControlDeactivate,getControlDeactivateFun)++						elementControlKeyFocusActionIO build activated info (WListLSHandle itemHs) ls_ps ioState = do+							elementsControlKeyFocusActionIO (\itemHs st ioState -> build (WListLSHandle itemHs) st ioState) activated info itemHs ls_ps ioState++						elementControlKeyFocusActionIO build activated info (WExtendLSHandle extLS itemHs) (ls,ps) ioState = do+							r <- elementsControlKeyFocusActionIO (\itemHs st ioState -> build (WExtendLSHandle (fst (fst st)) itemHs) ((snd (fst st)), snd st) ioState) activated info itemHs ((extLS,ls), ps) ioState+							let (done,((_,ls1),ps1),ioState)  = r+							return (done,(ls1,ps1),ioState)++						elementControlKeyFocusActionIO build activated info (WChangeLSHandle chLS itemHs) (ls,ps) ioState = do+							r <- elementsControlKeyFocusActionIO (\itemHs st ioState -> build (WChangeLSHandle (fst st) itemHs) (ls,snd st) ioState) activated info itemHs (chLS,ps) ioState+							let (done,(_,ps1),ioState) = r+							return (done,(ls,ps1),ioState)++				elementsControlKeyFocusActionIO _ _ _ [] ls_ps ioState = return (False, ls_ps, ioState)+windowStateControlKeyFocusActionIO _ _ _ _ _ _+	= windowdeviceFatalError "windowStateControlKeyFocusActionIO" "unexpected window placeholder"+++{-	windowStateControlKeyboardActionIO handles the keyboard actions of (Edit/Custom/PopUp)Controls+	and CompoundControls (not yet).+	In this implementation only EditControls are taken into account.+-}+windowStateControlKeyboardActionIO :: ControlKeyboardActionInfo -> WindowStateHandle ps -> WindowHandles ps -> ps -> IOSt ps -> IO (ps,IOSt ps)+windowStateControlKeyboardActionIO info wsH@(WindowStateHandle wids (Just (WindowLSHandle {wlsState=ls,wlsHandle=wH}))) windows ps ioState+	= do {+		r <- windowControlKeyboardActionIO (\wH st ioState -> ioStSetDevice+		                                                          (WindowSystemState+		                                                              (setWindowHandlesWindow+		                                                                  (WindowStateHandle wids (Just (WindowLSHandle {wlsState=fst st,wlsHandle=wH})))+		                                                                  windows))+		                                                          ioState)+		                                   wH (ls,ps) ioState;+		let ((_,ps1),ioState1) = r+		in  return (ps1,ioState1)+	  }+	where+		windowControlKeyboardActionIO :: (WindowHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps)+		                               -> WindowHandle ls ps -> (ls,ps) -> IOSt ps -> IO ((ls,ps),IOSt ps)+		windowControlKeyboardActionIO build wH@(WindowHandle {whItems=whItems}) ls_ps ioState+			= do {+				r <- elementsControlKeyboardActionIO (\itemHs st ioState -> build (wH {whItems=itemHs}) st ioState) whItems ls_ps ioState;+				let (_,ls_ps1,ioState1) = r+				in  return (ls_ps1,ioState1)+			  }+			where+				elementsControlKeyboardActionIO :: ([WElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IOSt ps)+				                                 -> [WElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IO (Bool,(ls,ps),IOSt ps)+				elementsControlKeyboardActionIO build (itemH:itemHs) ls_ps ioState+					= do {+						r <- elementControlKeyboardActionIO (\itemH st ioState -> build (itemH:itemHs) st ioState) itemH ls_ps ioState;+						let (done,ls_ps1,ioState1) = r+						in  if   done+						    then return (done,ls_ps1,ioState1)+						    else elementsControlKeyboardActionIO (\itemHs st ioState -> build (itemH:itemHs) st ioState) itemHs ls_ps1 ioState1+					  }+					where+						elementControlKeyboardActionIO :: (WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps)+						                                -> WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IO (Bool,(ls,ps),IOSt ps)++						elementControlKeyboardActionIO build (WListLSHandle itemHs) ls_ps ioState+							= elementsControlKeyboardActionIO (\itemHs st ioState -> build (WListLSHandle itemHs) st ioState) itemHs ls_ps ioState++						elementControlKeyboardActionIO build (WExtendLSHandle addLS itemHs) (ls,ps) ioState+							= do {+								r <- elementsControlKeyboardActionIO (\itemHs st ioState -> build (WExtendLSHandle (fst (fst st)) itemHs) (snd (fst st),snd st) ioState)+								                                     itemHs ((addLS,ls),ps) ioState;+								let (done,((_,ls1),ps1),ioState1) = r+								in  return (done,(ls1,ps1),ioState1)+							  }++						elementControlKeyboardActionIO build (WChangeLSHandle newLS itemHs) (ls,ps) ioState+							= do {+								r <- elementsControlKeyboardActionIO (\itemHs st ioState -> build (WChangeLSHandle (fst st) itemHs) (ls,snd st) ioState)+								                                     itemHs (newLS,ps) ioState;+								let (done,(_,ps1),ioState1) = r+								in  return (done,(ls,ps1),ioState1)+							  }++						elementControlKeyboardActionIO build itemH ls_ps ioState+							| ckItemNr info /= wItemNr itemH =+								if not (isRecursiveControl (wItemKind itemH))+								then return (False,ls_ps,build itemH ls_ps ioState)+								else elementsControlKeyboardActionIO (\itemHs st ioState -> build (itemH{wItems = itemHs}) st ioState) (wItems itemH) ls_ps ioState+							| otherwise = do								+								r <- itemControlKeyboardActionIO build itemH ls_ps ioState+								let (ls_ps1,ioState1) = r+								return (True,ls_ps1,ioState1)								+							where+								itemControlKeyboardActionIO :: (WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps)+								                             -> WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IO ((ls,ps),IOSt ps)+								itemControlKeyboardActionIO build itemH ls_ps ioState+									= fixIO (\st -> fromGUI (f (ckKeyboardState info) ls_ps) (build itemH (fst st) ioState))+									where+										(_,_,f) = getControlKeyboardAtt (snd (cselect isControlKeyboard undefined (wItemAtts itemH)))++				elementsControlKeyboardActionIO build nil ls_ps ioState+					= return (False,ls_ps,build nil ls_ps ioState)++windowStateControlKeyboardActionIO _ _ _ _ _+	= windowdeviceFatalError "windowStateControlKeyboardActionIO" "unexpected window placeholder"+++{-	windowStateControlMouseActionIO handles the mouse actions of CustomControls and CompoundControls (not yet). -}++windowStateControlMouseActionIO :: ControlMouseActionInfo -> WindowStateHandle ps -> WindowHandles ps -> ps -> IOSt ps -> IO (ps, IOSt ps)+windowStateControlMouseActionIO info wsH@(WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsState=ls,wlsHandle=wH@(WindowHandle {whItems=itemHs})}))) windows ps ioState = do+	r <- elementsControlMouseActionIO (\itemHs st ioState -> ioStSetDevice+						  (WindowSystemState+						      (setWindowHandlesWindow+							  (WindowStateHandle wids (Just (WindowLSHandle {wlsState=fst st,wlsHandle=wH{whItems=itemHs}})))+							  windows))+						  ioState) info itemHs (ls,ps) ioState+	let (_,(ls,ps),ioState) = r+	return (ps,ioState)+	where+		elementsControlMouseActionIO :: ([WElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IOSt ps) ->+						ControlMouseActionInfo -> [WElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IO (Bool,(ls,ps),IOSt ps)+		elementsControlMouseActionIO build info (itemH:itemHs) ls_ps ioState = do+		    r <- elementControlMouseActionIO (\itemH st ioState -> build (itemH:itemHs) st ioState) info itemH ls_ps ioState+		    let (done,ls_ps,ioState) = r+		    (if done then return r+ 		     else elementsControlMouseActionIO (\itemHs st ioState -> build (itemH:itemHs) st ioState) info itemHs ls_ps ioState)+		    where+			elementControlMouseActionIO :: (WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+							ControlMouseActionInfo -> WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IO (Bool,(ls,ps),IOSt ps)+			elementControlMouseActionIO build info itemH@(WItemHandle {wItemAtts=wItemAtts}) ls_ps ioState+				| cmItemNr info /= wItemNr itemH =+					if not (isRecursiveControl (wItemKind itemH)) then+						return (False,ls_ps,ioState)+					else elementsControlMouseActionIO (\itemHs st ioState -> build itemH{wItems=itemHs} st ioState) info (wItems itemH) ls_ps ioState+						+				| otherwise = do+					r <- fixIO (\st -> fromGUI (f (cmMouseState info) ls_ps) (build itemH (fst st) ioState))+					let (ls_ps, ioState) = r+					return (True,ls_ps,ioState)+					where+						(_,_,f)	= getControlMouseAtt (snd (cselect isControlMouse undefined wItemAtts))+			+			+			elementControlMouseActionIO build info (WListLSHandle itemHs) ls_ps ioState = do+				elementsControlMouseActionIO (\itemHs st ioState -> build (WListLSHandle itemHs) st ioState) info itemHs ls_ps ioState+			+			elementControlMouseActionIO build info (WExtendLSHandle extLS itemHs) (ls,ps) ioState = do+				r <- elementsControlMouseActionIO (\itemHs st ioState -> build (WExtendLSHandle (fst (fst st)) itemHs) (snd (fst st), snd st) ioState) info itemHs ((extLS,ls),ps) ioState+				let (done,((_,ls),ps),ioState) = r+				return (done,(ls,ps),ioState)+			+			elementControlMouseActionIO build info (WChangeLSHandle chLS itemHs) (ls,ps) ioState = do+				r <- elementsControlMouseActionIO (\itemHs st ioState -> build (WChangeLSHandle (fst st) itemHs) (ls, snd st) ioState) info itemHs (chLS,ps) ioState+				let (done,(_,ps),ioState) = r+				return (done,(ls,ps),ioState)+		+		elementsControlMouseActionIO _ _ _ ls_ps ioState = return (False,ls_ps,ioState)+windowStateControlMouseActionIO _ _ _ _ _+	= windowdeviceFatalError "windowStateControlMouseActionIO" "unexpected window placeholder"+++{-	windowStateControlSelectionIO handles the selection of the control. -}++windowStateControlSelectionIO :: ControlSelectInfo -> WindowStateHandle ps -> WindowHandles ps -> ps -> IOSt ps -> IO (ps, IOSt ps)+windowStateControlSelectionIO info (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsState=ls,wlsHandle=wH}))) windows ps ioState = do+     r <- windowControlSelectionIO (\wH st ioState -> ioStSetDevice+						  (WindowSystemState+						      (setWindowHandlesWindow+							  (WindowStateHandle wids (Just (WindowLSHandle {wlsState=fst st,wlsHandle=wH})))+							  windows))+						  ioState) info wH (ls,ps) ioState+     let ((_,ps1),ioState) = r+     return (ps1,ioState)+     where+	  windowControlSelectionIO :: (WindowHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+	  			      ControlSelectInfo -> WindowHandle ls ps -> (ls,ps) -> IOSt ps -> IO ((ls, ps), IOSt ps)+	  windowControlSelectionIO build info wH@(WindowHandle {whItems=whItems}) ls_ps ioState = do+		  r <- elementsControlSelectionIO (\itemHs st ioState -> build wH{whItems=itemHs} st ioState) info whItems ls_ps ioState+		  let (_,ls_ps,ioState) = r+		  return (ls_ps,ioState)+		  where+			elementsControlSelectionIO :: ([WElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IOSt ps) ->+						      ControlSelectInfo -> [WElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IO (Bool, (ls, ps), IOSt ps)+			elementsControlSelectionIO build info (itemH:itemHs) ls_ps ioState = do+				r <- elementControlSelectionIO (\itemH st ioState -> build (itemH:itemHs) st ioState) info itemH ls_ps ioState+				let (done, ls_ps1, ioState) = r+				(if done then return r+				 else elementsControlSelectionIO (\itemHs st ioState -> build (itemH:itemHs) st ioState) info itemHs ls_ps1 ioState)+				where+					elementControlSelectionIO :: (WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+								     ControlSelectInfo -> WElementHandle ls ps -> (ls, ps) -> IOSt ps -> IO (Bool, (ls, ps), IOSt ps)+					elementControlSelectionIO build info itemH@(WItemHandle{wItemKind=wItemKind,wItemNr=wItemNr,wItems=wItems}) ls_ps ioState+						| (csItemNr info) /= wItemNr =+							if isRecursiveControl wItemKind then do+								elementsControlSelectionIO (\itemHs st ioState -> build itemH{wItems=itemHs} st ioState) info wItems ls_ps ioState								+							else return (False, ls_ps, ioState)+						| otherwise = do+							r <- itemControlSelectionIO build info itemH ls_ps ioState+							let (ls_ps1, ioState) = r+							return (True, ls_ps1, ioState)+						where+							itemControlSelectionIO :: (WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+										  ControlSelectInfo -> WElementHandle ls ps -> (ls, ps) -> IOSt ps -> IO ((ls, ps), IOSt ps)++							itemControlSelectionIO build info itemH@(WItemHandle {wItemKind=IsRadioControl,wItemInfo=wItemInfo}) ls_ps ioState =+								fixIO (\st -> fromGUI (f ls_ps) (build itemH{wItemInfo=WRadioInfo (radioInfo{radioIndex=index})} (fst st) ioState))+								where+									(_, _, f)	= radioItem radio+									itemPtr	  	= csItemPtr info+									radioInfo 	= getWItemRadioInfo wItemInfo+									error		= windowdeviceFatalError "windowIO _ (ControlSelection _) _" "RadioControlItem could not be found"+									(index,radio)	= selectedAtIndex (\(RadioItemInfo{radioItemPtr=radioItemPtr})->radioItemPtr==itemPtr) error (radioItems radioInfo)									++							itemControlSelectionIO build info itemH@(WItemHandle {wItemKind=IsCheckControl,wItemInfo=wItemInfo}) ls_ps ioState =+								fixIO (\st -> fromGUI (f ls_ps) (build itemH{wItemInfo=WCheckInfo (checkInfo{checkItems=checks})} (fst st) ioState))+								where+									itemPtr		= csItemPtr info+									checkInfo 	= getWItemCheckInfo wItemInfo+									error		= windowdeviceFatalError "windowIO _ (ControlSelection _) _" "CheckControlItem could not be found"+									(_,f,checks)	= access (isCheckItem itemPtr) error (checkItems checkInfo)++									isCheckItem :: OSWindowPtr -> CheckItemInfo ls ps -> ((Bool,GUIFun ls ps),CheckItemInfo ls ps)+									isCheckItem itemPtr check@(CheckItemInfo {checkItemPtr=checkItemPtr,checkItem=(title,width,mark,f)})+										| itemPtr==checkItemPtr+											= ((True,f), check{checkItem=(title,width,toggle mark,f)})+										| otherwise+											= ((False,return),check)++							itemControlSelectionIO build info itemH@(WItemHandle {wItemKind=IsPopUpControl,wItemInfo=wItemInfo}) ls_ps ioState =+								fixIO (\st -> fromGUI (f ls_ps) (build itemH{wItemInfo= WPopUpInfo (popUpInfo{popUpInfoIndex=index})} (fst st) ioState))+								where+									popUpInfo	= getWItemPopUpInfo wItemInfo+									index		= csMoreData info+									f		= snd ((popUpInfoItems popUpInfo) !! (index-1))+									+							itemControlSelectionIO build info itemH@(WItemHandle {wItemKind=IsListBoxControl,wItemInfo=itemInfo}) ls_ps ioState =+								fixIO (\st -> fromGUI (f ls_ps) (build itemH{wItemInfo=WListBoxInfo (lboxInfo{listBoxInfoItems=newItems})} (fst st) ioState))+								where+									lboxInfo	= getWItemListBoxInfo itemInfo+									oldItems	= listBoxInfoItems lboxInfo+									(newItems,f) 	= updateItems (csMoreData info) oldItems+									+									updateItems n [] = ([], return)+									updateItems n ((title,mark,f):items)+										| n == 1 =+											let (items',_) = updateItems (n-1) items+											in ((title,if listBoxInfoMultiSel lboxInfo then toggle mark else Mark,f):items',f)+										| otherwise =+											let (items',f') = updateItems (n-1) items+											in ((title,if listBoxInfoMultiSel lboxInfo then mark else NoMark,f):items',f')++							itemControlSelectionIO build info itemH@(WItemHandle {wItemKind=wItemKind,wItemAtts=atts}) ls_ps ioState+								| (wItemKind==IsButtonControl || wItemKind==IsCustomButtonControl) && hasAtt =+									fixIO (\st -> fromGUI (f ls_ps) (build itemH (fst st) ioState))+								| otherwise = return (ls_ps, ioState)+								where+									(hasAtt,fAtt) = cselect (\att->isControlFunction att || isControlModsFunction att) undefined atts+									f             = case fAtt of+											   ControlFunction     fun -> fun+											   ControlModsFunction fun -> fun (csModifiers info)+											   wrongAttribute          -> windowdeviceFatalError "windowStateControlSelectionIO" "argument is not a function attribute"+					elementControlSelectionIO build info (WListLSHandle itemHs) ls_ps ioState = do+						elementsControlSelectionIO (\itemHs st ioState -> build (WListLSHandle itemHs) st ioState) info itemHs ls_ps ioState++					elementControlSelectionIO build info (WExtendLSHandle extLS itemHs) (ls,ps) ioState = do+						r <- elementsControlSelectionIO (\itemHs st ioState -> build (WExtendLSHandle (fst (fst st)) itemHs) (snd (fst st), snd st) ioState) info itemHs ((extLS,ls),ps) ioState+						let (done,((_,ls1),ps1), ioState) = r+						return (done, (ls1,ps1), ioState)++					elementControlSelectionIO build info (WChangeLSHandle chLS itemHs) (ls,ps) ioState = do+						r <- elementsControlSelectionIO (\itemHs st ioState -> build (WChangeLSHandle (fst st) itemHs) (ls,snd st) ioState) info itemHs (chLS,ps) ioState+						let (done,(_,ps1),ioState) = r+						return (done,(ls,ps1),ioState)++			elementsControlSelectionIO _ _ _ ls_ps ioState = return (False, ls_ps, ioState)+windowStateControlSelectionIO _ _ _ _ _+	= windowdeviceFatalError "windowStateControlSelectionIO" "unexpected window placeholder"+++++{- windowStateControlSliderActionIO handles the slider of windows/dialogs. -}++windowStateControlSliderActionIO :: ControlSliderInfo -> WindowStateHandle ps -> WindowHandles ps -> ps -> IOSt ps -> IO (ps, IOSt ps)+windowStateControlSliderActionIO info (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsState=ls,wlsHandle=wH}))) windows ps ioState = do+    r <- windowControlSliderAction (\wH st ioState -> ioStSetDevice+						  (WindowSystemState+						      (setWindowHandlesWindow+							  (WindowStateHandle wids (Just (WindowLSHandle {wlsState=fst st,wlsHandle=wH})))+							  windows))+						  ioState) info wH (ls,ps) ioState+    let ((_,ps1),ioState) = r+    return (ps1,ioState)+    where+	  windowControlSliderAction :: (WindowHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+	  				ControlSliderInfo -> (WindowHandle ls ps) -> (ls,ps) -> IOSt ps -> IO ((ls,ps), IOSt ps)+	  windowControlSliderAction build info wH@(WindowHandle {whItems=itemHs}) ls_ps ioState = do+	  	r <- elementsControlSliderActionIO (\itemHs st ioState -> build wH{whItems=itemHs} st ioState) info itemHs ls_ps ioState+	  	let (_,ls_ps1, ioState) = r+		return (ls_ps1, ioState)+	        where+		  elementsControlSliderActionIO :: ([WElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IOSt ps) ->+		  				   ControlSliderInfo -> [WElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IO (Bool,(ls,ps),IOSt ps)+		  elementsControlSliderActionIO build info (itemH:itemHs) ls_ps ioState = do+			r <- elementControlSliderActionIO (\itemH st ioState -> build (itemH:itemHs) st ioState) info itemH ls_ps ioState+			let (done,ls_ps,ioState) = r+			(if done then return r+			 else elementsControlSliderActionIO (\itemHs st ioState -> build (itemH:itemHs) st ioState) info itemHs ls_ps ioState)+			where+			    elementControlSliderActionIO :: (WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+			    				    ControlSliderInfo -> (WElementHandle ls ps) -> (ls,ps) -> IOSt ps -> IO (Bool, (ls,ps), IOSt ps)+			    elementControlSliderActionIO build info itemH@(WItemHandle {wItemNr=wItemNr, wItemKind=wItemKind, wItems=itemHs}) ls_ps ioState+				  | (cslItemNr info) /= wItemNr =+					    if isRecursiveControl wItemKind then+						  elementsControlSliderActionIO (\itemHs st ioState -> build itemH{wItems=itemHs} st ioState) info itemHs ls_ps ioState+					    else return (False,ls_ps,ioState)+				  | otherwise = do+					    r <- itemControlSliderActionIO build info itemH ls_ps ioState+					    let (ls_ps,ioState) = r+					    return (True,ls_ps,ioState)+				  where+				    itemControlSliderActionIO :: (WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+				    				 ControlSliderInfo -> (WElementHandle ls ps) -> (ls,ps) -> IOSt ps -> IO ((ls,ps), IOSt ps)+				    itemControlSliderActionIO build info itemH@(WItemHandle {wItemKind=IsSliderControl, wItemInfo=wItemInfo}) ls_ps ioState = do+					fixIO (\st -> fromGUI (f ls_ps) (build itemH (fst st) ioState))+					where+						f = sliderInfoAction (getWItemSliderInfo wItemInfo) (cslSliderMove info)+				    itemControlSliderActionIO _ _ itemH ls_ps ioState = return (ls_ps, ioState)++			    elementControlSliderActionIO build info (WListLSHandle itemHs) ls_ps ioState = do+				  elementsControlSliderActionIO (\itemHs st ioState -> build (WListLSHandle itemHs) st ioState) info itemHs ls_ps ioState++			    elementControlSliderActionIO build info (WExtendLSHandle extLS itemHs) (ls,ps) ioState = do+				  r <- elementsControlSliderActionIO (\itemHs st ioState -> build (WExtendLSHandle (fst (fst st)) itemHs) (snd (fst st), snd st) ioState) info itemHs ((extLS,ls),ps) ioState+				  let (done,((_,ls1),ps1),ioState) = r+				  return (done,(ls1,ps1),ioState)++			    elementControlSliderActionIO build info (WChangeLSHandle chLS itemHs) (ls,ps) ioState = do+				  r <- elementsControlSliderActionIO (\itemHs st ioState -> build (WChangeLSHandle (fst st) itemHs) (ls,snd st) ioState) info itemHs (chLS,ps) ioState+				  let (done,(_,ps1),ioState) = r+				  return (done,(ls,ps1),ioState)++		  elementsControlSliderActionIO _ _ _ ls_ps ioState = return (False,ls_ps,ioState)+windowStateControlSliderActionIO _ _ _ _ _+	= windowdeviceFatalError "windowStateControlSliderActionIO" "unexpected window placeholder"+++{-	windowStateActivationIO handles the activation of the window/dialog. -}++windowStateActivationIO :: WindowStateHandle ps -> WindowHandles ps -> ps -> IOSt ps -> IO (ps,IOSt ps)+windowStateActivationIO (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsState=ls,wlsHandle=wH}))) windows ps ioState = do+	r <- fixIO (\st -> fromGUI (f (ls,ps))+				   (ioStSetDevice+				       (WindowSystemState+					   (addWindowHandlesActiveWindow+					       (WindowStateHandle (wids {wActive=True})+								  (Just (wlsH {wlsState=fst (fst st)})))+					       windows))+				       ioState))	+	let ((_,ps1),ioState1) = r+	liftIO (when hasCaret (osCreateCaret (wPtr wids) cw ch >> osSetCaretPos (wPtr wids) (cx-ox) (cy-oy)))+	return (ps1,ioState1)+	where+		(hasAtt,att) = cselect isWindowActivate undefined (whAtts wH)+		f            = if hasAtt then getWindowActivateFun att else return+		(hasCaret,catt)           = cselect isWindowCaret undefined (whAtts wH)+		(Point2 cx cy,Size cw ch) = getWindowCaretAtt catt+		(Point2 ox oy)		  = windowOrigin (whWindowInfo wH)+windowStateActivationIO _ _ _ _+	= windowdeviceFatalError "windowStateActivationIO" "unexpected window placeholder"+++{-	windowStateDeactivationIO handles the deactivation of the window/dialog.+-}+windowStateDeactivationIO :: WindowStateHandle ps -> WindowHandles ps -> ps -> IOSt ps -> IO (ps,IOSt ps)+windowStateDeactivationIO (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsState=ls,wlsHandle=wH}))) windows ps ioState = do+	r <- fixIO (\st -> fromGUI (f (ls,ps))+				   (ioStSetDevice+				       (WindowSystemState+					  (setWindowHandlesWindow+					       (WindowStateHandle (wids {wActive=False})+								  (Just (wlsH {wlsState=fst (fst st)})))+					       windows))+				       ioState))+	let ((_,ps1),ioState1) = r+	liftIO (when hasCaret (osDestroyCaret (wPtr wids)))+	return (ps1,ioState1)+	where+		(hasAtt,att) = cselect isWindowDeactivate undefined (whAtts wH)+		f            = if hasAtt then getWindowDeactivateFun att else return+		(hasCaret,catt)           = cselect isWindowCaret undefined (whAtts wH)+		(Point2 cx cy,Size cw ch) = getWindowCaretAtt catt+windowStateDeactivationIO _ _ _ _+	= windowdeviceFatalError "windowStateDeactivationIO" "unexpected window placeholder"+++{-	windowStateInitialiseIO handles the initialisation of the window/dialog.  -}++windowStateInitialiseIO :: WindowStateHandle ps -> WindowHandles ps -> ps -> IOSt ps -> IO (ps,IOSt ps)+windowStateInitialiseIO (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsState=ls,wlsHandle=wH}))) windows ps ioState+	= do {+		r <- fixIO (\st -> fromGUI (f (ls,ps))+		                           (ioStSetDevice+		                               (WindowSystemState+		                                   (setWindowHandlesWindow+		                                       (WindowStateHandle wids (Just (wlsH {wlsState=fst (fst st),wlsHandle=wH1})))+		                                       windows))+		                               ioState));+		let ((_,ps1),ioState1) = r+		in  return (ps1,ioState1)+	  }+	where+		(hasAtt,initAtt,atts) = remove isWindowInit undefined (whAtts wH)+		f                     = if hasAtt then getWindowInitFun initAtt else return+		wH1                   = wH {whAtts=atts}+windowStateInitialiseIO _ _ _ _+	= windowdeviceFatalError "windowStateInitialiseIO" "unexpected window placeholder"+++{-	windowStateWindowKeyboardActionIO handles the keyboard for the window. -}++windowStateWindowKeyboardActionIO :: WindowKeyboardActionInfo -> WindowStateHandle ps -> WindowHandles ps -> ps -> IOSt ps -> IO (ps, IOSt ps)+windowStateWindowKeyboardActionIO info (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsState=ls,wlsHandle=wH}))) windows ps ioState	+	= do {+		r <- fixIO (\st -> fromGUI (f (wkKeyboardState info) (ls,ps))+					   (ioStSetDevice+					       (WindowSystemState+						   (setWindowHandlesWindow+						       (WindowStateHandle wids (Just (wlsH {wlsState=fst (fst st)})))+						       windows))+					       ioState));+		let ((_,ps1),ioState1) = r;+		in return (ps1,ioState1)+	}+	where+		(_,_,f) = getWindowKeyboardAtt (snd (cselect isWindowKeyboard undefined (whAtts wH)))+windowStateWindowKeyboardActionIO _ _ _ _ _+	= windowdeviceFatalError "windowStateWindowKeyboardActionIO" "unexpected window placeholder"+++{- windowStateWindowMouseActionIO handles the mouse for the window. -}++windowStateWindowMouseActionIO :: WindowMouseActionInfo -> WindowStateHandle ps -> WindowHandles ps -> ps -> IOSt ps -> IO (ps, IOSt ps)+windowStateWindowMouseActionIO info (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsState=ls,wlsHandle=wH}))) windows ps ioState+	= do {+		r <- fixIO (\st -> fromGUI (f (wmMouseState info) (ls,ps))+					   (ioStSetDevice+		                               (WindowSystemState+		                                   (setWindowHandlesWindow+		                                       (WindowStateHandle wids (Just (wlsH {wlsState=fst (fst st)})))+		                                       windows))+		                               ioState));+		let ((_,ps1),ioState1) = r;+		in return (ps1,ioState1)+	}+	where+		(_,_,f) = getWindowMouseAtt (snd (cselect isWindowMouse undefined (whAtts wH)))+windowStateWindowMouseActionIO _ _ _ _ _+	= windowdeviceFatalError "windowStateWindowMouseActionIO" "unexpected window placeholder"+++{-	windowButtonActionIO id wH st+		evaluates the button function of the (Custom)ButtonControl associated with id.+	This function is used by windowStateCANCELIO and windowStateOKIO.+-}++windowButtonActionIO :: (WindowHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+			Id -> WindowHandle ls ps -> (ls,ps) -> IOSt ps -> IO ((ls,ps), IOSt ps)+windowButtonActionIO build buttonId wH@(WindowHandle {whItems=itemHs}) ls_ps ioState = do+    r <- elementsButtonActionIO (\itemHs st ioState -> build wH{whItems=itemHs} st ioState) buttonId itemHs ls_ps ioState+    let (_,ls_ps1,ioState) = r+    return (ls_ps1,ioState)+    where	+	elementsButtonActionIO :: ([WElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IOSt ps) -> +				  Id -> [WElementHandle ls ps] -> (ls,ps) -> IOSt ps -> IO (Bool,(ls,ps),IOSt ps)+	elementsButtonActionIO build id (itemH:itemHs) ls_ps ioState = do+	    r <- elementButtonActionIO (\itemH st ioState -> build (itemH:itemHs) st ioState) id itemH ls_ps ioState+	    let (done,ls_ps1,ioState) = r+   	    (if done then return r+ 	     else elementsButtonActionIO (\itemHs st ioState -> build (itemH:itemHs) st ioState) id itemHs ls_ps1 ioState)+	    where+		elementButtonActionIO :: (WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IOSt ps) ->+					 Id -> WElementHandle ls ps -> (ls,ps) -> IOSt ps -> IO (Bool,(ls,ps),IOSt ps)+		elementButtonActionIO build id itemH@(WItemHandle {wItemId=itemId,wItemKind=kind,wItemAtts=atts,wItems=itemHs}) ls_ps ioState+			| isNothing itemId || fromJust itemId /= id =+				if not (isRecursiveControl (wItemKind itemH)) then+					return (False,ls_ps,ioState)+				else elementsButtonActionIO (\itemHs st ioState -> build itemH{wItems=itemHs} st ioState) id itemHs ls_ps ioState+			| kind /= IsButtonControl && kind /= IsCustomButtonControl =+				windowdeviceFatalError "windowButtonActionIO" "Id argument does not refer to (Custom)ButtonControl"+			| hasFunAtt = do+				r <- fixIO (\st -> fromGUI (getControlFun fAtt ls_ps) (build itemH (fst st) ioState))+				let (ls_ps1, ioState) = r+				return (True,ls_ps1,ioState)+			| otherwise =+				return (True,ls_ps,ioState)+			where+				(hasFunAtt,fAtt) = cselect isControlFunction undefined atts++		elementButtonActionIO build id (WListLSHandle itemHs) ls_ps ioState = do+			elementsButtonActionIO (\itemHs st ioState -> build (WListLSHandle itemHs) st ioState) id itemHs ls_ps ioState++		elementButtonActionIO build id (WExtendLSHandle exLS itemHs) (ls,ps) ioState = do+			r <- elementsButtonActionIO (\itemHs st ioState -> build (WExtendLSHandle (fst (fst st)) itemHs) (snd (fst st), snd st) ioState) id itemHs ((exLS,ls),ps) ioState+			let (done,((_,ls1),ps1),ioState) = r+			return (done,(ls1,ps1),ioState)++		elementButtonActionIO build info (WChangeLSHandle chLS itemHs) (ls,ps) ioState = do+			r <- elementsButtonActionIO (\itemHs st ioState -> build (WChangeLSHandle (fst st) itemHs) (ls,snd st) ioState) info itemHs (chLS,ps) ioState+			let (done,(_,ps1),ioState) = r+			return (done,(ls,ps1),ioState)+	+	elementsButtonActionIO _ _ _ ls_ps ioState = return (False,ls_ps,ioState)++{-	windowStateCANCELIO handles the evaluation of the Cancel button. -}++windowStateCANCELIO :: WindowStateHandle ps -> WindowHandles ps -> ps -> IOSt ps -> IO (ps, IOSt ps)+windowStateCANCELIO (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsState=ls,wlsHandle=wH}))) windows ps ioState =+	case whCancelId wH of+		Just id -> do+			r <- windowButtonActionIO (\wH st ioState -> ioStSetDevice+						  (WindowSystemState+						      (setWindowHandlesWindow+							  (WindowStateHandle wids (Just (WindowLSHandle {wlsState=fst st,wlsHandle=wH})))+							  windows))+						  ioState) id wH (ls,ps) ioState+			let ((_, ps1), ioState) = r+			return (ps1, ioState)+		Nothing -> windowdeviceFatalError "windowStateCANCELIO" "no Cancel button administrated"	+windowStateCANCELIO _ _ _ _+	= windowdeviceFatalError "windowStateCANCELIO" "unexpected window placeholder"+	+{-	windowStateOKIO handles the evaluation of the Ok button. -}++windowStateOKIO :: WindowStateHandle ps -> WindowHandles ps -> ps -> IOSt ps -> IO (ps, IOSt ps)+windowStateOKIO (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsState=ls,wlsHandle=wH}))) windows ps ioState =+	case whDefaultId wH of+		Just id -> do+			r <- windowButtonActionIO (\wH st ioState -> ioStSetDevice+						  (WindowSystemState+						      (setWindowHandlesWindow+							  (WindowStateHandle wids (Just (WindowLSHandle {wlsState=fst st,wlsHandle=wH})))+							  windows))+						  ioState) id wH (ls,ps) ioState+			let ((_, ps1), ioState) = r+			return (ps1, ioState)+		Nothing -> windowdeviceFatalError "windowStateOKIO" "no Ok button administrated"+windowStateOKIO _ _ _ _+	= windowdeviceFatalError "windowStateOKIO" "unexpected window placeholder"+++{-	windowStateRequestCloseIO handles the request to close the window/dialog.  -}++windowStateRequestCloseIO :: WindowStateHandle ps -> WindowHandles ps -> ps -> IOSt ps -> IO (ps,IOSt ps)+windowStateRequestCloseIO (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsState=ls,wlsHandle=wH}))) windows ps ioState+	= do {+		r <- fixIO (\st -> fromGUI (f (ls,ps))+		                           (ioStSetDevice+		                               (WindowSystemState+		                                   (setWindowHandlesWindow+		                                       (WindowStateHandle wids (Just (wlsH {wlsState=fst (fst st)})))+		                                       windows))+		                               ioState));+		let ((_,ps1),ioState1) = r+		in  return (ps1,ioState1)+	  }+	where+		(hasAtt,closeAtt) = cselect isWindowClose undefined (whAtts wH)+		f                 = if hasAtt then getWindowCloseFun closeAtt else return+windowStateRequestCloseIO _ _ _ _+	= windowdeviceFatalError "windowStateRequestCloseIO" "unexpected window placeholder"+++{-	windowStateScrollActionIO handles the mouse action of window scrollbars. -}++windowStateScrollActionIO :: OSWindowMetrics -> WindowScrollActionInfo -> WindowStateHandle ps -> IO (WindowStateHandle ps)+windowStateScrollActionIO wMetrics info (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) = do+    wH <- windowScrollActionIO wMetrics info wH+    return (WindowStateHandle wids (Just wlsH{wlsHandle=wH}))+    where+	windowScrollActionIO :: OSWindowMetrics -> WindowScrollActionInfo -> WindowHandle ls ps -> IO (WindowHandle ls ps)+	windowScrollActionIO wMetrics info@(WindowScrollActionInfo {wsaWIDS=WIDS{wPtr=wPtr}}) wH@(WindowHandle {whItems=oldItems,whSize=whSize,whAtts=whAtts,whSelect=whSelect,whShow=whShow})+	    | newThumb==oldThumb = return wH+	    | otherwise = do+		let (_,newOSThumb,_,_) = toOSscrollbarRange (min',newThumb,max') viewSize+		let newOrigin	       = if isHorizontal then oldOrigin{x=newThumb} else oldOrigin{y=newThumb}+		osSetWindowSliderThumb wMetrics wPtr isHorizontal newOSThumb (toTuple whSize) True+		liftIO (when hasCaret (osSetCaretPos wPtr (x caretPos - x newOrigin) (y caretPos - y newOrigin)))+		(_,newItems) <- layoutControls wMetrics hMargins vMargins spaces contentSize minSize [(domain,newOrigin)] oldItems+		let wH1 = wH{whWindowInfo = windowInfo{windowOrigin=newOrigin}, whItems = newItems}+		wH2 <- forceValidWindowClipState wMetrics True wPtr wH1+		(isRect,areaRect) <- case whWindowInfo wH2 of+			WindowInfo {windowClip=ClipState{clipRgn=clipRgn}} -> osGetRgnBox clipRgn			+		updRgn <- relayoutControls wMetrics whSelect whShow contentRect contentRect zero zero wPtr (whDefaultId wH) oldItems (whItems wH2)+		wH3 <- updateWindowBackgrounds wMetrics updRgn (wsaWIDS info) wH2+		let newFrame = posSizeToRectangle newOrigin contentSize+		let toMuch = if isHorizontal then abs((x newOrigin)-(x oldOrigin))>=w' else abs ((y newOrigin)-(y oldOrigin))>=h'+		let (updArea,updAction)	= if (not (lookSysUpdate lookInfo) || toMuch || not isRect)+					  then (newFrame,return [])+					  else calcScrollUpdateArea oldOrigin newOrigin areaRect+		let updState = UpdateState{oldFrame=oldFrame,newFrame=newFrame,updArea=[updArea]}+		drawWindowLook' wMetrics wPtr updAction updState wH3+	    where+		windowInfo				= whWindowInfo wH+		(oldOrigin,domainRect,hasHScroll,hasVScroll,lookInfo)+							= (windowOrigin windowInfo,windowDomain windowInfo,isJust (windowHScroll windowInfo),isJust (windowVScroll windowInfo),windowLook windowInfo)+		isHorizontal				= wsaDirection info==Horizontal+		domain					= rectToRectangle domainRect+		visScrolls				= osScrollbarsAreVisible wMetrics domainRect (toTuple whSize) (hasHScroll,hasVScroll)+		contentRect				= getWindowContentRect wMetrics visScrolls (sizeToRect whSize)+		contentSize				= rectSize contentRect+		Size{w=w',h=h'}				= contentSize+		oldFrame				= posSizeToRectangle oldOrigin contentSize+		(min',oldThumb,max',viewSize)		= if isHorizontal+							  then (x (corner1 domain),x oldOrigin,x (corner2 domain),w')+							  else (y (corner1 domain),y oldOrigin,y (corner2 domain),h')+		sliderState				= SliderState{sliderMin=min',sliderThumb=oldThumb,sliderMax=max'-viewSize}+		scrollInfo				= fromJust ((if isHorizontal then windowHScroll else  windowVScroll) windowInfo)+		scrollFun				= scrollFunction scrollInfo+		newThumb'				= scrollFun oldFrame sliderState (wsaSliderMove info)+		newThumb				= setBetween newThumb' min' (max'-viewSize)+		(defMinW,  defMinH)			= osMinWindowSize+		minSize					= Size{w=defMinW,h=defMinH}+		hMargins				= getWindowHMargins   IsWindow wMetrics whAtts+		vMargins				= getWindowVMargins   IsWindow wMetrics whAtts+		spaces					= getWindowItemSpaces IsWindow wMetrics whAtts+		(hasCaret,catt)           		= cselect isWindowCaret undefined whAtts+		(caretPos,_) 				= getWindowCaretAtt catt+		+	{-	calcScrollUpdateArea p1 p2 area calculates the new Rectangle 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,+		             scrolling occurs either horizontally or vertically.+	-}+		calcScrollUpdateArea :: Point2 -> Point2 -> Rect -> (Rectangle,Draw [Rect])+		calcScrollUpdateArea oldOrigin newOrigin areaRect =+			(updArea,scroll newOriginAreaRect{rright=rright+1,rbottom=rbottom+1} restArea v)+			where+				newOriginAreaRect		= addVector (toVector newOrigin) areaRect+				Rect{rleft=rleft,rtop=rtop,rright=rright,rbottom=rbottom} = newOriginAreaRect+				newOriginAreaRectangle		= rectToRectangle newOriginAreaRect+				v				= toVector (oldOrigin-newOrigin)+				Vector2{vx=vx,vy=vy}		= v+				(updArea,restArea)		= +					if (vx<0) then (newOriginAreaRectangle{corner1=Point2{x=rright+vx,y=rtop}},      newOriginAreaRect{rright =rright +vx}) else+					if (vx>0) then (newOriginAreaRectangle{corner2=Point2{x=rleft +vx,y=rbottom}},   newOriginAreaRect{rleft  =rleft  +vx}) else+					if (vy<0) then (newOriginAreaRectangle{corner1=Point2{x=rleft,    y=rbottom+vy}},newOriginAreaRect{rbottom=rbottom+vy}) else+					if (vy>0) then (newOriginAreaRectangle{corner2=Point2{x=rright,   y=rtop+vy}},   newOriginAreaRect{rtop   =rtop   +vy}) else+						       (windowdeviceFatalError "calcScrollUpdateArea (scrolling window)" "assumption violation")+			+				scroll :: Rect -> Rect -> Vector2 -> Draw [Rect]+				scroll scrollRect restRect v = do+					updRect <- pictScroll scrollRect v+					return (if updRect == zero then [] else [restRect])+				 ++windowStateScrollActionIO _ _ _+	= windowdeviceFatalError "windowStateScrollActionIO" "unexpected window placeholder"+++{-	windowStateSizeAction handles resizing a window and its controls. -}++windowStateSizeAction :: OSWindowMetrics -> Bool -> WindowSizeActionInfo -> WindowStateHandle ps -> ps -> GUI ps (WindowStateHandle ps, ps)+windowStateSizeAction wMetrics isActive info@(WindowSizeActionInfo {wsWIDS=WIDS{wPtr=wPtr},wsSize=wsSize,wsUpdateAll=wsUpdateAll}) (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsState=ls,wlsHandle=wH}))) ps =+    let +  	visOldScrolls 	= osScrollbarsAreVisible wMetrics domainRect oldSize' (hasHScroll,hasVScroll)+	oldContent	= getWindowContentRect wMetrics visOldScrolls (sizeToRect oldSize)+	oldContentSize	= rectSize oldContent+	visNewScrolls	= osScrollbarsAreVisible wMetrics domainRect newSize' (hasHScroll,hasVScroll)+	newContent	= getWindowContentRect wMetrics visNewScrolls (sizeToRect wsSize)+	newContentSize	= rectSize newContent+	newOrig		= newOrigin oldOrig domainRect newContentSize+	newWindowInfo	= windowInfo{windowOrigin=newOrig}+	resizedAtt	= WindowViewSize newContentSize+	(replaced,atts)	= creplace isWindowViewSize resizedAtt (whAtts wH)+	resizedAtts	= if replaced then atts else (resizedAtt:atts)+	wH1		= wH{whSize=wsSize,whWindowInfo=newWindowInfo,whAtts=resizedAtts}+    in do+    	(ls,ps) <- getWindowResizeAtt resizeAtt oldSize wsSize (ls,ps)+	liftIO (setWindowScrollThumbValues hasHScroll wMetrics wPtr True  ((w newContentSize)+1) (x oldOrig) (x newOrig) newSize')+	liftIO (setWindowScrollThumbValues hasVScroll wMetrics wPtr False ((h newContentSize)+1) (y oldOrig) (y newOrig) newSize')+	wH <- liftIO (resizeControls wMetrics isActive wsUpdateAll (wsWIDS info) oldOrig oldContentSize newContentSize wH1)+	return (WindowStateHandle wids (Just wlsH{wlsState=ls,wlsHandle=wH}),ps)+    where+	oldSize				= whSize wH+	oldSize'			= toTuple oldSize+	newSize'			= toTuple wsSize+	windowInfo			= whWindowInfo wH+	(oldOrig,domainRect,hasHScroll,hasVScroll) = (windowOrigin windowInfo,windowDomain windowInfo,isJust (windowHScroll windowInfo),isJust (windowVScroll windowInfo))+	+	(_,resizeAtt) = cselect isWindowResize (WindowResize (\_ _ -> return)) (whAtts wH)	+	+	newOrigin :: Point2 -> Rect -> Size -> Point2+	newOrigin (Point2 {x=x,y=y}) (Rect {rleft=rleft,rtop=rtop,rright=rright,rbottom=rbottom}) (Size{w=w,h=h})+		= Point2 {x=x',y=y'}+		where+			x' = if x+w > rright  then max (rright-w) rleft else x+			y' = if y+h > rbottom then max (rbottom-h) rtop else y+	+	setWindowScrollThumbValues :: Bool -> OSWindowMetrics -> OSWindowPtr -> Bool -> Int -> Int -> Int -> (Int,Int) -> IO ()+	setWindowScrollThumbValues hasScroll wMetrics wPtr isHorizontal size old new maxcoords+		| not hasScroll	= return ()+		| otherwise = do+			osSetWindowSliderThumbSize wMetrics wPtr isHorizontal size maxcoords (old==new)+			(if old==new then return ()+			 else osSetWindowSliderThumb wMetrics wPtr isHorizontal new maxcoords True)+windowStateSizeAction _ _ _ _ _+	= windowdeviceFatalError "windowIO _ (WindowSizeAction _) _" "unexpected placeholder argument"++--	Auxiliary function (move to CommonDef??):+selectedAtIndex :: Cond x -> x -> [x] -> (Index, x)		-- if index==0 then not found; item was found at index+selectedAtIndex cond dummy xs+	= (if found then i else 0,x)+	where+		(found,i,x) = selected cond dummy xs 1++		selected :: Cond x -> x -> [x] -> Int -> (Bool,Int,x)+		selected cond dummy (x:xs) i+			| cond x    = (True,i,x)+			| otherwise = selected cond dummy xs (i+1)+		selected _ dummy _ i+			= (False,i,dummy)
+ Graphics/UI/ObjectIO/Window/Dispose.hs view
@@ -0,0 +1,205 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Window.Dispose+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Window.Dispose disposes all system resources associated with the+-- indicated window if it exists.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Window.Dispose+		( disposeWindow+		, disposeWindowStateHandle+		, disposeWElementHandle+		) where+++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Control.Validate+import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.Process.Scheduler+import Graphics.UI.ObjectIO.Window.Access+import Graphics.UI.ObjectIO.Window.Handle+import Graphics.UI.ObjectIO.Window.Create(bufferDelayedEvents)+import Graphics.UI.ObjectIO.Window.ClipState(disposeClipState)+import Graphics.UI.ObjectIO.OS.Window+import qualified Data.Map as Map+++windowdisposeFatalError :: String -> String -> x+windowdisposeFatalError function error+	= dumpFatalError function "WindowDispose" error+++{-	disposeWindow disposes all system resources associated with the indicated window if it exists.+	Inactive modal dialogues are not removed.+	If the window belongs to an SDI process, then only the SDI client is removed, not the SDI frame.+	It removes the indicated window from the window device administration.+	Because the window may contain controls that are 'logically' disposed, but not 'physically'+	disposeWindow also applies the init function contained in the IOSt.+-}+disposeWindow :: WID -> ps -> GUI ps ps+disposeWindow wid ps+	= do {+		(found,wDevice) <- accIOEnv (ioStGetDevice WindowDevice);+		if   not found+		then return ps+		else let+			windows               = windowSystemStateGetWindowHandles wDevice+			(found,wsH,windows1)  = getWindowHandlesWindow wid windows+		in+		if   not found                -- The window could not be found+		then appIOEnv (ioStSetDevice (WindowSystemState windows1)) >> return ps+		else+		if   getWindowStateHandleClosing wsH -- The window is already in the act of being closed+		then appIOEnv (ioStSetDevice (WindowSystemState (setWindowHandlesWindow wsH windows1))) >> return ps+		else let                      -- Any modeless window can be disposed+			wKind = getWindowStateHandleWindowKind wsH+			wids  = getWindowStateHandleWIDS wsH+		in do {+		        xDI <- accIOEnv ioStGetDocumentInterface;+			-- Of a SDI process, the SDI client should be closed, not the SDI frame (which is closed by closeProcess)+		        if   xDI==SDI && wKind==IsWindow+		        then dispose wids wsH (incWindowBound windows1) ps+		        else dispose wids wsH windows1 ps+		   }+	  }+	where+		incWindowBound :: WindowHandles ps -> WindowHandles ps+		incWindowBound wHs@(WindowHandles {whsNrWindowBound=whsNrWindowBound})+			= wHs {whsNrWindowBound=incBound whsNrWindowBound}++		dispose :: WIDS -> WindowStateHandle ps -> WindowHandles ps -> ps -> GUI ps ps+		dispose wids@(WIDS {wId=wId}) wsH windows ps+			= do {+				disposeFun    <-  accIOEnv ioStGetInitIO;+				ps1  <- disposeFun ps;+				osdinfo       <-  accIOEnv ioStGetOSDInfo;+				oldInputTrack <-  ioStGetInputTrack;+				(ids,delayinfo,finalLS,inputTrack,ps2) <- disposeWindowStateHandle osdinfo oldInputTrack wsH ps1;+				ioStSetInputTrack inputTrack;+				idtable      <- ioStGetIdTable;+				ioStSetIdTable (foldr Map.delete idtable ids);+				(let windows2 = windows1{whsFinalModalLS=finalLS++(whsFinalModalLS windows1)}+				 in appIOEnv (ioStSetDevice (WindowSystemState windows2)));+				bufferDelayedEvents delayinfo;+				return ps2+			  }+			where+				(_,_,windows1)    = removeWindowHandlesWindow (toWID wId) windows	-- Remove window placeholder+++{-	disposeWindowStateHandle disposes all system resources associated with the given WindowStateHandle.+	The return [Id] are the Ids of the other controls.+	When timers are part of windows, also timer ids should be returned.+-}++disposeWindowStateHandle :: OSDInfo -> Maybe InputTrack -> WindowStateHandle ps -> ps -> GUI ps ([Id], [DelayActivationInfo], [FinalModalLS], Maybe InputTrack, ps)+disposeWindowStateHandle osdinfo oldInputTrack (WindowStateHandle wids (Just wlsH@(WindowLSHandle {wlsState=ls, wlsHandle=wH@(WindowHandle {whKind=whKind, whMode=whMode})}))) ps+	= do		+		(ids,fs) <- liftIO (disposeWElementHandles (wPtr wids) (whItems wH))+		liftIO fs+		(delayInfo,ps) <- liftContextIO (\context -> osDestroyWindow osdinfo (whMode==Modal) (whKind==IsWindow) (wPtr wids) (handleContextOSEvent context)) ps+		let finalModalLS  = if whKind==IsDialog && whMode==Modal then [FinalModalLS wids ls] else []+		let newInputTrack =+			case oldInputTrack of+			  Just (InputTrack{itWindow=itWindow}) ->+			  		if itWindow==(wPtr wids) then Nothing else oldInputTrack+	  		  Nothing -> Nothing+		return ((wId wids):ids, delayInfo, finalModalLS, newInputTrack, ps)++disposeWindowStateHandle _ _ _ _+	= windowdisposeFatalError "disposeWindowStateHandle" "window expected instead of placeholder"+	+	+{-	disposeWElementHandle(s) (recursively) hides all system resources associated with the given+	WElementHandle(s). The argument OSWindowPtr must be the parent window.+	The (IO ()) action must be used to actually dispose the controls.+	It returns all freed receiver and control ids.+	When timers are part of windows, also timer ids should be returned.+-}+disposeWElementHandles :: OSWindowPtr -> [WElementHandle ls ps] -> IO ([Id],IO ())+disposeWElementHandles wptr (itemH:itemHs)+	= do {+		(ids, fs)  <- disposeWElementHandle  wptr itemH;+		(idss,fss) <- disposeWElementHandles wptr itemHs;+		return (ids++idss,fs>>fss)+	  }+disposeWElementHandles _ []+	= return ([],return ())++{-	disposeWElementHandle (recursively) hides all system resources associated with the given WItemHandle.+	The OSWindowPtr argument must identify the parent window.+	The (IO ()) function must be used to actually dispose the controls.+	It returns all freed ids.+	When timers are part of windows, also timer ids should be returned.+-}+disposeWElementHandle :: OSWindowPtr -> WElementHandle ls ps -> IO ([Id],IO ())+disposeWElementHandle wptr (WExtendLSHandle _ itemHs)+	= disposeWElementHandles wptr itemHs+disposeWElementHandle wptr (WChangeLSHandle _ itemHs)+	= disposeWElementHandles wptr itemHs+disposeWElementHandle wptr (WListLSHandle itemHs)+	= disposeWElementHandles wptr itemHs++disposeWElementHandle wPtr itemH@(WItemHandle {wItemKind=IsCheckControl, wItemInfo=wItemInfo, wItemId=wItemId}) =+	let checkInfo = getWItemCheckInfo wItemInfo+	    items = checkItems checkInfo++	    show CheckItemInfo{checkItemPtr=checkItemPtr, checkItemPos=checkItemPos, checkItemSize=checkItemSize} _ =+	    	osSetCheckControlShow wPtr checkItemPtr (posSizeToRect checkItemPos checkItemSize) False++	    destroy CheckItemInfo{checkItemPtr=checkItemPtr} _ =+	    	osDestroyCheckControl checkItemPtr+	in do+		foldrM show () items+		return (maybeToList wItemId,foldrM destroy () items)++disposeWElementHandle wPtr itemH@(WItemHandle {wItemKind=IsCompoundControl}) = do+	(idss,fs) <- disposeWElementHandles wPtr (wItems itemH)+	let ids	= maybeToList (wItemId itemH) ++ idss+	let info = getWItemCompoundInfo (wItemInfo itemH)+	let itemPtr = wItemPtr itemH+	osSetCompoundShow wPtr itemPtr (posSizeToRect (wItemPos itemH) (wItemSize itemH)) False+	return (ids,fs >> osDestroyCompoundControl itemPtr >> disposeClipState (compoundClip (compoundLookInfo info)))++disposeWElementHandle wPtr itemH@(WItemHandle {wItemKind=IsLayoutControl, wItems=wItems}) =+	disposeWElementHandles wPtr wItems++disposeWElementHandle wPtr itemH@(WItemHandle {wItemKind=IsRadioControl, wItemInfo=wItemInfo, wItemId=wItemId}) =+	let radioInfo = getWItemRadioInfo wItemInfo+	    items = radioItems radioInfo++	    show RadioItemInfo{radioItemPtr=radioItemPtr,radioItemPos=radioItemPos,radioItemSize=radioItemSize} _ =+		osSetRadioControlShow wPtr radioItemPtr (posSizeToRect radioItemPos radioItemSize) False++	    destroy RadioItemInfo{radioItemPtr=radioItemPtr} _ =+	     	osDestroyRadioControl radioItemPtr+	in do+		foldrM show () items+		return (maybeToList wItemId,foldrM destroy () items)++disposeWElementHandle wPtr itemH@(WItemHandle {wItemKind=IsReceiverControl, wItemId=wItemId}) =+	return (maybeToList wItemId,return ())++disposeWElementHandle wptr (WItemHandle {wItemKind=wItemKind,wItemId=wItemId,wItemPtr=wItemPtr,wItemPos=wItemPos,wItemSize=wItemSize})+	= hide wptr wItemPtr (posSizeToRect wItemPos wItemSize) False >> return (maybeToList wItemId,dispose wItemPtr)+	where+		(hide,dispose)	= case wItemKind of+					IsPopUpControl	-> (osSetPopUpControlShow,  osDestroyPopUpControl)+					IsListBoxControl-> (osSetListBoxControlShow,osDestroyListBoxControl)+					IsSliderControl	-> (osSetSliderControlShow, osDestroySliderControl)+					IsTextControl   -> (osSetTextControlShow,   osDestroyTextControl)+					IsEditControl   -> (osSetEditControlShow,   osDestroyEditControl)+					IsButtonControl -> (osSetButtonControlShow, osDestroyButtonControl)+					IsCustomButtonControl	-> (osSetCustomButtonControlShow, osDestroyCustomButtonControl)+					IsCustomControl	-> (osSetCustomControlShow, osDestroyCustomControl)+					_               -> windowdisposeFatalError "disposeWItemHandle" ("unmatched ControlKind: "++show wItemKind)
+ Graphics/UI/ObjectIO/Window/Draw.hs view
@@ -0,0 +1,101 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Window.Draw+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Window.Draw contains the window drawing functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Window.Draw where+++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Control.Layout+import Graphics.UI.ObjectIO.StdPicture+import Graphics.UI.ObjectIO.Window.Access+import Graphics.UI.ObjectIO.OS.Picture+import Graphics.UI.ObjectIO.OS.Rgn+import Graphics.UI.ObjectIO.OS.Window+import Graphics.UI.ObjectIO.StdWindowAttribute(isWindowDoubleBuffered)+++{-	drawWindowLook wPtr includeBackground window+		applies the Look function of window.+	The wPtr argument must be the OSWindowPtr of window.+	It is assumed that window refers to a Window with a valid ClipState.+	If includeBackground is True then also the background outside the WindowViewDomain is drawn.+-}+drawWindowLook :: OSWindowMetrics -> OSWindowPtr -> Draw () -> UpdateState -> WindowHandle ls ps -> IO (WindowHandle ls ps)+drawWindowLook wMetrics wPtr drawFirst updState wH@(WindowHandle {whSelect=whSelect,whSize=whSize,whWindowInfo=info,whAtts=attrs}) = do+    osPict <- osGrabWindowPictContext wPtr    +    (_,_,pen,_) <- doDraw origin (lookPen look) True clip' osPict (any isWindowDoubleBuffered attrs) draw+    osReleaseWindowPictContext wPtr osPict+    osValidateWindowRgn wPtr clip' 		-- PA: added to eliminate update of window (in drawing part)	+    return (wH{whWindowInfo=info{windowLook=look{lookPen=pen}}})+    where+        draw = drawFirst >> accClipPicture (toRegion (if lookSysUpdate look then updArea updState else [wFrame])) (lookFun look select updState)+           +	select		= if whSelect then Able else Unable+	domainRect	= windowDomain info+	origin		= windowOrigin info+	look		= windowLook info+	clip		= windowClip info+	clip'		= clipRgn clip+	hasScrolls	= (isJust (windowHScroll info),isJust (windowVScroll info))+	visScrolls	= osScrollbarsAreVisible wMetrics domainRect (toTuple whSize) hasScrolls+	Size {w=w,h=h}	= rectSize (getWindowContentRect wMetrics visScrolls (sizeToRect whSize))+	wFrame		= Rectangle{corner1=origin,corner2=Point2{x=x origin + w,y=y origin + h}}+++drawWindowLook' :: OSWindowMetrics -> OSWindowPtr -> Draw [Rect] -> UpdateState -> WindowHandle ls ps -> IO (WindowHandle ls ps)+drawWindowLook' wMetrics wPtr drawFirst updState wH@(WindowHandle {whSelect=whSelect,whSize=whSize,whWindowInfo=info,whAtts=attrs}) = do+    osPict <- osGrabWindowPictContext wPtr    +    (_,_,pen,_) <- doDraw origin (lookPen look) True clip' osPict (any isWindowDoubleBuffered attrs) draw+    osReleaseWindowPictContext wPtr osPict+    osValidateWindowRgn wPtr clip' 		-- PA: added to eliminate update of window (in drawing part)	+    return (wH{whWindowInfo=info{windowLook=look{lookPen=pen}}})+    where+        draw = do+            additionalUpdateArea <- drawFirst+            let updState1 = updState{updArea = [rectToRectangle r | r<-additionalUpdateArea, not (isEmptyRect r)] ++ (updArea updState)}+            accClipPicture (toRegion (if lookSysUpdate look then updArea updState1 else [wFrame])) (lookFun look select updState1)+            return ()+        +	select		= if whSelect then Able else Unable+	domainRect	= windowDomain info+	origin		= windowOrigin info+	look		= windowLook info+	clip		= windowClip info+	clip'		= clipRgn clip+	hasScrolls	= (isJust (windowHScroll info),isJust (windowVScroll info))+	visScrolls	= osScrollbarsAreVisible wMetrics domainRect (toTuple whSize) hasScrolls+	Size {w=w,h=h}	= rectSize (getWindowContentRect wMetrics visScrolls (sizeToRect whSize))+	wFrame		= Rectangle{corner1=origin,corner2=Point2{x=x origin + w,y=y origin + h}}+++{-	drawInWindow wPtr drawfun window+		applies the drawing function to the picture of the window.+	The wPtr argument must be the OSWindowPtr of the window.+	It is assumed that window refers to a Window with a valid ClipState.+-}+drawInWindow :: OSWindowMetrics -> OSWindowPtr -> Draw a -> (WindowHandle ls ps) -> IO (a, WindowHandle ls ps)+drawInWindow wMetrics wPtr drawFun wH@(WindowHandle {whSize=whSize,whWindowInfo=info,whAtts=attrs}) = do+    domainRgn <- osNewRectRgn contentRect+    clip <- osSectRgn domainRgn (clipRgn (windowClip info))+    osPict <- osGrabWindowPictContext wPtr    +    (x,_,pen,_) <- doDraw (windowOrigin info) (lookPen look) True clip osPict (any isWindowDoubleBuffered attrs) drawFun+    osReleaseWindowPictContext wPtr osPict+    mapM_ osDisposeRgn [domainRgn,clip]+    return (x,wH{whWindowInfo=info{windowLook=look{lookPen=pen}}})+    where+	look		= windowLook info+	hasScrolls	= (isJust (windowHScroll info),isJust (windowVScroll info))+	visScrolls	= osScrollbarsAreVisible wMetrics (windowDomain info) (toTuple whSize) hasScrolls+	contentRect	= getWindowContentRect wMetrics visScrolls (sizeToRect whSize)
+ Graphics/UI/ObjectIO/Window/Handle.hs view
@@ -0,0 +1,316 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Window.Handle+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Window.Handle contains the internal data structures that represent the +-- state of windows. +--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Window.Handle+		( ControlState, WindowHandles(..)+		, Graphics.UI.ObjectIO.CommonDef.Bound(..), WindowStateHandle(..), WIDS(..)+		, WindowLSHandle(..)+		, ScrollInfo(..),  ClipState(..)+		, WindowHandle(..), WindowKind(..), WindowMode(..)+		, WElementHandle(..)+		, LayoutInfo(..), WItemInfo(..)+		, RadioInfo(..), RadioItemInfo(..), CheckInfo(..)+		, CheckItemInfo(..), PopUpInfo(..), PopUpEditInfo(..), ListBoxInfo(..)+		, SliderInfo(..), ButtonInfo(..), EditInfo(..), TextInfo(..)+		, ControlKind(..), FinalModalLS(..)+		, wElementHandleToControlState, controlStateToWElementHandle+		, Graphics.UI.ObjectIO.OS.Picture.OSPictContext+		, Graphics.UI.ObjectIO.OS.Picture.Origin+		, Graphics.UI.ObjectIO.OS.Picture.Pen(..)+		, Graphics.UI.ObjectIO.OS.Picture.Font(..)+		, Graphics.UI.ObjectIO.OS.Picture.Colour(..)+		, module Graphics.UI.ObjectIO.StdControlDef+		, module Graphics.UI.ObjectIO.StdWindowDef+		, module Graphics.UI.ObjectIO.OS.Types+		, isCustomisedControl, isRecursiveControl+		, LookInfo(..), WindowInfo(..)+		, CustomButtonInfo(..), CustomInfo(..)+		, CompoundInfo(..), CompoundLookInfo(..)+		) where+                    +                    ++import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.StdControlDef+import Graphics.UI.ObjectIO.StdWindowDef+import Graphics.UI.ObjectIO.KeyFocus+import Graphics.UI.ObjectIO.Receiver.Handle(ReceiverHandle(..))+import Graphics.UI.ObjectIO.OS.Picture+import Graphics.UI.ObjectIO.OS.Types+import Graphics.UI.ObjectIO.OS.Rgn(OSRgnHandle)+++type ControlState ls ps+   = WElementHandle ls ps            -- is a WElementHandle++data WindowHandles ps+   = WindowHandles+        { whsWindows      :: [WindowStateHandle ps]   -- The windows and their controls of a process+        , whsNrWindowBound:: !Bound             -- The maximum number of windows that are allowed to be opened+        , whsModal	  :: Bool		-- Flag: the window system is modal (used in combination with modal dialogues)+	, whsFinalModalLS :: [FinalModalLS]	-- The final local states of terminated modal dialogs+        }++data FinalModalLS = forall ls . FinalModalLS WIDS ls++data WindowStateHandle ps+   = forall ls . +      WindowStateHandle +            WIDS                            	-- A window is identified by an Id and an OSWindowPtr+        (Maybe (WindowLSHandle ls ps))          -- If used as placeholder, Nothing; otherwise window with local state+data WindowLSHandle ls ps+   = WindowLSHandle+        { wlsState        :: ls                 -- The local state of this window+        , wlsHandle       :: WindowHandle ls ps -- The window implementation+        }+data WIDS+   = WIDS+        { wId             :: Id                 -- Id  of window+        , wPtr            :: !OSWindowPtr     	-- Ptr of window+        , wActive         :: !Bool              -- The window is the active window (True) or not (False)+        }+data WindowHandle ls ps+   = WindowHandle+        { whMode      :: !WindowMode            -- The window mode (Modal or Modeless)+        , whKind      :: !WindowKind      	-- The window kind (Window or Dialog)+        , whTitle     :: !Title             	-- The window title+        , whItemNrs   :: [Int]              	-- The list of free system item numbers for all controls+        , whKeyFocus  :: KeyFocus         	-- The item that has the keyboard input focus+        , whWindowInfo:: WindowInfo		-- Additional information about the window+        , whItems     :: [WElementHandle ls ps] -- The window controls+        , whShow      :: Bool			-- The visibility of the window (True iff visible)+        , whSelect    :: Bool			-- The WindowSelectState==Able (by default True)+        , whAtts      :: ![WindowAttribute ls ps] -- The window attributes+        , whDefaultId :: Maybe Id		-- The Id of the optional default button+	, whCancelId  :: Maybe Id		-- The Id of the optional cancel  button+        , whSize      :: !Size              	-- The exact size of the window        +        , whClosing   :: !Bool              	-- Flag: the window is being closed (True)+        }+        +data LookInfo+   = LookInfo+   	{ lookFun	:: Look			-- The Look function+	, lookPen	:: Pen			-- The settings of the Pen+	, lookSysUpdate	:: Bool			-- The system handles updates as much as possible+	}++data WindowInfo+    = WindowInfo+	{ windowDomain	:: Rect			-- The optional view domain of the window+	, windowOrigin	:: Point2		-- The Origin of the view domain+	, windowHScroll	:: Maybe ScrollInfo	-- The scroll data of the WindowHScroll attribute+	, windowVScroll	:: Maybe ScrollInfo	-- The scroll data of the WindowVScroll attribute+	, windowLook	:: LookInfo		-- The look and pen of the window+	, windowClip	:: ClipState		-- The clipped elements of the window+	}+    | NoWindowInfo+        +data WindowMode                          	-- Modality of the window+    = Modal                           		-- Modal window (only for dialogs)+    | Modeless                        		-- Modeless window+    deriving (Eq)+    +data WindowKind+    = IsWindow                          	-- Window kind+    | IsDialog                          	-- Dialog kind+    deriving (Eq)+    +data ScrollInfo+   = ScrollInfo	+      {	scrollFunction	:: ScrollFunction	-- The ScrollFunction of the (horizontal/vertical) scroll attribute+      ,	scrollItemPos	:: Point2		-- The exact position of the scrollbar+      ,	scrollItemSize	:: Size			-- The exact size of the scrollbar+      ,	scrollItemPtr	:: OSWindowPtr		-- The OSWindowPtr of the scrollbar+      }++data ClipState +   = ClipState+      { clipRgn     :: OSRgnHandle              -- The clipping region+      , clipOk      :: Bool                 	-- Flag: the clipping region is valid+      }++data    WElementHandle ls ps+    = WListLSHandle       [WElementHandle  ls      ps]+    | forall ls1 . +      WExtendLSHandle ls1 [WElementHandle (ls1,ls) ps]+    | forall ls1 . +      WChangeLSHandle ls1 [WElementHandle  ls1     ps]+    | WItemHandle+        { wItemId         :: Maybe Id           -- If the control has a (ControlId id) attribute, then Just id; Nothing+        , wItemNr         :: Int                -- The internal nr of this control  (generated from whItemNrs)+        , wItemKind       :: ControlKind        -- The sort of control+        , wItemShow       :: Bool               -- The visibility of the control (True iff visible)+        , wItemSelect     :: Bool               -- The ControlSelectState==Able  (by default True)+        , wItemInfo       :: WItemInfo ls ps  	-- Additional information of the control+        , wItemAtts       :: [ControlAttribute ls ps] -- The control attributes                   +        , wItems          :: [WElementHandle ls ps]   -- In case of   CompoundControl : its control elements+                                    		      -- Otherwise        	      : []+        , wItemVirtual    :: Bool               -- The control is virtual (True) and should not be layn out+        , wItemPos        :: Point2             -- The exact position of the item+        , wItemSize       :: Size               -- The exact size of the item+        , wItemPtr        :: OSWindowPtr        -- The ptr to the item (osNoWindowPtr if no handle)+        , wItemLayoutInfo :: LayoutInfo         -- Additional information on layout+        }+        +        +data LayoutInfo                          	-- The layout attribute of the layout root control is:+    = LayoutFix                             	-- ItemPos    = Fix+    | LayoutFrame                           	-- any other attribute+    deriving (Eq)+    +data WItemInfo ls ps+    = WButtonInfo ButtonInfo                    -- In case of   ButtonControl   : the button information+    | WCheckInfo  (CheckInfo ls ps)  		-- In case of   CheckControl    : the check items information+    | WCompoundInfo CompoundInfo		-- In case of	CompoundControl	: the compound control information+    | WCustomButtonInfo	CustomButtonInfo	-- In case of	CustomButtonControl	: the custom button information+    | WCustomInfo CustomInfo			-- In case of	CustomControl		: the custom information+    | WEditInfo   EditInfo                      -- In case of   EditControl     : the edit text information+    | WPopUpInfo  (PopUpInfo ls ps)  		-- In case of   PopUpControl    : the pop up information+    | WListBoxInfo (ListBoxInfo ls ps)		-- In case of   ListBoxControl  : the list box information+    | WRadioInfo  (RadioInfo ls ps)  		-- In case of   RadioControl    : the radio items information   +    | WReceiverInfo (ReceiverHandle ls ps)	-- In case of	ReceiverControl	: the receiver information+    | WSliderInfo (SliderInfo ls ps)  		-- In case of   SliderControl   : the slider information+    | WTextInfo   TextInfo                      -- In case of   TextControl     : the text information  +    | NoWItemInfo                           	-- No additional information+    +data RadioInfo ls ps+   = RadioInfo+        { radioItems        :: [RadioItemInfo ls ps]  		-- The radio items and their exact position (initially zero)+        , radioLayout       :: RowsOrColumns        		-- The layout of the radio items+        , radioIndex        :: Int              		-- The currently selected radio item (1<=radioIndex<=length radioItems)+        }+data RadioItemInfo ls ps+   = RadioItemInfo+        { radioItem         :: (String,Int,GUIFun ls ps) 	-- The RadioItem of the definition (Int field redundant)+        , radioItemPos      :: !Point2          		-- The exact position of the item+        , radioItemSize     :: Size             		-- The exact size of the item+        , radioItemPtr      :: OSWindowPtr          		-- The OSWindowPtr of the item+        }+data CheckInfo ls ps+   = CheckInfo+        { checkItems        :: [CheckItemInfo ls ps]		-- The check items and their exact position (initially zero)+        , checkLayout       :: RowsOrColumns    		-- The layout of the check items+        }+data CheckItemInfo ls ps+   = CheckItemInfo+        { checkItem         :: (String,Int,MarkState,GUIFun ls ps) -- The CheckItem of the definition (Int field redundant)+        , checkItemPos      :: !Point2              		-- The exact position of the item+        , checkItemSize     :: Size                 		-- The exact size of the item+        , checkItemPtr      :: OSWindowPtr          		-- The OSWindowPtr of the item+        }+data PopUpInfo ls ps+   = PopUpInfo+        { popUpInfoItems    :: [PopUpControlItem ps (ls,ps)]	-- The pop up items+        , popUpInfoIndex    :: Index                		-- The currently selected pop up item (1<=popUpInfoIndex<=length popUpInfoItems)+        , popUpInfoEdit     :: Maybe PopUpEditInfo  		-- If the pop up is editable: the PopUpEditInfo, otherwise Nothing+        }+data PopUpEditInfo+   = PopUpEditInfo+        { popUpEditText     :: String               		-- The current content of the editable pop up+        , popUpEditPtr      :: OSWindowPtr          		-- The OSWindowPtr of the editable pop up+        }+data ListBoxInfo ls ps+   = ListBoxInfo+        { listBoxInfoItems  :: [ListBoxControlItem ps (ls,ps)]	-- The list box items+        , listBoxNrLines    :: NrLines+        , listBoxInfoMultiSel :: Bool+        }+data SliderInfo ls ps+   = SliderInfo+        { sliderInfoDir     :: Direction            -- The direction of the slider+        , sliderInfoLength  :: Int                  -- The length (in pixels) of the slider+        , sliderInfoState   :: SliderState          -- The current slider state+        , sliderInfoAction  :: SliderAction ls ps   -- The action of the slider+        }+data ButtonInfo+   = ButtonInfo+        { buttonInfoText  :: String                 -- The title of the button control+        }+data CustomButtonInfo+   = CustomButtonInfo+   	{ cButtonInfoLook :: LookInfo	    	    -- The look of the custom button control+	}+data CustomInfo+   = CustomInfo+   	{ customInfoLook :: LookInfo		    -- The look of the custom control+	}+data  CompoundInfo+    = CompoundInfo+    	{ compoundDomain  :: Rect                   -- The optional view domain of the compound control+        , compoundOrigin  :: Point2                 -- The Origin of the view domain+        , compoundHScroll :: Maybe ScrollInfo       -- The scroll data of the ControlHScroll attribute+        , compoundVScroll :: Maybe ScrollInfo       -- The scroll data of the ControlVScroll attribute+        , compoundLookInfo:: CompoundLookInfo       -- The look information of the compound control+        }+data  CompoundLookInfo+    = CompoundLookInfo+    	{ compoundLook    :: LookInfo               -- The look of the compound control+        , compoundClip    :: ClipState              -- The clipped elements of the compound control+        }+data    EditInfo+    = EditInfo+        { editInfoText    :: !String                -- The content of the edit control+        , editInfoWidth   :: Int                    -- The width (in pixels) of the edit item+        , editInfoNrLines :: Int                    -- The nr of complete visible lines of the edit item+        }+data    TextInfo+    = TextInfo+        { textInfoText    :: String                 -- The content of the text control+        }+data    ControlKind+    = IsButtonControl+    | IsCheckControl+    | IsCompoundControl+    | IsCustomButtonControl+    | IsCustomControl+    | IsEditControl+    | IsLayoutControl+    | IsPopUpControl+    | IsListBoxControl+    | IsRadioControl+    | IsSliderControl+    | IsTextControl+    | IsReceiverControl 				-- Of other controls the ControlType++    deriving (Eq,Show)+++instance Eq WIDS where+    (==) wids wids' = wPtr wids==wPtr wids' && wId wids==wId wids'+++--  The given ControlKind corresponds with a custom-drawn control.++isCustomisedControl :: ControlKind -> Bool+isCustomisedControl IsCustomButtonControl = True+isCustomisedControl IsCustomControl   = True+isCustomisedControl _             = False++--  The given ControlKind corresponds with a control that contains other controls (CompoundControl).++isRecursiveControl :: ControlKind -> Bool+isRecursiveControl IsCompoundControl    = True+isRecursiveControl IsLayoutControl  = True+isRecursiveControl _            = False+++--  Conversion functions from ControlState to WElementHandle, and vice versa:++wElementHandleToControlState :: WElementHandle ls ps -> ControlState ls ps+wElementHandleToControlState wH = wH++controlStateToWElementHandle :: ControlState ls ps -> WElementHandle ls ps+controlStateToWElementHandle wH = wH
+ Graphics/UI/ObjectIO/Window/SDISize.hs view
@@ -0,0 +1,95 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Window.SDISize+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Window.SDISize(getSDIWindowSize, resizeSDIWindow) where++++import	Graphics.UI.ObjectIO.Process.IOState+import	Graphics.UI.ObjectIO.Window.Access+import	Graphics.UI.ObjectIO.Window.Update+import	Graphics.UI.ObjectIO.CommonDef(dumpFatalError)+import	Graphics.UI.ObjectIO.OS.Window+import 	Graphics.UI.ObjectIO.OS.Types++sdiSizeFatalError :: String -> String -> x+sdiSizeFatalError rule error = dumpFatalError rule "Window.SDISize" error+++--	getSDIWindowSize retrieves the current size of the WindowViewFrame if this is a SDI process+getSDIWindowSize :: GUI ps (Size,OSWindowPtr)+getSDIWindowSize = do+	osdInfo <- accIOEnv ioStGetOSDInfo	+	let wPtr  = case getOSDInfoOSInfo osdInfo of+		Just info -> osFrame info+		_         -> osNoWindowPtr+	(if getOSDInfoDocumentInterface osdInfo /= SDI then return (zero,wPtr)+	 else do+		-- PA: here we have to use osGetWindowViewFrameSize, because it is the only reliable way to determine proper viewframe size. +		(w,h) <- liftIO (osGetWindowViewFrameSize wPtr)+		return (Size{w=w,h=h},wPtr))++{-	resizeSDIWindow wPtr oldviewframesize newviewframesize+		resizes the SDI window so the viewframe does not change in size. +		oldviewframesize is the size of the ViewFrame(!) before the menu/toolbar was created.+		newviewframesize is the size of the ViewFrame(!) after  the menu/toolbar was created.+		Note that:+			h oldviewframesize /= h newviewframesize && w oldviewframesize == w newviewframesize+-}+resizeSDIWindow :: OSWindowPtr -> Size -> Size -> GUI ps ()+resizeSDIWindow wPtr (Size{h=oldHeight}) newFrameSize@(Size {h=newHeight}) = do {+	osdInfo <- accIOEnv ioStGetOSDInfo;+	if getOSDInfoDocumentInterface osdInfo /= SDI then sdiSizeFatalError "resizeSDIWindow" "not an SDI process"+	else +		let (framePtr,clientPtr) = case getOSDInfoOSInfo osdInfo of+	  		Just osinfo -> (osFrame osinfo,osClient osinfo)+	  		_           -> (osNoWindowPtr,osNoWindowPtr)+		in+		    if wPtr /= framePtr then sdiSizeFatalError "resizeSDIWindow" "SDIWindow frame could not be located"	+		    else do {+		    		(oldw,oldh) <- liftIO (osGetWindowSize framePtr);+				liftIO (osSetWindowSize framePtr (oldw,oldh+oldHeight-newHeight) True);+				if newHeight > oldHeight then return ()	-- menus take up less space+				else do {+					(ok,wDevice) <- accIOEnv (ioStGetDevice WindowDevice);+					if not ok then return ()+					else +						let 	windows = windowSystemStateGetWindowHandles wDevice+	  					    	(found,wsH,windows1) = getWindowHandlesWindow (toWID clientPtr) windows+	  					in +							if not found then appIOEnv (ioStSetDevice (WindowSystemState windows1))+							else do	{+								wMetrics <- accIOEnv ioStGetOSWindowMetrics;+								wsH <- liftIO (updateSDIWindow wMetrics oldHeight newFrameSize wsH);+								let windows2 = setWindowHandlesWindow wsH windows1+								in appIOEnv (ioStSetDevice (WindowSystemState windows2));+							};+				};+			};+	}		+	where+		-- Note that oldH > h newSize+		updateSDIWindow :: OSWindowMetrics -> Int -> Size -> WindowStateHandle ps -> IO (WindowStateHandle ps)+		updateSDIWindow wMetrics oldH newSize (WindowStateHandle wids@(WIDS {wPtr=wPtr}) (Just wlsH@(WindowLSHandle {wlsHandle=wH}))) = do+			wH <- updateWindow wMetrics updateInfo wH		-- Update the background+			wH <- updateRectControls wMetrics newArea wPtr wH	-- Update the controls+			return (WindowStateHandle wids (Just wlsH{wlsHandle=wH}))+			where			+				newArea		= zero{rright=w newSize,rbottom=oldH}+				updateInfo	= UpdateInfo +							{ updWIDS	= wids+							, updWindowArea	= newArea+							, updControls	= []+							, updGContext	= Nothing+							}+		updateSDIWindow _ _ _ _ = sdiSizeFatalError "updateSDIWindow" "unexpected window placeholder"
+ Graphics/UI/ObjectIO/Window/Update.hs view
@@ -0,0 +1,455 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Window.Update+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Window.Update contains the window update functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Window.Update+		( updateWindow, updateWindowBackgrounds+		, updateRectControls, updateWindowBackground+		, updateControls+		) where++++import	Graphics.UI.ObjectIO.CommonDef+import	Graphics.UI.ObjectIO.Device.Events+import	Graphics.UI.ObjectIO.Window.Handle+import	Graphics.UI.ObjectIO.Window.Access(getWItemCompoundInfo, getWItemCustomButtonInfo, getWItemCustomInfo,+				  	   getCompoundContentRect, getWindowContentRect, getCompoundHScrollRect, getCompoundVScrollRect)+import	Graphics.UI.ObjectIO.Window.ClipState(validateWindowClipState)+import  Graphics.UI.ObjectIO.StdPicture(toRegion, accClipPicture)+import  Graphics.UI.ObjectIO.StdControlAttribute(isControlDoubleBuffered)+import  Graphics.UI.ObjectIO.StdWindowAttribute(isWindowDoubleBuffered)+import	Graphics.UI.ObjectIO.OS.Picture+import	Graphics.UI.ObjectIO.OS.Rgn+import	Graphics.UI.ObjectIO.OS.Window+import  Control.Monad(when)+import  Foreign.Ptr(nullPtr)++windowupdateFatalError :: String -> String -> x+windowupdateFatalError rule error = dumpFatalError rule "windowupdate" error+++--	updateWindow updates the window, using the UpdateInfo argument. ++updateWindow :: OSWindowMetrics -> UpdateInfo -> WindowHandle ls ps -> IO (WindowHandle ls ps)+updateWindow wMetrics info@(UpdateInfo {updWIDS=WIDS{wPtr=wPtr},updGContext=updGContext}) wH = do+	wH1 <- validateWindowClipState wMetrics False wPtr wH+	osPict <- getUpdateContext wPtr updGContext+	wH2 <- updateWindowBackground wMetrics False Nothing info wH1 osPict+	wH3 <- updateControls wMetrics info wH2 osPict+	setUpdateContext wPtr updGContext osPict+	return wH3+	where+	    getUpdateContext :: OSWindowPtr -> Maybe OSPictContext -> IO OSPictContext+	    getUpdateContext _ (Just osPict) = return osPict+	    getUpdateContext wPtr _ = osGrabWindowPictContext wPtr+	+	    setUpdateContext :: OSWindowPtr -> Maybe OSPictContext -> OSPictContext -> IO ()+	    setUpdateContext wPtr updContext osPict+		| isJust updContext = return ()+		| otherwise	    = osReleaseWindowPictContext wPtr osPict+++{-	updateWindowBackgrounds redraws the (window/compound) backgrounds that are inside the OSRgnHandle argument.+	After redrawing the OSRgnHandle argument is disposed!+-}+updateWindowBackgrounds :: OSWindowMetrics -> OSRgnHandle -> WIDS -> WindowHandle ls ps -> IO (WindowHandle ls ps)+updateWindowBackgrounds wMetrics backgrRgn wids@(WIDS {wPtr=wPtr}) wH@(WindowHandle {whItems=whItems,whSelect=whSelect,whSize=whSize,whWindowInfo=whWindowInfo}) = do+    (_,backgrRect) <- osGetRgnBox backgrRgn+    (if isEmptyRect backgrRect then osDisposeRgn backgrRgn >> return wH+     else do+	let updInfo = UpdateInfo+	      { updWIDS       = wids+	      , updWindowArea	= backgrRect+	      , updControls	= []+	      , updGContext	= Nothing+	      }+	osPict <- osGrabWindowPictContext wPtr	    +	wH1 <- updateWindowBackground wMetrics True (Just backgrRgn) updInfo wH osPict+	backgrRgn1 <- updateControlBackgrounds wMetrics backgrRgn wH1 osPict+	osReleaseWindowPictContext wPtr osPict+	osDisposeRgn backgrRgn1+	return wH1)+    where+	pen = case whWindowInfo of+		WindowInfo{windowLook=look} -> lookPen look+		NoWindowInfo 		    -> defaultPen+	+	updateControlBackgrounds :: OSWindowMetrics -> OSRgnHandle -> WindowHandle ls ps -> OSPictContext -> IO OSRgnHandle+	updateControlBackgrounds wMetrics backgrRgn wH@(WindowHandle {whItems=whItems,whSelect=whSelect,whSize=whSize}) osPict = do+	    updateBackgrounds wMetrics (sizeToRect whSize) whSelect backgrRgn whItems osPict+	    where+		updateBackgrounds :: OSWindowMetrics -> Rect -> Bool -> OSRgnHandle -> [WElementHandle ls ps] -> OSPictContext -> IO OSRgnHandle+		updateBackgrounds wMetrics wFrame ableContext backgrRgn itemHs osPict = do+		    empty <- osIsEmptyRgn backgrRgn+		    (if empty || null itemHs then return backgrRgn+		     else do+			backgrRgn <- updateBackground  wMetrics wFrame ableContext backgrRgn (head itemHs) osPict+			backgrRgn <- updateBackgrounds wMetrics wFrame ableContext backgrRgn (tail itemHs) osPict+			return backgrRgn)+		    where+			updateBackground :: OSWindowMetrics -> Rect -> Bool -> OSRgnHandle -> WElementHandle ls ps -> OSPictContext -> IO OSRgnHandle+			updateBackground wMetrics wFrame ableContext backgrRgn itemH@(WItemHandle {wItemShow=wItemShow,wItemVirtual=wItemVirtual,wItemKind=wItemKind,wItemPos=wItemPos,wItemSize=wItemSize}) osPict+			    | not wItemShow || wItemVirtual || not (isRecursiveControl wItemKind) =	-- PA: isRecursive includes also LayoutControls+				    return backgrRgn+			    | otherwise = do+				    (_, backgrRect) <- osGetRgnBox backgrRgn+				    let compoundRect = posSizeToRect wItemPos wItemSize+				    (if disjointRects backgrRect compoundRect then+				       return backgrRgn+				     else updateCompoundBackground wMetrics wFrame compoundRect ableContext backgrRgn itemH osPict)+			    where+				updateCompoundBackground :: OSWindowMetrics -> Rect -> Rect -> Bool -> OSRgnHandle -> WElementHandle ls ps -> OSPictContext -> IO OSRgnHandle+				updateCompoundBackground wMetrics wFrame compoundRect ableContext backgrRgn itemH@(WItemHandle {wItemKind=IsLayoutControl,wItems=wItems}) osPict = do+				    backgrRgn <- updateBackgrounds wMetrics cFrame cAble backgrRgn wItems osPict+				    rectRgn	<- osNewRectRgn cFrame+				    diffRgn <- osDiffRgn backgrRgn rectRgn+				    mapM_ osDisposeRgn [rectRgn,backgrRgn]+				    return diffRgn+				    where+					cFrame = intersectRects wFrame compoundRect+					cAble  = ableContext && wItemSelect itemH+				updateCompoundBackground wMetrics wFrame compoundRect ableContext backgrRgn itemH@(WItemHandle {wItemKind=IsCompoundControl,wItems=wItems,wItemPos=itemPos,wItemSize=itemSize,wItemAtts=attrs}) osPict = do+				    updRgn <- osSectRgn backgrRgn (clipRgn clipInfo)+				    empty <- osIsEmptyRgn updRgn+				    (if empty then do+					backgrRgn <- updateBackgrounds wMetrics cFrame cAble backgrRgn wItems osPict+					rectRgn <- osNewRectRgn cFrame+					diffRgn <- osDiffRgn backgrRgn rectRgn+					mapM_ osDisposeRgn [rectRgn,backgrRgn,updRgn]+					return diffRgn+				     else do				     +				     	contentRgn <- osNewRectRgn contentRect+				     	clipRgn <- osSectRgn contentRgn updRgn+				     	osDisposeRgn contentRgn+					(x,_,_,_) <- doDraw (origin-itemPos) lookPen True clipRgn osPict (any isControlDoubleBuffered attrs) (lookFun (if cAble then Able else Unable) updState)+					osDisposeRgn clipRgn+					backgrRgn <- updateBackgrounds wMetrics cFrame cAble backgrRgn wItems osPict+					rectRgn <- osNewRectRgn cFrame+					diffRgn <- osDiffRgn backgrRgn rectRgn+					mapM_ osDisposeRgn [rectRgn,backgrRgn,updRgn]+					return diffRgn)+				    where				+					info		= getWItemCompoundInfo (wItemInfo itemH)+					compLookInfo	= compoundLookInfo info+					LookInfo{lookFun=lookFun,lookPen=lookPen} = compoundLook compLookInfo+					clipInfo	= compoundClip compLookInfo+					origin		= compoundOrigin info+					domainRect	= compoundDomain info+					hasScrolls	= (isJust (compoundHScroll info),isJust (compoundVScroll info))+					visScrolls	= osScrollbarsAreVisible wMetrics domainRect (toTuple itemSize) hasScrolls+					contentRect	= getCompoundContentRect wMetrics visScrolls compoundRect+					cFrame		= intersectRects wFrame contentRect+					cAble		= ableContext && wItemSelect itemH+					updFrame	= rectToRectangle cFrame+					updState	= UpdateState{oldFrame=updFrame,newFrame=updFrame,updArea=[updFrame]}++			        updateCompoundBackground _ _ _ _ _ WItemHandle {wItemKind=wItemKind} _ =+				    windowupdateFatalError "updateCompoundBackground (updateWindowBackgrounds)" ("unexpected control kind: " ++ show wItemKind)+			+			updateBackground wMetrics wFrame ableContext backgrRgn (WListLSHandle itemHs) osPict = do+				updateBackgrounds wMetrics wFrame ableContext backgrRgn itemHs osPict				+			+			updateBackground wMetrics wFrame ableContext backgrRgn (WExtendLSHandle exLS itemHs) osPict = do+				updateBackgrounds wMetrics wFrame ableContext backgrRgn itemHs osPict				+			+			updateBackground wMetrics wFrame ableContext backgrRgn (WChangeLSHandle chLS itemHs) osPict = do+				updateBackgrounds wMetrics wFrame ableContext backgrRgn itemHs osPict				+++{-	updateRectControls updates the controls that fit in the Rect argument of the indicated window or compound control. +	The Rect is in window/compound coordinates. +-}+updateRectControls :: OSWindowMetrics -> Rect -> OSWindowPtr -> WindowHandle ls ps -> IO (WindowHandle ls ps)+updateRectControls wMetrics area wPtr wH@(WindowHandle {whItems=whItems,whSelect=whSelect})+    | isEmptyRect area = return wH+    | otherwise = do+	itemHs <- updateControlsInRect wMetrics wPtr whSelect area whItems+	return (wH{whItems=itemHs})+    where+	updateControlsInRect :: OSWindowMetrics -> OSWindowPtr -> Bool -> Rect -> [WElementHandle ls ps] -> IO [WElementHandle ls ps]+	updateControlsInRect wMetrics parentPtr ableContext area itemHs+	    | isEmptyRect area || null itemHs = return itemHs+	    | otherwise = do+		itemH  <- updateControlInRect  wMetrics parentPtr ableContext area (head itemHs)+		itemHs <- updateControlsInRect wMetrics parentPtr ableContext area (tail itemHs)+		return (itemH:itemHs)+	    where+		updateControlInRect :: OSWindowMetrics -> OSWindowPtr -> Bool -> Rect -> WElementHandle ls ps -> IO (WElementHandle ls ps)+		updateControlInRect wMetrics parentPtr ableContext area itemH@(WItemHandle {wItemKind=wItemKind,wItemPtr=wItemPtr,wItemPos=wItemPos,wItemSize=wItemSize,wItemShow=wItemShow,wItemVirtual=wItemVirtual})+		    | not wItemShow || wItemVirtual || isEmptyRect intersectRect || wItemKind == IsReceiverControl =+			    return itemH+		    | isCustomControl = updateCustomControl wMetrics parentPtr ableContext intersectRect itemH+		    | Just updateOSControl <- mb_updateOSControl = do+		            updateOSControl (subVector (toVector wItemPos) intersectRect) parentPtr wItemPtr+		            return itemH+		    | isRecursiveControl wItemKind	= do -- This includes LayoutControl and excludes CompoundControl which is already guarded as iscustomcontrol+			    let ableContext1 = ableContext && wItemSelect itemH+			    itemHs <- updateControlsInRect wMetrics parentPtr ableContext1 area (wItems itemH) -- PA: shouldn't area be clipped (also below at updatecustomcontrol?)+			    return (itemH{wItems=itemHs})+		    | otherwise	-- This alternative should never be reached+			    = windowupdateFatalError "updateControlInRect" "unexpected ControlKind"+		    where+			controlRect		= posSizeToRect wItemPos wItemSize+			intersectRect		= intersectRects area controlRect+			isCustomControl		= case wItemKind of+				IsCustomButtonControl	-> True+				IsCustomControl		-> True+				IsCompoundControl	-> True+				_			-> False			+			mb_updateOSControl = case wItemKind of+				IsRadioControl		-> Just osUpdateRadioControl+				IsCheckControl		-> Just osUpdateCheckControl+				IsPopUpControl		-> Just osUpdatePopUpControl+				IsListBoxControl	-> Just osUpdateListBoxControl+				IsSliderControl		-> Just osUpdateSliderControl+				IsTextControl		-> Just osUpdateTextControl+				IsEditControl		-> Just osUpdateEditControl+				IsButtonControl		-> Just osUpdateButtonControl+				_			-> Nothing+			+	--		updatecustomcontrol updates a ((Custom)Button/Compound)Control.+			updateCustomControl :: OSWindowMetrics -> OSWindowPtr -> Bool -> Rect -> WElementHandle ls ps -> IO (WElementHandle ls ps)+			updateCustomControl _ parentPtr contextAble area itemH@(WItemHandle {wItemKind=IsCustomButtonControl, wItemSize=wItemSize, wItemPos=wItemPos, wItemPtr=itemPtr, wItemAtts=attrs}) = do+			    osPict <- osGrabControlPictContext parentPtr itemPtr+			    (_,_,pen,_) <- doDraw zero (lookPen lookInfo) True osNoRgn osPict (any isControlDoubleBuffered attrs) (accClipPicture (toRegion updArea) (lookFun lookInfo selectState updState))+			    let info1 = info{cButtonInfoLook=lookInfo{lookPen=pen}}+			    osReleaseControlPictContext itemPtr osPict	+			    osValidateWindowRect itemPtr areaLocal+			    return (itemH{wItemInfo=WCustomButtonInfo info1})+			    where+				selectState	= if (contextAble && wItemSelect itemH) then Able else Unable+				info		= getWItemCustomButtonInfo (wItemInfo itemH)+				lookInfo	= cButtonInfoLook info+				areaLocal	= subVector (toVector wItemPos) area+				cFrame		= sizeToRectangle wItemSize+				updArea		= rectToRectangle areaLocal+				updState	= UpdateState{oldFrame=cFrame,newFrame=cFrame,updArea=[updArea]}+			+			updateCustomControl _ parentPtr contextAble area itemH@(WItemHandle {wItemKind=IsCustomControl,wItemSize=wItemSize,wItemPtr=itemPtr,wItemPos=itemPos,wItemAtts=attrs}) = do+			    osPict <- osGrabControlPictContext parentPtr itemPtr			    +			    (_,_,pen,_) <- doDraw zero (lookPen lookInfo) True osNoRgn osPict (any isControlDoubleBuffered attrs) (accClipPicture (toRegion updArea) (lookFun lookInfo selectState updState))+			    let info1 = info{customInfoLook=lookInfo{lookPen=pen}}+			    osReleaseControlPictContext itemPtr osPict+			    osValidateWindowRect itemPtr areaLocal+			    return (itemH{wItemInfo=WCustomInfo info1})+			    where+				selectState	= if (contextAble && wItemSelect itemH) then Able else Unable+				info		= getWItemCustomInfo (wItemInfo itemH)+				lookInfo	= customInfoLook info+				areaLocal	= subVector (toVector itemPos) area+				cFrame		= sizeToRectangle wItemSize+				updArea		= rectToRectangle areaLocal+				updState	= UpdateState{oldFrame=cFrame,newFrame=cFrame,updArea=[updArea]}+			+			updateCustomControl wMetrics parentPtr contextAble area itemH@(WItemHandle {wItemKind=IsCompoundControl,wItems=wItems,wItemSize=itemSize,wItemPtr=itemPtr,wItemPos=itemPos,wItemAtts=attrs}) = do+			    osPict <- osGrabControlPictContext parentPtr itemPtr			    +			    (_,_,pen,_) <- doDraw origin (lookPen lookInfo) True osNoRgn osPict (any isControlDoubleBuffered attrs) (accClipPicture (toRegion updArea) (lookFun lookInfo selectState updState))+			    let info1 = info{compoundLookInfo=compLookInfo{compoundLook=lookInfo{lookPen=pen}}}+			    osReleaseControlPictContext itemPtr osPict+			    updateScrollAreas+			    itemHs <- updateControlsInRect wMetrics parentPtr compoundAble area wItems+			    osValidateWindowRect itemPtr areaLocal+			    return (itemH{wItemInfo=WCompoundInfo info1,wItems=itemHs})+			    where				+				compoundAble	= contextAble && wItemSelect itemH+				selectState	= if compoundAble then Able else Unable+				info		= getWItemCompoundInfo (wItemInfo itemH)+				compLookInfo	= compoundLookInfo info+				lookInfo	= compoundLook compLookInfo+				(origin,domainRect,hasScrolls) = (compoundOrigin info,compoundDomain info,(isJust (compoundHScroll info),isJust (compoundVScroll info)))+				visScrolls	= osScrollbarsAreVisible wMetrics domainRect (toTuple itemSize) hasScrolls+				contentRect	= getCompoundContentRect wMetrics visScrolls (posSizeToRect origin itemSize)+				areaLocal	= subVector (toVector itemPos) area+				cFrame		= rectToRectangle contentRect+				updArea		= rectToRectangle (intersectRects contentRect (subVector (toVector (itemPos-origin)) area))+				updState	= UpdateState {oldFrame=cFrame,newFrame=cFrame,updArea=[updArea]}+				+				updateScrollAreas = if emptyH && emptyV then return () else+						    (if emptyH	then (osUpdateCompoundControl updVRect parentPtr itemPtr) else+						     (if emptyV	then (osUpdateCompoundControl updHRect parentPtr itemPtr) else+						      ((osUpdateCompoundControl (updVRect{rbottom=rbottom updHRect}) parentPtr itemPtr) >>+						       (osUpdateCompoundControl updHRect parentPtr itemPtr))))+				itemRect	= posSizeToRect itemPos itemSize+				hRect		= getCompoundHScrollRect wMetrics hasScrolls itemRect+				vRect		= getCompoundVScrollRect wMetrics hasScrolls itemRect+				updHRect	= intersectRects hRect area+				updVRect	= intersectRects vRect area+				emptyH		= isEmptyRect updHRect+				emptyV		= isEmptyRect updVRect+			+			updateCustomControl _ _ _ _ (WItemHandle {wItemKind=wItemKind}) =+				windowupdateFatalError "updateCustomControl" ("unexpected ControlKind: " ++ show wItemKind)+		+		updateControlInRect wMetrics parentPtr ableContext area (WListLSHandle itemHs) = do+		    itemHs <- updateControlsInRect wMetrics parentPtr ableContext area itemHs+		    return (WListLSHandle itemHs)+		+		updateControlInRect wMetrics parentPtr ableContext area (WExtendLSHandle exLS itemHs) = do+		    itemHs <- updateControlsInRect wMetrics parentPtr ableContext area itemHs+		    return (WExtendLSHandle exLS itemHs)+		+		updateControlInRect wMetrics parentPtr ableContext area (WChangeLSHandle chLS itemHs) = do+		    itemHs <- updateControlsInRect wMetrics parentPtr ableContext area itemHs+		    return (WChangeLSHandle chLS itemHs)+			++{-	updateBackground updates the background of the window.+-}+updateWindowBackground :: OSWindowMetrics -> Bool -> Maybe OSRgnHandle -> UpdateInfo -> WindowHandle ls ps -> OSPictContext -> IO (WindowHandle ls ps)+updateWindowBackground wMetrics pictureInitialised alsoClipRgn info@(UpdateInfo {updWIDS=WIDS{wPtr=wPtr}}) wH@(WindowHandle {whKind=whKind,whWindowInfo=windowInfo,whSize=whSize,whAtts=attrs}) osPict+    | isEmptyRect updRect || whKind /= IsWindow =		-- Nothing to update at all+	    return wH+    | isEmptyRect updAreaRect =					-- Nothing to update inside viewframe+	    return wH+    | otherwise = do	    +	    let drawf = do+		maybe (return ()) pictAndClipRgn alsoClipRgn+		setPictOrigin origin+		accClipPicture (toRegion updArea) (lookFun lookInfo selectState updState)+	    (_,_,pen,_) <- doDraw zero initPen True (clipRgn clipState) osPict (any isWindowDoubleBuffered attrs) drawf+	    return (wH{whWindowInfo=windowInfo{windowLook=lookInfo{lookPen=pen}}})+    where+	updRect				= updWindowArea info	+	(origin,domainRect,hasScrolls)	= (windowOrigin windowInfo,windowDomain windowInfo,(isJust (windowHScroll windowInfo),isJust (windowVScroll windowInfo)))+	visScrolls			= osScrollbarsAreVisible wMetrics domainRect (toTuple whSize) hasScrolls+	wFrameRect			= posSizeToRect origin (rectSize (getWindowContentRect wMetrics visScrolls (sizeToRect whSize)))+	wFrame				= rectToRectangle wFrameRect+	updAreaRect			= intersectRects wFrameRect (addVector (toVector origin) updRect)+	updArea				= rectToRectangle updAreaRect+	updState			= UpdateState{oldFrame=wFrame,newFrame=wFrame,updArea=[updArea]}+	lookInfo			= windowLook windowInfo+	clipState			= windowClip windowInfo+	selectState			= if whSelect wH then Able else Unable+	initPen				= lookPen lookInfo+++-- 	updatecontrols updates the controls that are registered for update in UpdateInfo.++updateControls :: OSWindowMetrics -> UpdateInfo -> WindowHandle ls ps -> OSPictContext -> IO (WindowHandle ls ps)+updateControls wMetrics info@(UpdateInfo {updWIDS=updWIDS,updControls=updControls}) wH@(WindowHandle {whSelect=whSelect,whItems=whItems}) osPict = do+    (_,itemHs) <- updateControls wMetrics updWIDS whSelect updControls whItems osPict+    return (wH{whItems=itemHs})+    where+	updateControls :: OSWindowMetrics -> WIDS -> Bool -> [ControlUpdateInfo] -> [WElementHandle ls ps] -> OSPictContext -> IO ([ControlUpdateInfo],[WElementHandle ls ps])+	updateControls wMetrics wids contextAble updControls itemHs osPict+	    | null updControls || null itemHs = return (updControls,itemHs)+	    | otherwise = do			+		  (updControls1,itemH1) <- updateControl  wMetrics wids contextAble updControls  (head itemHs) osPict+		  (updControls2,itemHs1) <- updateControls wMetrics wids contextAble updControls1 (tail itemHs) osPict+		  return (updControls2,itemH1:itemHs1)+	    where+		updateControl :: OSWindowMetrics -> WIDS -> Bool -> [ControlUpdateInfo] -> WElementHandle ls ps -> OSPictContext -> IO ([ControlUpdateInfo], WElementHandle ls ps)+		updateControl wMetrics wids contextAble updControls itemH@(WItemHandle {wItemShow=wItemShow}) osPict = do+		    updateControl' wMetrics wids contextAble updControls itemH osPict		    +		    where+			updateControl' :: OSWindowMetrics -> WIDS -> Bool -> [ControlUpdateInfo] -> WElementHandle ls ps -> OSPictContext -> IO ([ControlUpdateInfo], WElementHandle ls ps)+			updateControl' wMetrics wids contextAble updControls itemH@(WItemHandle {wItemNr=wItemNr}) osPict = do+			    let (found,updInfo,updControls1) = remove (\ControlUpdateInfo{cuItemNr=cuItemNr}->cuItemNr==wItemNr) undefined updControls+			    (updControls2,itemHs) <- updateControls wMetrics wids (contextAble && wItemSelect itemH) updControls1 (wItems itemH) osPict+			    let itemH1 = itemH{wItems=itemHs}+			    (if not found then return (updControls2,itemH1)+			     else do+				 itemH <- updateControl'' wMetrics wids contextAble (cuArea updInfo) itemH1 osPict+				 return (updControls2,itemH))+			    where+				updateControl'' :: OSWindowMetrics -> WIDS -> Bool -> Rect -> WElementHandle ls ps -> OSPictContext -> IO (WElementHandle ls ps)+				updateControl'' wMetrics wids contextAble area itemH@(WItemHandle {wItemKind=IsCustomButtonControl,wItemAtts=attrs}) osPict = do+				    (_,_,pen,_) <- doDraw zero (lookPen lookInfo) True osNoRgn osPict (any isControlDoubleBuffered attrs) (accClipPicture (toRegion cFrame) (lookFun lookInfo selectState updState))+				    let info1 = info{cButtonInfoLook=lookInfo{lookPen=pen}}+				    return (itemH{wItemInfo=WCustomButtonInfo info1})+				    where+					selectState	= if (contextAble && wItemSelect itemH) then Able else Unable+					info		= getWItemCustomButtonInfo (wItemInfo itemH)+					lookInfo	= cButtonInfoLook info+					cFrame		= sizeToRectangle (wItemSize itemH)+					updArea		= rectToRectangle (subVector (toVector (wItemPos itemH)) area)+					updState	= UpdateState{oldFrame=cFrame,newFrame=cFrame,updArea=[updArea]}+				+				updateControl'' wMetrics wids contextAble area itemH@(WItemHandle {wItemKind=IsCustomControl,wItemAtts=attrs}) osPict = do+				    (_,_,pen,_) <- doDraw zero (lookPen lookInfo) True osNoRgn osPict (any isControlDoubleBuffered attrs) (accClipPicture (toRegion cFrame) (lookFun lookInfo selectState updState))+				    let info1 = info{customInfoLook=lookInfo{lookPen=pen}}+				    return (itemH{wItemInfo=WCustomInfo info1})+				    where+					selectState	= if (contextAble && wItemSelect itemH) then Able else Unable+					info		= getWItemCustomInfo (wItemInfo itemH)+					lookInfo	= customInfoLook info+					cFrame		= sizeToRectangle (wItemSize itemH)+					updArea		= rectToRectangle (subVector (toVector (wItemPos itemH)) area)+					updState	= UpdateState{oldFrame=cFrame,newFrame=cFrame,updArea=[updArea]}+				+				updateControl'' wMetrics wids contextAble area itemH@(WItemHandle {wItemKind=IsCompoundControl,wItemAtts=attrs}) osPict = do+				    (_,_,pen,_) <- doDraw origin (lookPen lookInfo) True osNoRgn osPict (any isControlDoubleBuffered attrs) (accClipPicture (toRegion cFrame) (lookFun lookInfo selectState updState))+				    let info1 = info{compoundLookInfo=compLookInfo{compoundLook=lookInfo{lookPen=pen}}}+				    return (itemH{wItemInfo=WCompoundInfo info1})+				    where+					selectState	= if contextAble && wItemSelect itemH then Able else Unable+					itemSize	= wItemSize itemH+					itemPos		= wItemPos itemH+					info		= getWItemCompoundInfo (wItemInfo itemH)+					domainRect	= compoundDomain info+					hasScrolls	= (isJust (compoundHScroll info),isJust (compoundVScroll info))+					visScrolls	= osScrollbarsAreVisible wMetrics domainRect (toTuple itemSize) hasScrolls+					compLookInfo	= compoundLookInfo info+					lookInfo	= compoundLook compLookInfo+					origin		= compoundOrigin info+					cFrame		= posSizeToRectangle origin (rectSize (getCompoundContentRect wMetrics visScrolls (sizeToRect itemSize)))+					updArea		= rectToRectangle (intersectRects (rectangleToRect cFrame) (addVector (toVector (origin-itemPos)) area))+					updState	= UpdateState{oldFrame=cFrame,newFrame=cFrame,updArea=[updArea]}+				+				updateControl'' _ wids contextAble area itemH@(WItemHandle {wItemKind=IsRadioControl}) osPict = do+					osUpdateRadioControl area (wPtr wids) (wItemPtr itemH)+					return itemH+				+				updateControl'' _ wids contextAble area itemH@(WItemHandle {wItemKind=IsCheckControl}) osPict = do+					osUpdateCheckControl area (wPtr wids) (wItemPtr itemH)+					return itemH+				+				updateControl'' _ wids contextAble area itemH@(WItemHandle {wItemKind=IsPopUpControl}) osPict = do+					osUpdatePopUpControl area (wPtr wids) (wItemPtr itemH)+					return itemH+				+				updateControl'' _ wids contextAble area itemH@(WItemHandle {wItemKind=IsSliderControl}) osPict = do+					osUpdateSliderControl area (wPtr wids) (wItemPtr itemH)+					return itemH+				+				updateControl'' _ wids contextAble area itemH@(WItemHandle {wItemKind=IsTextControl}) osPict = do+					osUpdateTextControl area (wPtr wids) (wItemPtr itemH)+					return itemH+				+				updateControl'' _ wids contextAble area itemH@(WItemHandle {wItemKind=IsEditControl}) osPict = do+					osUpdateEditControl area (wPtr wids) (wItemPtr itemH)+					return itemH+				+				updateControl'' _ wids contextAble area itemH@(WItemHandle {wItemKind=IsButtonControl}) osPict = do+					osUpdateButtonControl area (wPtr wids) (wItemPtr itemH)+					return itemH+				+				updateControl'' _ _ _ _ itemH@(WItemHandle {wItemKind=IsReceiverControl}) osPict =+					return itemH+				+				updateControl'' _ _ _ _ itemH@(WItemHandle {wItemKind=IsLayoutControl}) _ =+					windowupdateFatalError "updatecontrols (updateControl``)" "LayoutControl should never be updated"+		+		updateControl wMetrics wids contextAble updControls (WListLSHandle itemHs) osPict = do+		    (updControls1,itemHs1) <- updateControls wMetrics wids contextAble updControls itemHs osPict+		    return (updControls1,WListLSHandle itemHs1)+		+		updateControl wMetrics wids contextAble updControls (WExtendLSHandle exLS itemHs) osPict = do+		    (updControls1,itemHs1) <- updateControls wMetrics wids contextAble updControls itemHs osPict+		    return (updControls1,WExtendLSHandle exLS itemHs1)+		+		updateControl wMetrics wids contextAble updControls (WChangeLSHandle chLS itemHs) osPict = do+		    (updControls1,itemHs1) <- updateControls wMetrics wids contextAble updControls itemHs osPict+		    return (updControls1,WChangeLSHandle chLS itemHs1)
+ Graphics/UI/ObjectIO/Window/Validate.hs view
@@ -0,0 +1,626 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Window.Validate+-- Copyright   :  (c) Krasimir Andreev 2002+-- License     :  BSD-style+-- +-- Maintainer  :  ka2_mail@yahoo.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Window.Validate contains window validation functions.+--+-----------------------------------------------------------------------------++module Graphics.UI.ObjectIO.Window.Validate+		( validateWindowId+		, validateWindow+		, exactWindowSize+		, exactWindowPos+		, validateViewDomain+		) where+++++import Prelude hiding (Either(..))	-- Either = Left | Right must be hidden+import Graphics.UI.ObjectIO.CommonDef+import Graphics.UI.ObjectIO.Control.Layout+import Graphics.UI.ObjectIO.Id+import Graphics.UI.ObjectIO.Process.IOState+import Graphics.UI.ObjectIO.StdId+import Graphics.UI.ObjectIO.StdWindowAttribute+import Graphics.UI.ObjectIO.Window.Access+import Graphics.UI.ObjectIO.Window.Handle+import Graphics.UI.ObjectIO.KeyFocus(newFocusItems)+import Graphics.UI.ObjectIO.StdSystem(maxScrollWindowSize)+import Graphics.UI.ObjectIO.StdPicture(unfill, Draw(..))+import Graphics.UI.ObjectIO.OS.System+import Graphics.UI.ObjectIO.OS.Window+import Graphics.UI.ObjectIO.OS.Picture(PenAttribute(..), setPenAttribute, defaultPen)+import Foreign.Ptr(nullPtr)+import qualified Data.Map as Map+import Data.List(find)+++windowValidateFatalError :: String -> String -> x+windowValidateFatalError function message+	= dumpFatalError function "windowvalidate" message+++{-	validateWindowId checks whether the Id of the window/dialogue has already been bound.+	If so, Nothing is returned; otherwise a proper Id value for the window/dialogue is returned.+	The Id is not bound.+-}+validateWindowId :: Maybe Id -> GUI ps (Maybe Id)+validateWindowId Nothing+	= do {+		wId <- openId;+		return (Just wId)+	  }+validateWindowId (Just id)+	= do {+		idtable <- ioStGetIdTable;+		if   Map.member id idtable+		then return Nothing+		else return (Just id)+	  }+++{-	Validate the given window.+-}+validateWindow :: OSWindowMetrics -> OSDInfo -> WindowHandle ls ps -> WindowHandles ps+               -> IO (Index,Point2,Size,Vector2,WindowHandle ls ps)++validateWindow wMetrics _ wH@(WindowHandle {whMode=mode,whKind=IsDialog,whItemNrs=whItemNrs,whItems=whItemsX,whAtts=atts}) windows+	= do {+		(derSize,items) <- layoutControls wMetrics hMargins vMargins spaces reqSize minSize [(domain,zero)] whItemsX;+		let (itemNrs,   items1) = genWElementItemNrs whItemNrs items+		    focusItems 		= getWElementKeyFocusIds True items1+		    derSize1            = determineRequestedSize derSize sizeAtt+		    domain1             = sizeToRectangle derSize1+		    okSize              = exactWindowSize wMetrics domain1 derSize1 False False IsDialog+		in do {			+			okPos <- exactWindowPos wMetrics okSize pos IsDialog mode windows;+			return ( index+			       , okPos+			       , okSize+			       , zero+			       , wH { whItemNrs   = itemNrs+			            , whKeyFocus  = newFocusItems focusItems+			            , whItems     = items1+			            , whSelect    = True+			            , whAtts      = atts4+			            , whDefaultId = defid+			            , whCancelId  = canid+			            , whSize      = okSize+			            }			       +			       )+		   }+	  }+	where+		atts1                 = filter isValidDialogAttribute         atts+		(index,atts2)	      = validateWindowIndex mode              atts1 windows+		(pos,  atts3) 	      = validateWindowPos   mode              atts2 windows+		sizeAtt               = attrSize                              atts3	-- Retrieve Window(View/Outer)Size (identical for Dialogs)+		(hMargins,vMargins)   = attrMargins         IsDialog wMetrics atts3+		spaces                = getWindowItemSpaces IsDialog wMetrics atts3+		defid       	      = getOkId                               atts3 whItemsX+		canid       	      = getCancelId                           atts3 whItemsX+		atts4       	      = validateWindowInitActive              atts3 whItemsX		+		reqSize               = determineRequestedSize zero sizeAtt+		(minWidth,minHeight)  = osMinWindowSize+		minSize               = Size {w=minWidth,h=minHeight}+		domain                = sizeToRectangle reqSize		++validateWindow wMetrics osdInfo wH@(WindowHandle {whKind=IsWindow,whItemNrs=whItemNrs,whItems=whItems,whAtts=atts}) windows+	= let+		atts1                  = filter isValidWindowAttribute atts+		mode                   = Modeless+		(domain,atts2)         = validateWindowDomain          atts1+		(maybe_hScroll,atts3)  = validateWindowHScroll         atts2+		(maybe_vScroll,atts4)  = validateWindowVScroll         atts3+		(sysLook,look, atts5)  = validateWindowLook            atts4+		atts6		       = validateCaretPos domain atts5+	  in+	  do {+		(reqSize,atts7)       <- validateWindowSize wMetrics domain isMDI True (isJust maybe_hScroll,isJust maybe_vScroll) atts6;+		let+			(index,atts8)            = validateWindowIndex mode  atts7 windows+			(pos,  atts9)   	 = validateWindowPos   mode  atts8 windows+			(penAtts,atts10)         = attrPen                       atts9+			(hMargins,vMargins)      = attrMargins IsWindow wMetrics atts10+			spaces                   = getWindowItemSpaces IsWindow wMetrics atts10+			isAble                   = attrSelectState                       atts10+			defid         		 = getOkId                               atts10 whItems+			canid         		 = getCancelId                           atts10 whItems+			atts11         		 = validateWindowInitActive              atts10 whItems+			pen                      = foldr setPenAttribute defaultPen (reverse penAtts)+		in+		do {+			(derSize,items)         <- layoutControls wMetrics hMargins vMargins spaces reqSize minSize [(domain,corner1 domain)] whItems;+			let+				(itemNrs,items1)    = genWElementItemNrs whItemNrs items+				focusItems 	    = getWElementKeyFocusIds True items1+				(origin,atts12)     = validateOrigin derSize domain atts11+				okSize              = exactWindowSize wMetrics domain derSize (isJust maybe_hScroll) (isJust maybe_vScroll) IsWindow+			in+			do {+				okPos <- exactWindowPos wMetrics okSize pos IsWindow mode windows;+				let+					(hScroll,vScroll) = validScrollInfos wMetrics okSize maybe_hScroll maybe_vScroll+				in return ( index+	                                  , okPos+	                                  , okSize+	                                  , toVector (origin-corner1 domain)+	                                  , wH { whItemNrs    = itemNrs+	                                       , whKeyFocus   = newFocusItems focusItems+	                                       , whWindowInfo = WindowInfo+	                                                           { windowDomain  = rectangleToRect domain+	                                                           , windowOrigin  = corner1 domain+	                                                           , windowHScroll = hScroll+	                                                           , windowVScroll = vScroll+	                                                           , windowLook    = LookInfo {lookFun=look,lookPen=pen,lookSysUpdate=sysLook}+	                                                           , windowClip    = ClipState {clipRgn=nullPtr,clipOk=False}+	                                                           }+	                                       , whItems      = items1+	                                       , whSelect     = isAble+	                                       , whAtts       = atts12+	                                       , whDefaultId  = defid+	                                       , whCancelId   = canid+	                                       , whSize       = okSize+	                                       }+	                                  )+			}+		}+	  }+	where+		minSize = fromTuple osMinWindowSize+		isMDI   = getOSDInfoDocumentInterface osdInfo == MDI+		+		validScrollInfos :: OSWindowMetrics -> Size -> Maybe ScrollFunction -> Maybe ScrollFunction+		                 -> (Maybe ScrollInfo,Maybe ScrollInfo)+		validScrollInfos wMetrics wSize maybe_hScroll maybe_vScroll+			= (fmap (scrollInfo hScrollRect) maybe_hScroll,fmap (scrollInfo vScrollRect) maybe_vScroll)+			  where+				  windowRect   = sizeToRect wSize+				  hasScrolls   = (isJust maybe_hScroll,isJust maybe_vScroll)+				  hScrollRect  = getWindowHScrollRect wMetrics hasScrolls windowRect+				  vScrollRect  = getWindowVScrollRect wMetrics hasScrolls windowRect++				  scrollInfo :: Rect -> ScrollFunction -> ScrollInfo+				  scrollInfo r@(Rect {rleft=rleft,rtop=rtop}) scrollFun+					  = ScrollInfo+					    { scrollFunction = scrollFun+					    , scrollItemPos  = Point2 {x=rleft,y=rtop}+					    , scrollItemSize = rectSize r+					    , scrollItemPtr  = osNoWindowPtr+					    }++++determineRequestedSize :: Size -> Maybe Size -> Size+determineRequestedSize size Nothing  = size+determineRequestedSize _ (Just size) = size+++{-	validateWindowIndex validates the WindowIndex attribute. +	The return Index is the validated Index. +	The return WindowAttribute list does not contain a WindowIndex attribute.+-}+validateWindowIndex :: WindowMode -> [WindowAttribute ls ps] -> WindowHandles ps -> (Index,[WindowAttribute ls ps])+validateWindowIndex mode atts windows@(WindowHandles {whsWindows=whsWindows}) = (okIndex,atts')+	where+		(modal,modeless)      	= span isModalWindow whsWindows+		nrModals      	       	= length modal+		nrModeless 	       	= length modeless+		(_,indexAtt,atts')	= remove isWindowIndex (WindowIndex 0) atts+		index			= getWindowIndexAtt indexAtt+		okIndex                	= if   mode==Modal+		                          then 0						-- Open modal windows frontmost+		                          else setBetween index nrModals (nrModals+nrModeless)	-- Open modeless windows behind the modal windows+++{-	validateWindowPos validates the WindowPos attribute.+	If no WindowPos attribute is given then Nothing is returned.+	If the WindowPos is relative, it is verified that the window relates to an existing window.+	If this is not the case, then Nothing is returned.+	The resulting attribute list does not contain the WindowPos attribute anymore.+-}+validateWindowPos :: WindowMode -> [WindowAttribute ls ps] -> WindowHandles ps+                      -> (Maybe ItemPos,[WindowAttribute ls ps])+validateWindowPos mode atts windows+	| not hasPosAtt+		= (Nothing,atts')+	| not isRelative+		= (Just itemPos,atts')+	| otherwise+		= (if hasWindowHandlesWindow (toWID relativeTo) windows then Just itemPos else Nothing,atts')+	where+		(hasPosAtt,posAtt,atts') = remove isWindowPos undefined atts+		itemPos			 = getWindowPosAtt posAtt+		(isRelative,relativeTo)  = isRelativeItemPos itemPos+++{-	The result ({corner1=A,corner2=B},_) of validateWindowDomain is such that A<B (point A lies to +	the left of and above point B). If either A.x==B.x or A.y==B.y then the ViewDomain is illegal and +	the computation is aborted. +	The default ViewDomain is maximal and positive, i.e.:+		{viewDomainRange & corner1=zero}.+-}+{-	Used only for Window  -}+validateWindowDomain :: [WindowAttribute ls ps] -> (ViewDomain,[WindowAttribute ls ps])+validateWindowDomain atts+	| not hasDomain+		= (viewDomainRange {corner1=zero},atts1)+	| isEmptyRectangle domain+		= windowValidateFatalError "validateWindowDomain" "Window has illegal ViewDomain argument"+	| otherwise+		= (validateViewDomain domain,atts1)+	where+		(hasDomain,domainAtt,atts1) = remove isWindowViewDomain undefined atts+		domain                      = getWindowViewDomainAtt domainAtt++validateViewDomain :: ViewDomain -> ViewDomain+validateViewDomain domain+	= Rectangle+	     { corner1 = Point2+	                    { x = setBetween dl rl rr+	                    , y = setBetween dt rt rb+	                    }+	     , corner2 = Point2+	                    { x = setBetween dr rl rr+	                    , y = setBetween db rt rb+	                    }+	     }+	where+		(Rect {rleft=dl,rtop=dt,rright=dr,rbottom=db}) = rectangleToRect domain+		(Rect {rleft=rl,rtop=rt,rright=rr,rbottom=rb}) = rectangleToRect viewDomainRange+++validateCaretPos :: ViewDomain -> [WindowAttribute ls ps] -> [WindowAttribute ls ps]+validateCaretPos domain atts+	| not hasCaret = atts+	| otherwise    = (WindowCaret (Point2 cx' cy') size) : atts1+	where+		(hasCaret,caretAtt,atts1)  = remove isWindowCaret undefined atts+		(Point2 cx cy, size@(Size cw ch)) = getWindowCaretAtt caretAtt+		(Rect {rleft=dl,rtop=dt,rright=dr,rbottom=db}) = rectangleToRect domain+		cx' = setBetween cx dl (dr-cw)+		cy' = setBetween cy dt (db-ch)+++{-	validateWindowSize wMetrics viewDomain isMDI isResizable (hasHScroll,hasVScroll) atts+		takes care that the Window(View/Outer)Size attribute fits on the current screen.+		The Boolean  isMDI should be True iff the window belongs to a MDI process.+		The Boolean  isResizable should be True iff the window is resizable. +		The Booleans hasHScroll hasVScroll should be True iff the window has the WindowHScroll, WindowVScroll+		attribute set respectively. +		In addition, the WindowOuterSize attribute is mapped to WindowViewSize attribute.+-}+{-	Used only for Window -}+validateWindowSize :: OSWindowMetrics -> ViewDomain -> Bool -> Bool -> (Bool,Bool) -> [WindowAttribute ls ps]+                                                                          -> IO (Size,[WindowAttribute ls ps])+validateWindowSize wMetrics domain isMDI isResizable hasScrolls atts+	| not hasSize = +		let domainSize = rectangleSize domain+		    pictSize   = Size {w=min (w domainSize) (w maxSize),h=min (h domainSize) (h maxSize)}+		in return (pictSize,(WindowViewSize pictSize):atts)+	| isWindowViewSize sizeAtt =+		let size       = getWindowViewSizeAtt sizeAtt+		    size1      = Size {w=setBetween (w size) (fst minSize) (w maxSize),h=setBetween (h size) (snd minSize) (h maxSize)}+		in return (size1,snd (creplace isWindowViewSize (WindowViewSize size1) atts))+	| otherwise = do+		(dw,dh)   <- osStripOuterSize isMDI isResizable+		let	outerSize   = getWindowOuterSizeAtt sizeAtt+			(w',h')     = (w outerSize-dw,h outerSize-dh)+			visScrolls  = osScrollbarsAreVisible wMetrics (rectangleToRect domain) (w',h') hasScrolls+			viewSize    = rectSize (getWindowContentRect wMetrics visScrolls (sizeToRect (Size {w=w',h=h'})))+			(_,_,atts1) = remove isWindowOuterSize undefined atts+			(_,_,atts2) = remove isWindowViewSize  undefined atts1+		return (viewSize,(WindowViewSize viewSize):atts)		+	where+		(hasSize,sizeAtt) = cselect (\att->isWindowViewSize att || isWindowOuterSize att) undefined atts+		minSize           = osMinWindowSize+		maxSize           = maxScrollWindowSize++++{-	validateOrigin takes care that the WindowOrigin attribute is a point in the rectangle+	formed by the left top of the (validated!) ViewDomain, and the width and height of the +	(validated!) derived size.+-}+{-	Used only for Window -}+validateOrigin :: Size -> ViewDomain -> [WindowAttribute ls ps] -> (Point2,[WindowAttribute ls ps])+validateOrigin (Size {w=w,h=h}) domain@(Rectangle {corner1=Point2 {x=l,y=t},corner2=Point2 {x=r,y=b}}) atts+	= (Point2 {x=setBetween (x origin) l (max l (r-w)),y=setBetween (y origin) t (max t (b-h))},atts1)+	where+		(_,domainAtt,atts1) = remove isWindowOrigin (WindowOrigin (corner1 domain)) atts+		origin              = getWindowOriginAtt domainAtt+++{-	validateWindow(H/V)Scroll removes the Window(H/V)Scroll attribute from the attribute list. +-}+{-	Used only for Window  -}+validateWindowHScroll :: [WindowAttribute ls ps] -> (Maybe ScrollFunction,[WindowAttribute ls ps])+validateWindowHScroll atts+	| found     = (Just (getWindowHScrollFun scrollAtt),atts1)+	| otherwise = (Nothing,atts1)+	where+			(found,scrollAtt,atts1) = remove isWindowHScroll undefined atts++{-	Used only for Window -}+validateWindowVScroll :: [WindowAttribute ls ps] -> (Maybe ScrollFunction,[WindowAttribute ls ps])+validateWindowVScroll atts+	| found     = (Just (getWindowVScrollFun scrollAtt),atts1)+	| otherwise = (Nothing,atts1)+	where+		(found,scrollAtt,atts1) = remove isWindowVScroll undefined atts++++{-	validateWindowLook takes care that the optional WindowLook attribute is removed from the attribute list.+	If no attribute was present, then a default look is provided that paints the window with the background colour+	using standard window update mechanism.+-}+--	Used only for Window+validateWindowLook :: [WindowAttribute ls ps] -> (Bool,Look,[WindowAttribute ls ps])+validateWindowLook atts+	= (sysLook,lookFun,atts1)+	where+		(_,lookAtt,atts1) = remove isWindowLook (WindowLook True defaultlook) atts+		(sysLook,lookFun) = getWindowLookAtt lookAtt+		+		defaultlook :: SelectState -> UpdateState -> Draw ()+		defaultlook _ updState = mapM_ unfill (updArea updState)++++--	Retrieve (View/Outer)Size, Margins, ItemSpaces, SelectState, and PenAttributes from the attribute list.++attrSize :: [WindowAttribute ls ps] -> Maybe Size+attrSize atts+	| not hasSize          = Nothing+	| isWindowViewSize att = Just (getWindowViewSizeAtt  att)+	| otherwise            = Just (getWindowOuterSizeAtt att)+	where	+		(hasSize,att)  = cselect (\att->isWindowViewSize att || isWindowOuterSize att) undefined atts++attrMargins :: WindowKind -> OSWindowMetrics -> [WindowAttribute ls ps] -> ((Int,Int),(Int,Int))+attrMargins wKind wMetrics atts+	= (getWindowHMargins wKind wMetrics atts,getWindowVMargins wKind wMetrics atts)++attrSelectState :: [WindowAttribute ls ps] -> Bool+attrSelectState atts+	= enabled (getWindowSelectStateAtt (snd (cselect isWindowSelectState (WindowSelectState Able) atts)))++attrPen :: [WindowAttribute ls ps] -> ([PenAttribute],[WindowAttribute ls ps])+attrPen atts = (getWindowPenAtt penAtt,atts1)+	where (_,penAtt,atts1) = remove isWindowPen (WindowPen []) atts+++{-	get(Ok/Cancel)Id select the Id of the Window(Ok/Cancel) attribute, and checks+	whether this Id corresponds with a (Custom)ButtonControl.+-}++getOkId :: [WindowAttribute ls ps] -> [WElementHandle ls ps] -> Maybe Id+getOkId atts itemHs+	| not hasid 				= Nothing+	| isOkOrCancelControlId id itemHs 	= Just id+	| otherwise 				= Nothing+	where+	  (hasid,idAtt) = cselect isWindowOk undefined atts+	  id            = getWindowOkAtt idAtt++getCancelId :: [WindowAttribute ls ps] -> [WElementHandle ls ps] -> Maybe Id+getCancelId atts itemHs+	| not hasid 			  = Nothing+	| isOkOrCancelControlId id itemHs = Just id+	| otherwise 			  = Nothing+	where+	  (hasid,idAtt) = cselect isWindowCancel undefined atts+	  id            = getWindowCancelAtt idAtt+	  ++{-	Used only by getOkId and getCancelId. -}+isOkOrCancelControlId :: Id -> [WElementHandle ls ps] -> Bool+isOkOrCancelControlId id itemHs =+	case getControlKind id itemHs of+	  Just kind -> kind==IsButtonControl || kind==IsCustomButtonControl+	  Nothing   -> False++{-	validateWindowInitActive checks if the WindowInitActive attribute corresponds with an existing control.+	If this is not the case, the attribute is removed from the attribute list.+-}++validateWindowInitActive :: [WindowAttribute ls ps] -> [WElementHandle ls ps]+                        		-> [WindowAttribute ls ps]+validateWindowInitActive atts itemHs+	| not hasAtt     = atts1+	| isNothing kind = atts1+	| otherwise      = atts+	where+	  (hasAtt,att,atts1) = remove isWindowInitActive undefined atts+	  kind     	     = getControlKind (getWindowInitActiveAtt att) itemHs+++{-	getControlKind id itemHs+		returns (Just ControlKind) of the control in the item list. +		If no such control could be found then Nothing is returned.+-}+{-	Used only by isOkOrCancelControlId and validateWindowInitActive. -}+getControlKind :: Id -> [WElementHandle ls ps] -> Maybe ControlKind+getControlKind id (itemH:itemHs) =+	case getControlKind' id itemH of+	   mk@(Just _) -> mk+	   Nothing     -> getControlKind id itemHs	           +	where+		getControlKind' :: Id -> WElementHandle ls ps -> Maybe ControlKind+		getControlKind' id (WExtendLSHandle addLS itemHs) = getControlKind id itemHs+		getControlKind' id (WChangeLSHandle newLS itemHs) = getControlKind id itemHs+		getControlKind' id (WListLSHandle itemHs) = getControlKind id itemHs+		getControlKind' id itemH@(WItemHandle {wItemId=wItemId,wItemKind=wItemKind,wItems=itemHs})+			| wItemId == Just id 	= Just wItemKind+			| otherwise 		= getControlKind id itemHs+getControlKind _ _ = Nothing++++{-	exactWindowSize determines the exact size of a window.+	The size is extended to fit in sliderbars if requested (argument 4 and 5).+-}+exactWindowSize :: OSWindowMetrics -> ViewDomain -> Size -> Bool -> Bool -> WindowKind -> Size+exactWindowSize wMetrics domain wSize@(Size {w=w,h=h}) hasHScroll hasVScroll wKind+	| wKind==IsDialog          = wSize+	| visHScroll && visVScroll = Size {w=w',h=h'}+	| visHScroll               = wSize {h=h'}+	| visVScroll               = wSize {w=w'}+	| otherwise                = wSize+	where+		visHScroll         = hasHScroll && osScrollbarIsVisible (minmax (x $ corner1 domain) (x $ corner2 domain)) w+		visVScroll         = hasVScroll && osScrollbarIsVisible (minmax (y $ corner1 domain) (y $ corner2 domain)) h+		w'                 = w+osmVSliderWidth  wMetrics+		h'                 = h+osmHSliderHeight wMetrics+++{-	exactWindowPos determines the exact position of a window.+	The size argument must be the exact size as calculated by exactWindowSize of the window.+	The ItemPos argument must be the validated(!) ItemPos attribute of the window.+-}+exactWindowPos :: OSWindowMetrics -> Size -> Maybe ItemPos -> WindowKind -> WindowMode -> WindowHandles ps -> IO Point2+exactWindowPos wMetrics exactSize maybePos wKind wMode windows+	| wKind==IsDialog && wMode==Modal+		= do {+			screenRect <- osScreenRect;+			let+				screenSize = rectSize screenRect+				l          = rleft screenRect + round ((fromIntegral (w screenSize - w exactSize))/2.0)+				t          = rtop  screenRect + round ((fromIntegral (h screenSize - h exactSize))/3.0)+				pos        = Point2 {x=setBetween l (rleft screenRect) (rright screenRect),y=setBetween t (rtop screenRect) (rbottom screenRect)}+			in return pos+		  }+	| isNothing maybePos = return zero+	| otherwise+		= do {+			pos  <- getItemPosPosition wMetrics exactSize (fromJust maybePos) windows;+			pos1 <- setWindowInsideScreen pos exactSize;+			return pos1+		  }+	where+	{-	getItemPosPosition calculates the exact position of the given window. +		getItemPosPosition does not check whether this position will place the window off screen.+	-}+		getItemPosPosition :: OSWindowMetrics -> Size -> ItemPos -> WindowHandles ps -> IO Point2+		getItemPosPosition wMetrics size itemPos windows@(WindowHandles {whsWindows=wsHs})+			| isRelative+				= do {+					rect <- osScreenRect;+					let	unidentifyWindow :: WID -> WindowStateHandle ps -> Bool+						unidentifyWindow wid wsH+							= let ids = getWindowStateHandleWIDS wsH+							  in  not (identifyWIDS wid ids)+						+						screenDomain        = rectToRectangle rect+						screenOrigin        = Point2 {x=rleft rect,y=rtop rect}+						(wptr,wsH1)  = case find (unidentifyWindow (toWID relativeTo)) wsHs of+						                          Nothing -> windowValidateFatalError "getItemPosPosition" "target window could not be found"+						                          Just (wsH@(WindowStateHandle wids wlsH)) -> (wPtr wids,wsH)+						relativeSize 	    = getWindowStateHandleSize wsH1+					in+					do {+						(relativeX,relativeY) <- osGetWindowPos wptr;+						let+							(relativeW,relativeH) = toTuple relativeSize+							(exactW,exactH)       = (w size,h size)+							v                     = itemPosOffset (snd itemPos) screenDomain screenOrigin+							(vx',vy')             = (vx v,vy v)+							pos                   = case (fst itemPos) of+							                            (LeftOf  _) -> Point2 {x=relativeX+vx'-exactW,   y=relativeY+vy'}+							                            (RightTo _) -> Point2 {x=relativeX+vx'+relativeW,y=relativeY+vy'}+							                            (Above   _) -> Point2 {x=relativeX+vx',          y=relativeY+vy'-exactH}+							                            (Below   _) -> Point2 {x=relativeX+vx',          y=relativeY+vy'+relativeH}+							                            other       -> windowValidateFatalError "getItemPosPosition" "unexpected ItemLoc alternative"+						in return pos+					}+				  }+			| isAbsolute+				= do {+					rect <- osScreenRect;+					let	screenDomain        = rectToRectangle rect+						screenOrigin        = Point2 {x=rleft rect,y=rtop rect}+					in return (movePoint (itemPosOffset offset screenDomain screenOrigin) zero)+				  }+			| isCornerItemPos itemPos+				= do {+					rect <- osScreenRect;+					let	screenDomain        = rectToRectangle rect+						screenOrigin        = Point2 {x=rleft rect,y=rtop rect}+						(exactW,exactH)     = toTuple size+						v                   = itemPosOffset (snd itemPos) screenDomain screenOrigin+						(vx',vy')           = (vx v,vy v)+						pos                 = case (fst itemPos) of+						                           LeftTop     -> Point2 {x=rleft  rect + vx',        y=rtop    rect + vy'}+						                           RightTop    -> Point2 {x=rright rect + vx'-exactW, y=rtop    rect + vy'}+						                           LeftBottom  -> Point2 {x=rleft  rect + vx',        y=rbottom rect + vy'-exactH}+						                           RightBottom -> Point2 {x=rright rect + vx'-exactW, y=rbottom rect + vy'-exactH}+					in return pos+				  }+			| otherwise+				= return zero+			where+				(isRelative,relativeTo) = isRelativeItemPos itemPos+				(isAbsolute,offset)     = isAbsoluteItemPos itemPos+		+	{-	setWindowInsideScreen makes sure that a window at the given position and given size will be on screen.+	-}+		setWindowInsideScreen :: Point2 -> Size -> IO Point2+		setWindowInsideScreen pos@(Point2 {x=x,y=y}) size@(Size {w=w,h=h})+			= do {+				screenRect <- osScreenRect;+				let+					(Size {w=screenW,h=screenH})+					        = rectSize screenRect+					(x',y') = (setBetween x (rleft screenRect) (rright screenRect-w),setBetween y (rtop screenRect) (rbottom screenRect-h))+					pos1    = if   w<=screenW && h<=screenH then Point2 {x=x',y=y'}		-- window fits entirely on screen+					          else if w<=screenW            then Point2 {x=x',y=0 }		-- window is to high+					          else if h<=screenH            then Point2 {x=0, y=y'}		-- window is to wide+					                                        else zero			-- window doesn't fit anyway+				in return pos1+			  }+++--	itemPosOffset calculates the actual offset vector of the given ItemOffset value.++itemPosOffset :: ItemOffset -> ViewDomain -> Point2 -> Vector2+{-+itemPosOffset NoOffset _ _+	= zero+-}+itemPosOffset {-(OffsetVector v)-}v _ _+	= v+{-+itemPosOffset (OffsetFun i f) domain origin+	| i==1       = f (domain,origin)+	| otherwise  = windowValidateFatalError "calculating OffsetFun" ("illegal ParentIndex value: "++show i)+-}+++--	Predicates on ItemPos:+isRelativeItemPos :: ItemPos -> (Bool,Id)+isRelativeItemPos (LeftOf  id,_) = (True, id)+isRelativeItemPos (RightTo id,_) = (True, id)+isRelativeItemPos (Above   id,_) = (True, id)+isRelativeItemPos (Below   id,_) = (True, id)+isRelativeItemPos _              = (False,undefined)++isAbsoluteItemPos :: ItemPos -> (Bool,ItemOffset)+isAbsoluteItemPos (Fix,offset) = (True, offset)+isAbsoluteItemPos _            = (False,undefined)++isCornerItemPos :: ItemPos -> Bool+isCornerItemPos (LeftTop,_)     = True+isCornerItemPos (RightTop,_)    = True+isCornerItemPos (LeftBottom,_)  = True+isCornerItemPos (RightBottom,_) = True+isCornerItemPos _               = False
+ ObjectIO.cabal view
@@ -0,0 +1,129 @@+name:       ObjectIO+version:    1.0.1.1+license:    BSD3+maintainer: ka2_mail@yahoo.com+exposed-modules:+    Graphics.UI.ObjectIO.Control.Access,+    Graphics.UI.ObjectIO.Control.Create,+    Graphics.UI.ObjectIO.Control.Draw,+    Graphics.UI.ObjectIO.Control.Internal,+    Graphics.UI.ObjectIO.Control.Layout,+    Graphics.UI.ObjectIO.Control.Pos,+    Graphics.UI.ObjectIO.Control.Relayout,+    Graphics.UI.ObjectIO.Control.Resize,+    Graphics.UI.ObjectIO.Control.Validate,+    Graphics.UI.ObjectIO.CommonDef,+    Graphics.UI.ObjectIO.Id,+    Graphics.UI.ObjectIO.Key,+    Graphics.UI.ObjectIO.KeyFocus,+    Graphics.UI.ObjectIO.Layout,+    Graphics.UI.ObjectIO.Relayout,+    Graphics.UI.ObjectIO.StdBitmap,+    Graphics.UI.ObjectIO.StdClipboard,+    Graphics.UI.ObjectIO.StdControl,+    Graphics.UI.ObjectIO.StdControlAttribute,+    Graphics.UI.ObjectIO.StdControlClass,+    Graphics.UI.ObjectIO.StdControlDef,+    Graphics.UI.ObjectIO.StdControlReceiver,+    Graphics.UI.ObjectIO.StdFileSelect,+    Graphics.UI.ObjectIO.StdGUI,+    Graphics.UI.ObjectIO.StdIOBasic,+    Graphics.UI.ObjectIO.StdIOCommon,+    Graphics.UI.ObjectIO.StdId,+    Graphics.UI.ObjectIO.StdKey,+    Graphics.UI.ObjectIO.StdMenu,+    Graphics.UI.ObjectIO.StdMenuAttribute,+    Graphics.UI.ObjectIO.StdMenuDef,+    Graphics.UI.ObjectIO.StdMenuElement,+    Graphics.UI.ObjectIO.StdMenuElementClass,+    Graphics.UI.ObjectIO.StdMenuReceiver,+    Graphics.UI.ObjectIO.StdPicture,+    Graphics.UI.ObjectIO.StdPictureDef,+    Graphics.UI.ObjectIO.StdProcess,+    Graphics.UI.ObjectIO.StdProcessAttribute,+    Graphics.UI.ObjectIO.StdProcessDef,+    Graphics.UI.ObjectIO.StdReceiver,+    Graphics.UI.ObjectIO.StdReceiverAttribute,+    Graphics.UI.ObjectIO.StdReceiverDef,+    Graphics.UI.ObjectIO.StdSound,+    Graphics.UI.ObjectIO.StdSystem,+    Graphics.UI.ObjectIO.StdTimer,+    Graphics.UI.ObjectIO.StdTimerAttribute,+    Graphics.UI.ObjectIO.StdTimerDef,+    Graphics.UI.ObjectIO.StdTimerElementClass,+    Graphics.UI.ObjectIO.StdTimerReceiver,+    Graphics.UI.ObjectIO.StdWindow,+    Graphics.UI.ObjectIO.StdWindowAttribute,+    Graphics.UI.ObjectIO.StdWindowDef,+    Graphics.UI.ObjectIO.SystemId,+    Graphics.UI.ObjectIO.Device.Events,+    Graphics.UI.ObjectIO.Device.SystemState,+    Graphics.UI.ObjectIO.Device.Types,+    Graphics.UI.ObjectIO.Menu.Access,+    Graphics.UI.ObjectIO.Menu.Create,+    Graphics.UI.ObjectIO.Menu.DefAccess,+    Graphics.UI.ObjectIO.Menu.Device,+    Graphics.UI.ObjectIO.Menu.Handle,+    Graphics.UI.ObjectIO.Menu.Internal,+    Graphics.UI.ObjectIO.Menu.Items,+    Graphics.UI.ObjectIO.OS.Bitmap,+    Graphics.UI.ObjectIO.OS.ClCCall_12,+    Graphics.UI.ObjectIO.OS.ClCrossCall_12,+    Graphics.UI.ObjectIO.OS.Clipboard,+    Graphics.UI.ObjectIO.OS.Cutil_12,+    Graphics.UI.ObjectIO.OS.DocumentInterface,+    Graphics.UI.ObjectIO.OS.Event,+    Graphics.UI.ObjectIO.OS.FileSelect,+    Graphics.UI.ObjectIO.OS.Font,+    Graphics.UI.ObjectIO.OS.Menu,+    Graphics.UI.ObjectIO.OS.MenuEvent,+    Graphics.UI.ObjectIO.OS.Picture,+    Graphics.UI.ObjectIO.OS.ProcessEvent,+    Graphics.UI.ObjectIO.OS.ReceiverEvent,+    Graphics.UI.ObjectIO.OS.Rgn,+    Graphics.UI.ObjectIO.OS.System,+    Graphics.UI.ObjectIO.OS.Time,+    Graphics.UI.ObjectIO.OS.TimerEvent,+    Graphics.UI.ObjectIO.OS.ToolBar,+    Graphics.UI.ObjectIO.OS.ToolTip,+    Graphics.UI.ObjectIO.OS.Types,+    Graphics.UI.ObjectIO.OS.Window,+    Graphics.UI.ObjectIO.OS.WindowCCall_12,+    Graphics.UI.ObjectIO.OS.WindowCrossCall_12,+    Graphics.UI.ObjectIO.OS.WindowEvent,+    Graphics.UI.ObjectIO.Process.Device,+    Graphics.UI.ObjectIO.Process.IOState,+    Graphics.UI.ObjectIO.Process.Scheduler,+    Graphics.UI.ObjectIO.Process.Toolbar,+    Graphics.UI.ObjectIO.Receiver.Access,+    Graphics.UI.ObjectIO.Receiver.DefAccess,+    Graphics.UI.ObjectIO.Receiver.Device,+    Graphics.UI.ObjectIO.Receiver.Handle,+    Graphics.UI.ObjectIO.Timer.Access,+    Graphics.UI.ObjectIO.Timer.DefAccess,+    Graphics.UI.ObjectIO.Timer.Device,+    Graphics.UI.ObjectIO.Timer.Handle,+    Graphics.UI.ObjectIO.Timer.Table,+    Graphics.UI.ObjectIO.Window.Access,+    Graphics.UI.ObjectIO.Window.ClipState,+    Graphics.UI.ObjectIO.Window.Controls,+    Graphics.UI.ObjectIO.Window.Create,+    Graphics.UI.ObjectIO.Window.Device,+    Graphics.UI.ObjectIO.Window.Dispose,+    Graphics.UI.ObjectIO.Window.Draw,+    Graphics.UI.ObjectIO.Window.Handle,+    Graphics.UI.ObjectIO.Window.SDISize,+    Graphics.UI.ObjectIO.Window.Update,+    Graphics.UI.ObjectIO.Window.Validate,+    Graphics.UI.ObjectIO+extra-libraries:    "user32",+                    "gdi32",+                    "kernel32",+                    "comctl32",+                    "comdlg32",+                    "shell32",+                    "winmm",+                    "winspool",+                    "ole32"+depends: base+
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain