{-# INCLUDE "wxc.h" #-} {-# LANGUAGE ForeignFunctionInterface, FlexibleInstances #-} ----------------------------------------------------------------------------------------- {-| Module : Types Copyright : (c) Daan Leijen 2003 License : wxWindows Maintainer : wxhaskell-devel@lists.sourceforge.net Stability : provisional Portability : portable Basic types and operations. -} ----------------------------------------------------------------------------------------- module Graphics.UI.WXCore.Types( -- * Objects ( # ) , Object, objectNull, objectIsNull, objectCast, objectIsManaged , objectDelete , withObjectPtr, withObjectRef , withObjectResult, withManagedObjectResult , objectFinalize, objectNoFinalize , objectFromPtr, managedObjectFromPtr -- , Managed, managedNull, managedIsNull, managedCast, createManaged, withManaged, managedTouch -- * Identifiers , Id, idAny, idCreate -- * Bits , (.+.), (.-.) , bits , bitsSet -- * Control , unitIO, bracket, bracket_, finally, finalize, when -- * Variables , Var, varCreate, varGet, varSet, varUpdate, varSwap -- * Misc. , Style , EventId , TreeItem, treeItemInvalid, treeItemIsOk -- * Basic types -- ** Booleans , boolFromInt, intFromBool -- ** Colors , Color, rgb, colorRGB, colorRed, colorGreen, colorBlue, intFromColor, colorFromInt, colorOk , black, darkgrey, dimgrey, mediumgrey, grey, lightgrey, white , red, green, blue , cyan, magenta, yellow -- *** System colors , SystemColor(..), colorSystem -- ** Points , Point, Point2(Point,pointX,pointY), point, pt, pointFromVec, pointFromSize, pointZero, pointNull , pointMove, pointMoveBySize, pointAdd, pointSub, pointScale -- ** Sizes , Size, Size2D(Size,sizeW,sizeH), sz, sizeFromPoint, sizeFromVec, sizeZero, sizeNull, sizeEncloses , sizeMin, sizeMax -- ** Vectors , Vector, Vector2(Vector,vecX,vecY), vector, vec, vecFromPoint, vecFromSize, vecZero, vecNull , vecNegate, vecOrtogonal, vecAdd, vecSub, vecScale, vecBetween, vecLength , vecLengthDouble -- ** Rectangles , Rect, Rect2D(Rect,rectLeft,rectTop,rectWidth,rectHeight) , rectTopLeft, rectTopRight, rectBottomLeft, rectBottomRight, rectBottom, rectRight , rect, rectBetween, rectFromSize, rectZero, rectNull, rectSize, rectIsEmpty , rectContains, rectMoveTo, rectFromPoint, rectCentralPoint, rectCentralRect, rectStretchTo , rectCentralPointDouble, rectCentralRectDouble , rectMove, rectOverlaps, rectsDiff, rectUnion, rectOverlap, rectUnions ) where import Data.List( (\\) ) import Graphics.UI.WXCore.WxcTypes import Graphics.UI.WXCore.WxcDefs import Graphics.UI.WXCore.WxcClasses( wxcSystemSettingsGetColour ) import System.IO.Unsafe( unsafePerformIO ) -- utility import Data.Array import Data.Bits import Control.Concurrent.STM import qualified Control.Exception as CE import qualified Control.Monad as M infixl 5 .+. infixl 5 .-. infix 5 # -- | Reverse application, i.e. @x # f@ = @f x@. -- Useful for an object oriented style of programming. -- -- > (frame # frameSetTitle) "hi" -- ( # ) :: obj -> (obj -> a) -> a object # method = method object {-------------------------------------------------------------------------------- Bitmasks --------------------------------------------------------------------------------} -- | Bitwise /or/ of two bit masks. (.+.) :: Int -> Int -> Int (.+.) i j = i .|. j -- | Unset certain bits in a bitmask. (.-.) :: Int -> BitFlag -> Int (.-.) i j = i .&. complement j -- | Bitwise /or/ of a list of bit masks. bits :: [Int] -> Int bits xs = foldr (.+.) 0 xs -- | (@bitsSet mask i@) tests if all bits in @mask@ are also set in @i@. bitsSet :: Int -> Int -> Bool bitsSet mask i = (i .&. mask == mask) {-------------------------------------------------------------------------------- Id --------------------------------------------------------------------------------} {-# NOINLINE varTopId #-} varTopId :: Var Id varTopId = unsafePerformIO (varCreate (wxID_HIGHEST+1)) -- | When creating a new window you may specify 'idAny' to let wxWindows -- assign an unused identifier to it automatically. Furthermore, it can be -- used in an event connection to handle events for any identifier. idAny :: Id idAny = -1 -- | Create a new unique identifier. idCreate :: IO Id idCreate = varUpdate varTopId (+1) {-------------------------------------------------------------------------------- Control --------------------------------------------------------------------------------} -- | Ignore the result of an 'IO' action. unitIO :: IO a -> IO () unitIO io = do io; return () -- | Perform an action when a test succeeds. when :: Bool -> IO () -> IO () when = M.when -- | Properly release resources, even in the event of an exception. bracket :: IO a -- ^ computation to run first (acquire resource) -> (a -> IO b) -- ^ computation to run last (release resource) -> (a -> IO c) -- ^ computation to run in-between (use resource) -> IO c bracket = CE.bracket -- | Specialized variant of 'bracket' where the return value is not required. bracket_ :: IO a -- ^ computation to run first (acquire resource) -> IO b -- ^ computation to run last (release resource) -> IO c -- ^ computation to run in-between (use resource) -> IO c bracket_ = CE.bracket_ -- | Run some computation afterwards, even if an exception occurs. finally :: IO a -- ^ computation to run first -> IO b -- ^ computation to run last (release resource) -> IO a finally = CE.finally -- | Run some computation afterwards, even if an exception occurs. Equals 'finally' but -- with the arguments swapped. finalize :: IO b -- ^ computation to run last (release resource) -> IO a -- ^ computation to run first -> IO a finalize last first = finally first last {-------------------------------------------------------------------------------- Variables --------------------------------------------------------------------------------} -- | A mutable variable. Use this instead of 'MVar's or 'IORef's to accomodate for -- future expansions with possible concurrency. type Var a = TVar a -- | Create a fresh mutable variable. varCreate :: a -> IO (Var a) varCreate x = newTVarIO x -- | Get the value of a mutable variable. varGet :: Var a -> IO a varGet v = atomically $ readTVar v -- | Set the value of a mutable variable. varSet :: Var a -> a -> IO () varSet v x = atomically $ writeTVar v x -- | Swap the value of a mutable variable. varSwap :: Var a -> a -> IO a varSwap v x = atomically $ do prev <- readTVar v writeTVar v x return prev -- | Update the value of a mutable variable and return the old value. varUpdate :: Var a -> (a -> a) -> IO a varUpdate v f = atomically $ do x <- readTVar v writeTVar v (f x) return x {----------------------------------------------------------------------------------------- Point -----------------------------------------------------------------------------------------} pointMove :: (Num a) => Vector2 a -> Point2 a -> Point2 a pointMove (Vector dx dy) (Point x y) = Point (x+dx) (y+dy) pointMoveBySize :: (Num a) => Point2 a -> Size2D a -> Point2 a pointMoveBySize (Point x y) (Size w h) = Point (x + w) (y + h) pointAdd :: (Num a) => Point2 a -> Point2 a -> Point2 a pointAdd (Point x1 y1) (Point x2 y2) = Point (x1+x2) (y1+y2) pointSub :: (Num a) => Point2 a -> Point2 a -> Point2 a pointSub (Point x1 y1) (Point x2 y2) = Point (x1-x2) (y1-y2) pointScale :: (Num a) => Point2 a -> a -> Point2 a pointScale (Point x y) v = Point (v*x) (v*y) instance (Num a, Ord a) => Ord (Point2 a) where compare (Point x1 y1) (Point x2 y2) = case compare y1 y2 of EQ -> compare x1 x2 neq -> neq instance Ix (Point2 Int) where range (Point x1 y1,Point x2 y2) = [Point x y | y <- [y1..y2], x <- [x1..x2]] inRange (Point x1 y1, Point x2 y2) (Point x y) = (x >= x1 && x <= x2 && y >= y1 && y <= y2) rangeSize (Point x1 y1, Point x2 y2) = let w = abs (x2 - x1) + 1 h = abs (y2 - y1) + 1 in w*h index bnd@(Point x1 y1, Point x2 y2) p@(Point x y) = if inRange bnd p then let w = abs (x2 - x1) + 1 in (y-y1)*w + x else error ("Point index out of bounds: " ++ show p ++ " not in " ++ show bnd) {----------------------------------------------------------------------------------------- Size -----------------------------------------------------------------------------------------} -- | Return the width. (see also 'sizeW'). sizeWidth :: (Num a) => Size2D a -> a sizeWidth (Size w h) = w -- | Return the height. (see also 'sizeH'). sizeHeight :: (Num a) => Size2D a -> a sizeHeight (Size w h) = h -- | Returns 'True' if the first size totally encloses the second argument. sizeEncloses :: (Num a, Ord a) => Size2D a -> Size2D a -> Bool sizeEncloses (Size w0 h0) (Size w1 h1) = (w0 >= w1) && (h0 >= h1) -- | The minimum of two sizes. sizeMin :: (Num a, Ord a) => Size2D a -> Size2D a -> Size2D a sizeMin (Size w0 h0) (Size w1 h1) = Size (min w0 w1) (min h0 h1) -- | The maximum of two sizes. sizeMax :: (Num a, Ord a) => Size2D a -> Size2D a -> Size2D a sizeMax (Size w0 h0) (Size w1 h1) = Size (max w0 w1) (max h0 h1) {----------------------------------------------------------------------------------------- Vector -----------------------------------------------------------------------------------------} vecNegate :: (Num a) => Vector2 a -> Vector2 a vecNegate (Vector x y) = Vector (-x) (-y) vecOrtogonal :: (Num a) => Vector2 a -> Vector2 a vecOrtogonal (Vector x y) = (Vector y (-x)) vecAdd :: (Num a) => Vector2 a -> Vector2 a -> Vector2 a vecAdd (Vector x1 y1) (Vector x2 y2) = Vector (x1+x2) (y1+y2) vecSub :: (Num a) => Vector2 a -> Vector2 a -> Vector2 a vecSub (Vector x1 y1) (Vector x2 y2) = Vector (x1-x2) (y1-y2) vecScale :: (Num a) => Vector2 a -> a -> Vector2 a vecScale (Vector x y) v = Vector (v*x) (v*y) vecBetween :: (Num a) => Point2 a -> Point2 a -> Vector2 a vecBetween (Point x1 y1) (Point x2 y2) = Vector (x2-x1) (y2-y1) vecLength :: Vector -> Double vecLength (Vector x y) = sqrt (fromIntegral (x*x + y*y)) vecLengthDouble :: Vector2 Double -> Double vecLengthDouble (Vector x y) = sqrt (x*x + y*y) {----------------------------------------------------------------------------------------- Rectangle -----------------------------------------------------------------------------------------} rectContains :: (Num a, Ord a) => Rect2D a -> Point2 a -> Bool rectContains (Rect l t w h) (Point x y) = (x >= l && x <= (l+w) && y >= t && y <= (t+h)) rectMoveTo :: (Num a) => Rect2D a -> Point2 a -> Rect2D a rectMoveTo r p = rect p (rectSize r) rectFromPoint :: (Num a) => Point2 a -> Rect2D a rectFromPoint (Point x y) = Rect x y x y rectCentralPoint :: Rect2D Int -> Point2 Int rectCentralPoint (Rect l t w h) = Point (l + div w 2) (t + div h 2) rectCentralRect :: Rect2D Int -> Size -> Rect2D Int rectCentralRect r@(Rect l t rw rh) (Size w h) = let c = rectCentralPoint r in Rect (pointX c - (w - div w 2)) (pointY c - (h - div h 2)) w h rectCentralPointDouble :: (Fractional a) => Rect2D a -> Point2 a rectCentralPointDouble (Rect l t w h) = Point (l + w/2) (t + h/2) rectCentralRectDouble :: (Fractional a) => Rect2D a -> Size2D a -> Rect2D a rectCentralRectDouble r@(Rect l t rw rh) (Size w h) = let c = rectCentralPointDouble r in Rect (pointX c - (w - w/2)) (pointY c - (h - h/2)) w h rectStretchTo :: (Num a) => Rect2D a -> Size2D a -> Rect2D a rectStretchTo (Rect l t _ _) (Size w h) = Rect l t w h rectMove :: (Num a) => Rect2D a -> Vector2 a -> Rect2D a rectMove (Rect x y w h) (Vector dx dy) = Rect (x+dx) (y+dy) w h rectOverlaps :: (Num a, Ord a) => Rect2D a -> Rect2D a -> Bool rectOverlaps (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2) = (x1+w1 >= x2 && x1 <= x2+w2) && (y1+h1 >= y2 && y1 <= y2+h2) -- | A list with rectangles that constitute the difference between two rectangles. rectsDiff :: (Num a, Ord a) => Rect2D a -> Rect2D a -> [Rect2D a] rectsDiff rect1 rect2 = subtractFittingRect rect1 (rectOverlap rect1 rect2) where -- subtractFittingRect r1 r2 subtracts r2 from r1 assuming that r2 fits inside r1 subtractFittingRect :: (Num a, Ord a) => Rect2D a -> Rect2D a -> [Rect2D a] subtractFittingRect r1 r2 = filter (not . rectIsEmpty) [ rectBetween (rectTopLeft r1) (rectTopRight r2) , rectBetween (pt (rectLeft r1) (rectTop r2)) (rectBottomLeft r2) , rectBetween (pt (rectLeft r1) (rectBottom r2)) (pt (rectRight r2) (rectBottom r1)) , rectBetween (rectTopRight r2) (rectBottomRight r1) ] rectUnion :: (Num a, Ord a) => Rect2D a -> Rect2D a -> Rect2D a rectUnion r1 r2 = rectBetween (pt (min (rectLeft r1) (rectLeft r2)) (min (rectTop r1) (rectTop r2))) (pt (max (rectRight r1) (rectRight r2)) (max (rectBottom r1) (rectBottom r2))) rectUnions :: (Num a, Ord a) => [Rect2D a] -> Rect2D a rectUnions [] = rectZero rectUnions (r:rs) = foldr rectUnion r rs -- | The intersection between two rectangles. rectOverlap :: (Num a, Ord a) => Rect2D a -> Rect2D a -> Rect2D a rectOverlap r1 r2 | rectOverlaps r1 r2 = rectBetween (pt (max (rectLeft r1) (rectLeft r2)) (max (rectTop r1) (rectTop r2))) (pt (min (rectRight r1) (rectRight r2)) (min (rectBottom r1) (rectBottom r2))) | otherwise = rectZero {----------------------------------------------------------------------------------------- Default colors. -----------------------------------------------------------------------------------------} black, darkgrey, dimgrey, mediumgrey, grey, lightgrey, white :: Color red, green, blue :: Color cyan, magenta, yellow :: Color black = colorRGB 0x00 0x00 0x00 darkgrey = colorRGB 0x2F 0x2F 0x2F dimgrey = colorRGB 0x54 0x54 0x54 mediumgrey= colorRGB 0x64 0x64 0x64 grey = colorRGB 0x80 0x80 0x80 lightgrey = colorRGB 0xC0 0xC0 0xC0 white = colorRGB 0xFF 0xFF 0xFF red = colorRGB 0xFF 0x00 0x00 green = colorRGB 0x00 0xFF 0x00 blue = colorRGB 0x00 0x00 0xFF yellow = colorRGB 0xFF 0xFF 0x00 magenta = colorRGB 0xFF 0x00 0xFF cyan = colorRGB 0x00 0xFF 0xFF {-------------------------------------------------------------------------- System colors --------------------------------------------------------------------------} -- | System Colors. data SystemColor = ColorScrollBar -- ^ The scrollbar grey area. | ColorBackground -- ^ The desktop colour. | ColorActiveCaption -- ^ Active window caption. | ColorInactiveCaption -- ^ Inactive window caption. | ColorMenu -- ^ Menu background. | ColorWindow -- ^ Window background. | ColorWindowFrame -- ^ Window frame. | ColorMenuText -- ^ Menu text. | ColorWindowText -- ^ Text in windows. | ColorCaptionText -- ^ Text in caption, size box and scrollbar arrow box. | ColorActiveBorder -- ^ Active window border. | ColorInactiveBorder -- ^ Inactive window border. | ColorAppWorkspace -- ^ Background colour MDI -- ^applications. | ColorHighlight -- ^ Item(s) selected in a control. | ColorHighlightText -- ^ Text of item(s) selected in a control. | ColorBtnFace -- ^ Face shading on push buttons. | ColorBtnShadow -- ^ Edge shading on push buttons. | ColorGrayText -- ^ Greyed (disabled) text. | ColorBtnText -- ^ Text on push buttons. | ColorInactiveCaptionText -- ^ Colour of text in active captions. | ColorBtnHighlight -- ^ Highlight colour for buttons (same as 3DHILIGHT). | Color3DDkShadow -- ^ Dark shadow for three-dimensional display elements. | Color3DLight -- ^ Light colour for three-dimensional display elements. | ColorInfoText -- ^ Text colour for tooltip controls. | ColorInfoBk -- ^ Background colour for tooltip controls. | ColorDesktop -- ^ Same as BACKGROUND. | Color3DFace -- ^ Same as BTNFACE. | Color3DShadow -- ^ Same as BTNSHADOW. | Color3DHighlight -- ^ Same as BTNHIGHLIGHT. | Color3DHilight -- ^ Same as BTNHIGHLIGHT. | ColorBtnHilight -- ^ Same as BTNHIGHLIGHT. instance Enum SystemColor where toEnum i = error "Graphics.UI.WXCore.Types.SytemColor.toEnum: can not convert integers to system colors." fromEnum systemColor = case systemColor of ColorScrollBar -> wxSYS_COLOUR_SCROLLBAR ColorBackground -> wxSYS_COLOUR_BACKGROUND ColorActiveCaption -> wxSYS_COLOUR_ACTIVECAPTION ColorInactiveCaption -> wxSYS_COLOUR_INACTIVECAPTION ColorMenu -> wxSYS_COLOUR_MENU ColorWindow -> wxSYS_COLOUR_WINDOW ColorWindowFrame -> wxSYS_COLOUR_WINDOWFRAME ColorMenuText -> wxSYS_COLOUR_MENUTEXT ColorWindowText -> wxSYS_COLOUR_WINDOWTEXT ColorCaptionText -> wxSYS_COLOUR_CAPTIONTEXT ColorActiveBorder -> wxSYS_COLOUR_ACTIVEBORDER ColorInactiveBorder -> wxSYS_COLOUR_INACTIVEBORDER ColorAppWorkspace -> wxSYS_COLOUR_APPWORKSPACE ColorHighlight -> wxSYS_COLOUR_HIGHLIGHT ColorHighlightText -> wxSYS_COLOUR_HIGHLIGHTTEXT ColorBtnFace -> wxSYS_COLOUR_BTNFACE ColorBtnShadow -> wxSYS_COLOUR_BTNSHADOW ColorGrayText -> wxSYS_COLOUR_GRAYTEXT ColorBtnText -> wxSYS_COLOUR_BTNTEXT ColorInactiveCaptionText -> wxSYS_COLOUR_INACTIVECAPTIONTEXT ColorBtnHighlight -> wxSYS_COLOUR_BTNHIGHLIGHT Color3DDkShadow -> wxSYS_COLOUR_3DDKSHADOW Color3DLight -> wxSYS_COLOUR_3DLIGHT ColorInfoText -> wxSYS_COLOUR_INFOTEXT ColorInfoBk -> wxSYS_COLOUR_INFOBK ColorDesktop -> wxSYS_COLOUR_DESKTOP Color3DFace -> wxSYS_COLOUR_3DFACE Color3DShadow -> wxSYS_COLOUR_3DSHADOW Color3DHighlight -> wxSYS_COLOUR_3DHIGHLIGHT Color3DHilight -> wxSYS_COLOUR_3DHILIGHT ColorBtnHilight -> wxSYS_COLOUR_BTNHILIGHT -- | Convert a system color to a color. colorSystem :: SystemColor -> Color colorSystem systemColor = unsafePerformIO $ wxcSystemSettingsGetColour (fromEnum systemColor)