diff --git a/Graphics/UI/ObjectIO.hs b/Graphics/UI/ObjectIO.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/CommonDef.hs b/Graphics/UI/ObjectIO/CommonDef.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/CommonDef.hs @@ -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 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 \ \[module\] \ . + +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! \ . + +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 diff --git a/Graphics/UI/ObjectIO/Control/Access.hs b/Graphics/UI/ObjectIO/Control/Access.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Control/Access.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Control/Create.hs b/Graphics/UI/ObjectIO/Control/Create.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Control/Create.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Control/Draw.hs b/Graphics/UI/ObjectIO/Control/Draw.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Control/Draw.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Control/Internal.hs b/Graphics/UI/ObjectIO/Control/Internal.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Control/Internal.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/Control/Layout.hs b/Graphics/UI/ObjectIO/Control/Layout.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Control/Layout.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/Control/Pos.hs b/Graphics/UI/ObjectIO/Control/Pos.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Control/Pos.hs @@ -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]) diff --git a/Graphics/UI/ObjectIO/Control/Relayout.hs b/Graphics/UI/ObjectIO/Control/Relayout.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Control/Relayout.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Control/Resize.hs b/Graphics/UI/ObjectIO/Control/Resize.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Control/Resize.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Control/Validate.hs b/Graphics/UI/ObjectIO/Control/Validate.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Control/Validate.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Device/Events.hs b/Graphics/UI/ObjectIO/Device/Events.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Device/Events.hs @@ -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 + } diff --git a/Graphics/UI/ObjectIO/Device/SystemState.hs b/Graphics/UI/ObjectIO/Device/SystemState.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Device/SystemState.hs @@ -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 + diff --git a/Graphics/UI/ObjectIO/Device/Types.hs b/Graphics/UI/ObjectIO/Device/Types.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Device/Types.hs @@ -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 + ] diff --git a/Graphics/UI/ObjectIO/Id.hs b/Graphics/UI/ObjectIO/Id.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Id.hs @@ -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 + + + + + + + + + diff --git a/Graphics/UI/ObjectIO/Key.hs b/Graphics/UI/ObjectIO/Key.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Key.hs @@ -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 + ] diff --git a/Graphics/UI/ObjectIO/KeyFocus.hs b/Graphics/UI/ObjectIO/KeyFocus.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/KeyFocus.hs @@ -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}) diff --git a/Graphics/UI/ObjectIO/Layout.hs b/Graphics/UI/ObjectIO/Layout.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Layout.hs @@ -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 _ _ + = ([],[]) diff --git a/Graphics/UI/ObjectIO/Menu/Access.hs b/Graphics/UI/ObjectIO/Menu/Access.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Menu/Access.hs @@ -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}} diff --git a/Graphics/UI/ObjectIO/Menu/Create.hs b/Graphics/UI/ObjectIO/Menu/Create.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Menu/Create.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Menu/DefAccess.hs b/Graphics/UI/ObjectIO/Menu/DefAccess.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Menu/DefAccess.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/Menu/Device.hs b/Graphics/UI/ObjectIO/Menu/Device.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Menu/Device.hs @@ -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 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 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) diff --git a/Graphics/UI/ObjectIO/Menu/Handle.hs b/Graphics/UI/ObjectIO/Menu/Handle.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Menu/Handle.hs @@ -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 + } diff --git a/Graphics/UI/ObjectIO/Menu/Internal.hs b/Graphics/UI/ObjectIO/Menu/Internal.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Menu/Internal.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Menu/Items.hs b/Graphics/UI/ObjectIO/Menu/Items.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Menu/Items.hs @@ -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 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 [] diff --git a/Graphics/UI/ObjectIO/OS/Bitmap.hs b/Graphics/UI/ObjectIO/OS/Bitmap.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/Bitmap.hs @@ -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 () diff --git a/Graphics/UI/ObjectIO/OS/ClCCall_12.hs b/Graphics/UI/ObjectIO/OS/ClCCall_12.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/ClCCall_12.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/OS/ClCrossCall_12.hs b/Graphics/UI/ObjectIO/OS/ClCrossCall_12.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/ClCrossCall_12.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/OS/Clipboard.hs b/Graphics/UI/ObjectIO/OS/Clipboard.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/Clipboard.hs @@ -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 []) diff --git a/Graphics/UI/ObjectIO/OS/Cutil_12.hs b/Graphics/UI/ObjectIO/OS/Cutil_12.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/Cutil_12.hs @@ -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 + } diff --git a/Graphics/UI/ObjectIO/OS/DocumentInterface.hs b/Graphics/UI/ObjectIO/OS/DocumentInterface.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/DocumentInterface.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/OS/Event.hs b/Graphics/UI/ObjectIO/OS/Event.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/Event.hs @@ -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) [] diff --git a/Graphics/UI/ObjectIO/OS/FileSelect.hs b/Graphics/UI/ObjectIO/OS/FileSelect.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/FileSelect.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/OS/Font.hs b/Graphics/UI/ObjectIO/OS/Font.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/Font.hs @@ -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) + | ab = 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 () diff --git a/Graphics/UI/ObjectIO/OS/Menu.hs b/Graphics/UI/ObjectIO/OS/Menu.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/Menu.hs @@ -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 () diff --git a/Graphics/UI/ObjectIO/OS/MenuEvent.hs b/Graphics/UI/ObjectIO/OS/MenuEvent.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/MenuEvent.hs @@ -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=[]}) diff --git a/Graphics/UI/ObjectIO/OS/Picture.hs b/Graphics/UI/ObjectIO/OS/Picture.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/Picture.hs @@ -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 () diff --git a/Graphics/UI/ObjectIO/OS/ProcessEvent.hs b/Graphics/UI/ObjectIO/OS/ProcessEvent.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/ProcessEvent.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/OS/ReceiverEvent.hs b/Graphics/UI/ObjectIO/OS/ReceiverEvent.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/ReceiverEvent.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/OS/Rgn.hs b/Graphics/UI/ObjectIO/OS/Rgn.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/Rgn.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/OS/System.hs b/Graphics/UI/ObjectIO/OS/System.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/System.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/OS/Time.hs b/Graphics/UI/ObjectIO/OS/Time.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/Time.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/OS/TimerEvent.hs b/Graphics/UI/ObjectIO/OS/TimerEvent.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/TimerEvent.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/OS/ToolBar.hs b/Graphics/UI/ObjectIO/OS/ToolBar.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/ToolBar.hs @@ -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 () diff --git a/Graphics/UI/ObjectIO/OS/ToolTip.hs b/Graphics/UI/ObjectIO/OS/ToolTip.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/ToolTip.hs @@ -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 () diff --git a/Graphics/UI/ObjectIO/OS/Types.hs b/Graphics/UI/ObjectIO/OS/Types.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/Types.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/OS/Window.hs b/Graphics/UI/ObjectIO/OS/Window.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/Window.hs @@ -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 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 diff --git a/Graphics/UI/ObjectIO/OS/WindowCCall_12.hs b/Graphics/UI/ObjectIO/OS/WindowCCall_12.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/WindowCCall_12.hs @@ -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 () diff --git a/Graphics/UI/ObjectIO/OS/WindowCrossCall_12.hs b/Graphics/UI/ObjectIO/OS/WindowCrossCall_12.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/WindowCrossCall_12.hs @@ -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 () diff --git a/Graphics/UI/ObjectIO/OS/WindowEvent.hs b/Graphics/UI/ObjectIO/OS/WindowEvent.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/OS/WindowEvent.hs @@ -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}}) + diff --git a/Graphics/UI/ObjectIO/Process/Device.hs b/Graphics/UI/ObjectIO/Process/Device.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Process/Device.hs @@ -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" diff --git a/Graphics/UI/ObjectIO/Process/IOState.hs b/Graphics/UI/ObjectIO/Process/IOState.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Process/IOState.hs @@ -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 _ [] = [] diff --git a/Graphics/UI/ObjectIO/Process/Scheduler.hs b/Graphics/UI/ObjectIO/Process/Scheduler.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Process/Scheduler.hs @@ -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 + diff --git a/Graphics/UI/ObjectIO/Process/Toolbar.hs b/Graphics/UI/ObjectIO/Process/Toolbar.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Process/Toolbar.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Receiver/Access.hs b/Graphics/UI/ObjectIO/Receiver/Access.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Receiver/Access.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Receiver/DefAccess.hs b/Graphics/UI/ObjectIO/Receiver/DefAccess.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Receiver/DefAccess.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Receiver/Device.hs b/Graphics/UI/ObjectIO/Receiver/Device.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Receiver/Device.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Receiver/Handle.hs b/Graphics/UI/ObjectIO/Receiver/Handle.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Receiver/Handle.hs @@ -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}) diff --git a/Graphics/UI/ObjectIO/Relayout.hs b/Graphics/UI/ObjectIO/Relayout.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Relayout.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/StdBitmap.hs b/Graphics/UI/ObjectIO/StdBitmap.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdBitmap.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdClipboard.hs b/Graphics/UI/ObjectIO/StdClipboard.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdClipboard.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/StdControl.hs b/Graphics/UI/ObjectIO/StdControl.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdControl.hs @@ -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]) diff --git a/Graphics/UI/ObjectIO/StdControlAttribute.hs b/Graphics/UI/ObjectIO/StdControlAttribute.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdControlAttribute.hs @@ -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 + diff --git a/Graphics/UI/ObjectIO/StdControlClass.hs b/Graphics/UI/ObjectIO/StdControlClass.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdControlClass.hs @@ -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 + } diff --git a/Graphics/UI/ObjectIO/StdControlDef.hs b/Graphics/UI/ObjectIO/StdControlDef.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdControlDef.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdControlReceiver.hs b/Graphics/UI/ObjectIO/StdControlReceiver.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdControlReceiver.hs @@ -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)) diff --git a/Graphics/UI/ObjectIO/StdFileSelect.hs b/Graphics/UI/ObjectIO/StdFileSelect.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdFileSelect.hs @@ -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 () diff --git a/Graphics/UI/ObjectIO/StdGUI.hs b/Graphics/UI/ObjectIO/StdGUI.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdGUI.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdIOBasic.hs b/Graphics/UI/ObjectIO/StdIOBasic.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdIOBasic.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdIOCommon.hs b/Graphics/UI/ObjectIO/StdIOCommon.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdIOCommon.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/StdId.hs b/Graphics/UI/ObjectIO/StdId.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdId.hs @@ -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)) diff --git a/Graphics/UI/ObjectIO/StdKey.hs b/Graphics/UI/ObjectIO/StdKey.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdKey.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/StdMenu.hs b/Graphics/UI/ObjectIO/StdMenu.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdMenu.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdMenuAttribute.hs b/Graphics/UI/ObjectIO/StdMenuAttribute.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdMenuAttribute.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdMenuDef.hs b/Graphics/UI/ObjectIO/StdMenuDef.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdMenuDef.hs @@ -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 + diff --git a/Graphics/UI/ObjectIO/StdMenuElement.hs b/Graphics/UI/ObjectIO/StdMenuElement.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdMenuElement.hs @@ -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]) diff --git a/Graphics/UI/ObjectIO/StdMenuElementClass.hs b/Graphics/UI/ObjectIO/StdMenuElementClass.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdMenuElementClass.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdMenuReceiver.hs b/Graphics/UI/ObjectIO/StdMenuReceiver.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdMenuReceiver.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdPicture.hs b/Graphics/UI/ObjectIO/StdPicture.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdPicture.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdPictureDef.hs b/Graphics/UI/ObjectIO/StdPictureDef.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdPictureDef.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdProcess.hs b/Graphics/UI/ObjectIO/StdProcess.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdProcess.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/StdProcessAttribute.hs b/Graphics/UI/ObjectIO/StdProcessAttribute.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdProcessAttribute.hs @@ -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 + diff --git a/Graphics/UI/ObjectIO/StdProcessDef.hs b/Graphics/UI/ObjectIO/StdProcessDef.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdProcessDef.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdReceiver.hs b/Graphics/UI/ObjectIO/StdReceiver.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdReceiver.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/StdReceiverAttribute.hs b/Graphics/UI/ObjectIO/StdReceiverAttribute.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdReceiverAttribute.hs @@ -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 +-} diff --git a/Graphics/UI/ObjectIO/StdReceiverDef.hs b/Graphics/UI/ObjectIO/StdReceiverDef.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdReceiverDef.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdSound.hs b/Graphics/UI/ObjectIO/StdSound.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdSound.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdSystem.hs b/Graphics/UI/ObjectIO/StdSystem.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdSystem.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdTimer.hs b/Graphics/UI/ObjectIO/StdTimer.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdTimer.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/StdTimerAttribute.hs b/Graphics/UI/ObjectIO/StdTimerAttribute.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdTimerAttribute.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdTimerDef.hs b/Graphics/UI/ObjectIO/StdTimerDef.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdTimerDef.hs @@ -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 + diff --git a/Graphics/UI/ObjectIO/StdTimerElementClass.hs b/Graphics/UI/ObjectIO/StdTimerElementClass.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdTimerElementClass.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/StdTimerReceiver.hs b/Graphics/UI/ObjectIO/StdTimerReceiver.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdTimerReceiver.hs @@ -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)) diff --git a/Graphics/UI/ObjectIO/StdWindow.hs b/Graphics/UI/ObjectIO/StdWindow.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdWindow.hs @@ -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" diff --git a/Graphics/UI/ObjectIO/StdWindowAttribute.hs b/Graphics/UI/ObjectIO/StdWindowAttribute.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdWindowAttribute.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/StdWindowDef.hs b/Graphics/UI/ObjectIO/StdWindowDef.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/StdWindowDef.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/SystemId.hs b/Graphics/UI/ObjectIO/SystemId.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/SystemId.hs @@ -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 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 diff --git a/Graphics/UI/ObjectIO/Timer/DefAccess.hs b/Graphics/UI/ObjectIO/Timer/DefAccess.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Timer/DefAccess.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Timer/Device.hs b/Graphics/UI/ObjectIO/Timer/Device.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Timer/Device.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/Timer/Handle.hs b/Graphics/UI/ObjectIO/Timer/Handle.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Timer/Handle.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Timer/Table.hs b/Graphics/UI/ObjectIO/Timer/Table.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Timer/Table.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Window/Access.hs b/Graphics/UI/ObjectIO/Window/Access.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Window/Access.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Window/ClipState.hs b/Graphics/UI/ObjectIO/Window/ClipState.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Window/ClipState.hs @@ -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}}}}) diff --git a/Graphics/UI/ObjectIO/Window/Controls.hs b/Graphics/UI/ObjectIO/Window/Controls.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Window/Controls.hs @@ -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" diff --git a/Graphics/UI/ObjectIO/Window/Create.hs b/Graphics/UI/ObjectIO/Window/Create.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Window/Create.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Window/Device.hs b/Graphics/UI/ObjectIO/Window/Device.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Window/Device.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/Window/Dispose.hs b/Graphics/UI/ObjectIO/Window/Dispose.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Window/Dispose.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/Window/Draw.hs b/Graphics/UI/ObjectIO/Window/Draw.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Window/Draw.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/Window/Handle.hs b/Graphics/UI/ObjectIO/Window/Handle.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Window/Handle.hs @@ -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 diff --git a/Graphics/UI/ObjectIO/Window/SDISize.hs b/Graphics/UI/ObjectIO/Window/SDISize.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Window/SDISize.hs @@ -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" diff --git a/Graphics/UI/ObjectIO/Window/Update.hs b/Graphics/UI/ObjectIO/Window/Update.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Window/Update.hs @@ -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) diff --git a/Graphics/UI/ObjectIO/Window/Validate.hs b/Graphics/UI/ObjectIO/Window/Validate.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/ObjectIO/Window/Validate.hs @@ -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 (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 diff --git a/ObjectIO.cabal b/ObjectIO.cabal new file mode 100644 --- /dev/null +++ b/ObjectIO.cabal @@ -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 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain