Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

[wxhaskell-from-cvs @ 2003-07-13 21:22:45 by dleijen]

Initial revision

darcs-hash:20030713212249-deb31-31f7499c573bfd552675e380fbba8c2e1ec7fbfa.gz
  • Loading branch information...
commit 0109f99bab8a36dcb75d94dbd7d946f70eb5081f 1 parent 8848b02
dleijen authored
Showing with 1,146 additions and 0 deletions.
  1. +362 −0 wxh/src/Graphics/UI/WXH/Types.hs
  2. +784 −0 wxh/src/Graphics/UI/WXH/WxcTypes.hs
View
362 wxh/src/Graphics/UI/WXH/Types.hs
@@ -0,0 +1,362 @@
+{-# OPTIONS -fglasgow-exts -#include "wxc.h" #-}
+-----------------------------------------------------------------------------------------
+{-| Module : Types
+ Copyright : (c) Daan Leijen 2003
+ License : BSD-style
+
+ Maintainer : daan@cs.uu.nl
+ Stability : provisional
+ Portability : portable
+
+ Basic types and operations.
+-}
+-----------------------------------------------------------------------------------------
+module Graphics.UI.WXH.Types(
+ -- * Objects
+ ( # )
+ , Object, objectNull, objectIsNull, objectCast
+ , 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
+
+ -- * Basic types
+
+ -- ** Booleans
+ , boolFromInt, intFromBool
+
+ -- ** Colors
+ , Color, colorRGB, colorRed, colorGreen, colorBlue
+ , black, darkgrey, dimgrey, mediumgrey, grey, lightgrey, white
+ , red, green, blue
+ , cyan, magenta, yellow
+
+ -- ** Points
+ , Point(..), pt, pointFromVec, pointFromSize, pointZero, pointNull
+ , pointMove, pointMoveBySize, pointAdd, pointSub, pointScale
+
+ -- ** Sizes
+ , Size(..), sz, sizeFromPoint, sizeFromVec, sizeZero, sizeNull, sizeEncloses
+ , sizeMin, sizeMax
+
+ -- ** Vectors
+ , Vector(..), vec, vecFromPoint, vecFromSize, vecZero, vecNull
+ , vecNegate, vecOrtogonal, vecAdd, vecSub, vecScale, vecDistance
+
+ -- ** Rectangles
+ , Rect(..)
+ , topLeft, topRight, bottomLeft, bottomRight, bottom, right
+ , rect, rectBetween, rectFromSize, rectZero, rectNull, rectSize, rectIsEmpty
+ , rectContains, rectMoveTo, rectFromPoint, rectCentralPoint, rectCentralRect, rectStretchTo
+ , rectMove, rectOverlaps, rectsDiff, rectUnion, rectOverlap, rectUnions
+
+ ) where
+
+import List( (\\) )
+import Graphics.UI.WXH.WxcTypes
+import Graphics.UI.WXH.WxcDefs
+import System.IO.Unsafe( unsafePerformIO )
+
+-- utility
+import Data.Bits
+import Data.IORef
+import qualified Control.Exception as CE
+import qualified Monad as M
+
+
+infixl 5 .+.
+infixl 5 .-.
+infix 5 #
+
+-- | Reverse application. 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 = IORef a
+
+-- | Create a fresh mutable variable.
+varCreate :: a -> IO (Var a)
+varCreate x = newIORef x
+
+-- | Get the value of a mutable variable.
+varGet :: Var a -> IO a
+varGet v = readIORef v
+
+-- | Set the value of a mutable variable.
+varSet :: Var a -> a -> IO ()
+varSet v x = writeIORef v x
+
+-- | Swap the value of a mutable variable.
+varSwap :: Var a -> a -> IO a
+varSwap v x = do prev <- varGet v; varSet 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 = do x <- varGet v
+ varSet v (f x)
+ return x
+
+
+
+{-----------------------------------------------------------------------------------------
+ Point
+-----------------------------------------------------------------------------------------}
+pointMove :: Vector -> Point -> Point
+pointMove (Vector dx dy) (Point x y)
+ = Point (x+dx) (y+dy)
+
+pointMoveBySize :: Size -> Point -> Point
+pointMoveBySize (Size w h) (Point x y) = Point (x + w) (y + h)
+
+pointAdd :: Point -> Point -> Point
+pointAdd (Point x1 y1) (Point x2 y2) = Point (x1+x2) (y1+y2)
+
+pointSub :: Point -> Point -> Point
+pointSub (Point x1 y1) (Point x2 y2) = Point (x1-x2) (y1-y2)
+
+pointScale :: Int -> Point -> Point
+pointScale v (Point x y) = Point (v*x) (v*y)
+
+
+{-----------------------------------------------------------------------------------------
+ Size
+-----------------------------------------------------------------------------------------}
+-- | Returns 'True' if the first size totally encloses the second argument.
+sizeEncloses :: Size -> Size -> Bool
+sizeEncloses (Size w0 h0) (Size w1 h1)
+ = (w0 >= w1) && (h0 >= h1)
+
+-- | The minimum of two sizes.
+sizeMin :: Size -> Size -> Size
+sizeMin (Size w0 h0) (Size w1 h1)
+ = Size (min w0 w1) (min h0 h1)
+
+-- | The maximum of two sizes.
+sizeMax :: Size -> Size -> Size
+sizeMax (Size w0 h0) (Size w1 h1)
+ = Size (max w0 w1) (max h0 h1)
+
+{-----------------------------------------------------------------------------------------
+ Vector
+-----------------------------------------------------------------------------------------}
+vecNegate :: Vector -> Vector
+vecNegate (Vector x y)
+ = Vector (-x) (-y)
+
+vecOrtogonal :: Vector -> Vector
+vecOrtogonal (Vector x y) = (Vector y (-x))
+
+vecAdd :: Vector -> Vector -> Vector
+vecAdd (Vector x1 y1) (Vector x2 y2) = Vector (x1+x2) (y1+y2)
+
+vecSub :: Vector -> Vector -> Vector
+vecSub (Vector x1 y1) (Vector x2 y2) = Vector (x1-x2) (y1-y2)
+
+vecScale :: Int -> Vector -> Vector
+vecScale v (Vector x y) = Vector (v*x) (v*y)
+
+vecDistance :: Point -> Point -> Vector
+vecDistance (Point x1 y1) (Point x2 y2) = Vector (x2-x1) (y2-y1)
+
+{-----------------------------------------------------------------------------------------
+ Rectangle
+-----------------------------------------------------------------------------------------}
+rectContains :: Point -> Rect -> Bool
+rectContains (Point x y) (Rect l t w h)
+ = (x >= l && x <= (l+w) && y >= t && y <= (t+h))
+
+rectMoveTo :: Point -> Rect -> Rect
+rectMoveTo p r
+ = rect p (rectSize r)
+
+rectFromPoint :: Point -> Rect
+rectFromPoint (Point x y)
+ = Rect x y x y
+
+rectCentralPoint :: Rect -> Point
+rectCentralPoint (Rect l t w h)
+ = Point (l + div w 2) (t + div h 2)
+
+rectCentralRect :: Rect -> Size -> Rect
+rectCentralRect r@(Rect l t rw rh) (Size w h)
+ = let c = rectCentralPoint r
+ in Rect (px c - (w - div w 2)) (py c - (h - div h 2)) w h
+
+
+rectStretchTo :: Size -> Rect -> Rect
+rectStretchTo (Size w h) (Rect l t _ _)
+ = Rect l t w h
+
+rectMove :: Vector -> Rect -> Rect
+rectMove (Vector dx dy) (Rect x y w h)
+ = Rect (x+dx) (y+dy) w h
+
+rectOverlaps :: Rect -> Rect -> Bool
+rectOverlaps (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2)
+ = (x1+w1 >= x2 && x1 <= x2+w2) && (y1+h1 >= y2 && y1 <= y2+h2)
+
+rectsDiff :: Rect -> Rect -> [Rect]
+rectsDiff rect1 rect2
+ = subtractFittingRect rect1 (rectOverlap rect1 rect2)
+ where
+ -- subtractFittingRect r1 r2 subtracts r2 from r1 assuming that r2 fits inside r1
+ subtractFittingRect :: Rect -> Rect -> [Rect]
+ subtractFittingRect r1 r2 =
+ filter (not . rectIsEmpty)
+ [ rectBetween (topLeft r1) (topRight r2)
+ , rectBetween (pt (left r1) (top r2)) (bottomLeft r2)
+ , rectBetween (pt (left r1) (bottom r2)) (pt (right r2) (bottom r1))
+ , rectBetween (topRight r2) (bottomRight r1)
+ ]
+
+rectUnion :: Rect -> Rect -> Rect
+rectUnion r1 r2
+ = rectBetween (pt (min (left r1) (left r2)) (min (top r1) (top r2)))
+ (pt (max (right r1) (right r2)) (max (bottom r1) (bottom r2)))
+
+rectUnions :: [Rect] -> Rect
+rectUnions []
+ = rectZero
+rectUnions (r:rs)
+ = foldr rectUnion r rs
+
+rectOverlap :: Rect -> Rect -> Rect
+rectOverlap r1 r2
+ | rectOverlaps r1 r2 = rectBetween (pt (max (left r1) (left r2)) (max (top r1) (top r2)))
+ (pt (min (right r1) (right r2)) (min (bottom r1) (bottom 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
View
784 wxh/src/Graphics/UI/WXH/WxcTypes.hs
@@ -0,0 +1,784 @@
+{-# OPTIONS -cpp -fglasgow-exts -#include "wxc.h" #-}
+-----------------------------------------------------------------------------------------
+{-| Module : Types
+ Copyright : (c) Daan Leijen 2003
+ License : BSD-style
+
+ Maintainer : daan@cs.uu.nl
+ Stability : provisional
+ Portability : portable
+
+ Basic types and marshaling code for the wxWindows C library.
+-}
+-----------------------------------------------------------------------------------------
+module Graphics.UI.WXH.WxcTypes(
+ -- * Object types
+ Object, objectNull, objectIsNull, objectCast
+ , Managed, managedNull, managedIsNull, managedCast, createManaged, withManaged, managedTouch
+
+ -- * Type synonyms
+ , Id
+ , Style
+ , EventId
+
+ -- * Basic types
+ , intFromBool, boolFromInt
+
+ -- ** Point
+ , Point(..), pt, pointFromVec, pointFromSize, pointZero, pointNull
+
+ -- ** Size
+ , Size(..), sz, sizeFromPoint, sizeFromVec, sizeZero, sizeNull
+
+ -- ** Vector
+ , Vector(..), vec, vecFromPoint, vecFromSize, vecZero, vecNull
+
+ -- * Rectangle
+ , Rect(..)
+ , topLeft, topRight, bottomLeft, bottomRight, bottom, right
+ , rect, rectBetween, rectFromSize, rectZero, rectNull, rectSize, rectIsEmpty
+
+ -- ** Color
+ , Color, colorRGB, colorRed, colorGreen, colorBlue, isColorValid
+
+ -- * Marshalling
+ -- ** Basic types
+ , withPointResult, toCIntPointX, toCIntPointY, fromCPoint, withCPoint
+ , withSizeResult, toCIntSizeW, toCIntSizeH, fromCSize, withCSize
+ , withVectorResult, toCIntVectorX, toCIntVectorY, fromCVector, withCVector
+ , withRectResult, toCIntRectX, toCIntRectY, toCIntRectW, toCIntRectH, fromCRect, withCRect
+ , withArrayString, withArrayInt, withArrayObject
+ , withArrayIntResult, withArrayStringResult, withArrayObjectResult
+
+ , Colour, ColourObject
+ , colourFromColor, colorFromColour
+ , colourCreate, colourCreateRGB, colourDelete, colourRed, colourGreen, colourBlue
+
+ -- ** Managed object types
+ , managedAddFinalizer
+ , withRefColour, withManagedColourResult, withManagedColour
+ , withRefBitmap
+ , withRefCursor
+ , withRefIcon
+ , withRefPen
+ , withRefBrush
+ , withRefFont
+ , withRefDateTime
+ , withRefListItem
+ , withRefTreeItemId
+ , withRefFontData
+ , withRefPrintData
+ , withRefPageSetupDialogData
+ , withRefPrintDialogData
+ , withRefGridCellCoordsArray
+
+
+ -- ** Primitive types
+ -- *** CString
+ , CString, withCString, withStringResult
+ -- *** CInt
+ , CInt, toCInt, fromCInt, withIntResult
+ -- *** CChar
+ , CChar, toCChar, fromCChar, withCharResult
+ -- *** CBool
+ , CBool, toCBool, fromCBool, withBoolResult
+ -- ** Pointers
+ , Ptr, ptrNull, ptrIsNull, ptrCast, ForeignPtr, FunPtr, toCFunPtr
+ ) where
+
+import System.IO.Unsafe( unsafePerformIO )
+import Foreign.C
+import Foreign.Ptr
+import Foreign.Storable
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Array
+
+import Foreign.ForeignPtr hiding (newForeignPtr,addForeignPtrFinalizer)
+import Foreign.Concurrent
+
+
+
+{-----------------------------------------------------------------------------------------
+ Objects
+-----------------------------------------------------------------------------------------}
+-- | An @Id@ is used to identify objects during event handling.
+type Id = Int
+
+-- | An @EventId@ is identifies specific events.
+type EventId = Int
+
+-- | A @Style@ is normally used as a flag mask to specify some window style
+type Style = Int
+
+
+-- | An @Object a@ is a pointer to an object of type @a@. The @a@ parameter is used
+-- to encode the inheritance relation. For example, a @Window@ is derived from the
+-- @EvtHandler@ object:
+--
+-- > type Window a = EvtHandler (CWindow a) -- == Object (CWxObject (CEvtHandler (CWindow a)))
+--
+-- While a @Frame@ is derived from a @Window@
+--
+-- > type Frame a = Window (CFrame a)
+--
+-- Now, you can call functions that expect something of type @Window a@ with a
+-- frame pointer too.
+--
+-- The inheritance relation is also seperately available as a type @TWindow@:
+--
+-- > type TWindow a = TEvtHandler (CWindow a) -- == CWxObject (CEvtHandler (CWindow a))
+--
+-- Objects are not automatically deleted. Normally you can use a delete function
+-- like @windowDelete@ to delete an object. However, almost all objects in the
+-- wxWindows library are automatically deleted by the library.
+type Object a = Ptr a
+
+-- | A null object. Use with care.
+objectNull :: Object a
+objectNull
+ = nullPtr
+
+-- | Test for null object.
+objectIsNull :: Object a -> Bool
+objectIsNull p
+ = (p == objectNull)
+
+-- | Cast an object to another type. Use with care.
+objectCast :: Object a -> Object b
+objectCast obj
+ = castPtr obj
+
+{-----------------------------------------------------------------------------------------
+ Point
+-----------------------------------------------------------------------------------------}
+-- | A point has an x and y coordinate. Coordinates are normally relative to the
+-- upper-left corner of their view frame, where a positive x goes to the right and
+-- a positive y to the bottom of the view.
+data Point = Point
+ { px :: !Int -- ^ x component of a point.
+ , py :: !Int -- ^ y component of a point.
+ }
+ deriving (Eq,Show)
+
+-- | Short function to construct a point.
+pt :: Int -> Int -> Point
+pt x y = Point x y
+
+pointFromVec :: Vector -> Point
+pointFromVec (Vector x y)
+ = Point x y
+
+pointFromSize :: Size -> Point
+pointFromSize (Size w h)
+ = Point w h
+
+pointZero :: Point
+pointZero
+ = Point 0 0
+
+-- | A `null' point is not a legal point (x and y are -1) and can be used for some
+-- wxWindows functions to select a default point.
+pointNull :: Point
+pointNull
+ = Point (-1) (-1)
+
+-- marshalling
+withCPoint :: Point -> (CInt -> CInt -> IO a) -> IO a
+withCPoint (Point x y) f
+ = f (toCInt x) (toCInt y)
+
+withPointResult :: (Ptr CInt -> Ptr CInt -> IO ()) -> IO Point
+withPointResult f
+ = alloca $ \px ->
+ alloca $ \py ->
+ do f px py
+ x <- peek px
+ y <- peek py
+ return (fromCPoint x y)
+
+toCIntPointX, toCIntPointY :: Point -> CInt
+toCIntPointX (Point x y) = toCInt x
+toCIntPointY (Point x y) = toCInt y
+
+fromCPoint :: CInt -> CInt -> Point
+fromCPoint x y
+ = Point (fromCInt x) (fromCInt y)
+
+
+{-----------------------------------------------------------------------------------------
+ Size
+-----------------------------------------------------------------------------------------}
+-- | A @Size@ has a width and height.
+data Size = Size
+ { sw :: !Int -- ^ the width of a size
+ , sh :: !Int -- ^ the height of a size
+ }
+ deriving (Eq,Show)
+
+-- | Short function to construct a size
+sz :: Int -> Int -> Size
+sz w h
+ = Size w h
+
+sizeFromPoint :: Point -> Size
+sizeFromPoint (Point x y)
+ = Size x y
+
+sizeFromVec :: Vector -> Size
+sizeFromVec (Vector x y)
+ = Size x y
+
+sizeZero :: Size
+sizeZero
+ = Size 0 0
+
+-- | A `null' size is not a legal size (width and height are -1) and can be used for some
+-- wxWindows functions to select a default size.
+sizeNull :: Size
+sizeNull
+ = Size (-1) (-1)
+
+-- marshalling
+withCSize :: Size -> (CInt -> CInt -> IO a) -> IO a
+withCSize (Size w h) f
+ = f (toCInt w) (toCInt h)
+
+withSizeResult :: (Ptr CInt -> Ptr CInt -> IO ()) -> IO Size
+withSizeResult f
+ = alloca $ \cw ->
+ alloca $ \ch ->
+ do f cw ch
+ w <- peek cw
+ h <- peek ch
+ return (fromCSize w h)
+
+fromCSize :: CInt -> CInt -> Size
+fromCSize w h
+ = Size (fromCInt w) (fromCInt h)
+
+toCIntSizeW, toCIntSizeH :: Size -> CInt
+toCIntSizeW (Size w h) = toCInt w
+toCIntSizeH (Size w h) = toCInt h
+
+{-----------------------------------------------------------------------------------------
+ Vector
+-----------------------------------------------------------------------------------------}
+-- | A vector with an x and y delta.
+data Vector = Vector
+ { vx :: !Int -- ^ delta-x component of a vector
+ , vy :: !Int -- ^ delta-y component of a vector
+ }
+ deriving (Eq,Show)
+
+
+-- | Short function to construct a vector.
+vec :: Int -> Int -> Vector
+vec dx dy = Vector dx dy
+
+-- | A zero vector
+vecZero :: Vector
+vecZero
+ = Vector 0 0
+
+-- | A `null' vector has a delta x and y of -1 and can be used for some
+-- wxWindows functions to select a default vector.
+vecNull :: Vector
+vecNull
+ = Vector (-1) (-1)
+
+vecFromPoint :: Point -> Vector
+vecFromPoint (Point x y)
+ = Vector x y
+
+vecFromSize :: Size -> Vector
+vecFromSize (Size w h)
+ = Vector w h
+
+
+
+-- marshalling
+withCVector :: Vector -> (CInt -> CInt -> IO a) -> IO a
+withCVector (Vector x y) f
+ = f (toCInt x) (toCInt y)
+
+withVectorResult :: (Ptr CInt -> Ptr CInt -> IO ()) -> IO Vector
+withVectorResult f
+ = alloca $ \px ->
+ alloca $ \py ->
+ do f px py
+ x <- peek px
+ y <- peek py
+ return (fromCVector x y)
+
+toCIntVectorX, toCIntVectorY :: Vector -> CInt
+toCIntVectorX (Vector x y) = toCInt x
+toCIntVectorY (Vector x y) = toCInt y
+
+fromCVector :: CInt -> CInt -> Vector
+fromCVector x y
+ = Vector (fromCInt x) (fromCInt y)
+
+
+{-----------------------------------------------------------------------------------------
+ Rectangle
+-----------------------------------------------------------------------------------------}
+-- | A rectangle is defined by the left x coordinate, the top y coordinate,
+-- the width and the height.
+data Rect = Rect
+ { left :: !Int
+ , top :: !Int
+ , width :: !Int
+ , height :: !Int
+ }
+ deriving (Eq,Show)
+
+
+topLeft, topRight, bottomLeft, bottomRight :: Rect -> Point
+topLeft (Rect l t w h) = Point l t
+topRight (Rect l t w h) = Point (l+w) t
+bottomLeft (Rect l t w h) = Point l (t+h)
+bottomRight (Rect l t w h) = Point (l+w) (t+h)
+
+bottom, right :: Rect -> Int
+bottom (Rect x y w h) = y + h
+right (Rect x y w h) = x + w
+
+-- | Create a rectangle at a certain (upper-left) point with a certain size.
+rect :: Point -> Size -> Rect
+rect (Point x y) (Size w h)
+ = Rect x y w h
+
+-- | Construct a (positive) rectangle between two (arbitrary) points.
+rectBetween :: Point -> Point -> Rect
+rectBetween (Point x0 y0) (Point x1 y1)
+ = Rect (min x0 x1) (min y0 y1) (abs (x1-x0)) (abs (y1-y0))
+
+-- | An empty rectangle at (0,0).
+rectZero :: Rect
+rectZero
+ = Rect 0 0 0 0
+
+-- | An `null' rectangle is not a valid rectangle (@Rect -1 -1 -1 -1@) but can
+-- used for some wxWindows functions to select a default rectangle. (i.e. 'frameCreate').
+rectNull :: Rect
+rectNull
+ = Rect (-1) (-1) (-1) (-1)
+
+-- | Get the size of a rectangle.
+rectSize :: Rect -> Size
+rectSize (Rect l t w h)
+ = Size w h
+
+-- | Create a rectangle of a certain size with the upper-left corner at ('pt' 0 0).
+rectFromSize :: Size -> Rect
+rectFromSize (Size w h)
+ = Rect 0 0 w h
+
+rectIsEmpty :: Rect -> Bool
+rectIsEmpty (Rect l t w h)
+ = (w==0 && h==0)
+
+
+
+-- marshalling
+withCRect :: Rect -> (CInt -> CInt -> CInt -> CInt -> IO a) -> IO a
+withCRect (Rect x0 y0 x1 y1) f
+ = f (toCInt (x0)) (toCInt (y0)) (toCInt (x1)) (toCInt (y1))
+
+withRectResult :: (Ptr CInt -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO ()) -> IO Rect
+withRectResult f
+ = alloca $ \cx ->
+ alloca $ \cy ->
+ alloca $ \cw ->
+ alloca $ \ch ->
+ do f cx cy cw ch
+ x <- peek cx
+ y <- peek cy
+ w <- peek cw
+ h <- peek ch
+ return (fromCRect x y w h)
+
+fromCRect :: CInt -> CInt -> CInt -> CInt -> Rect
+fromCRect x y w h
+ = Rect (fromCInt x) (fromCInt y) (fromCInt w) (fromCInt h)
+
+toCIntRectX, toCIntRectY, toCIntRectW, toCIntRectH :: Rect -> CInt
+toCIntRectX (Rect x y w h) = toCInt x
+toCIntRectY (Rect x y w h) = toCInt y
+toCIntRectW (Rect x y w h) = toCInt w
+toCIntRectH (Rect x y w h) = toCInt h
+
+{-----------------------------------------------------------------------------------------
+ CInt
+-----------------------------------------------------------------------------------------}
+withIntResult :: IO CInt -> IO Int
+withIntResult io
+ = do x <- io
+ return (fromCInt x)
+
+toCInt :: Int -> CInt
+toCInt i = fromIntegral i
+
+fromCInt :: CInt -> Int
+fromCInt ci
+ = fromIntegral ci
+
+{-----------------------------------------------------------------------------------------
+ CBool
+-----------------------------------------------------------------------------------------}
+type CBool = CInt
+
+toCBool :: Bool -> CBool
+toCBool b = toCInt (if b then 1 else 0)
+
+withBoolResult :: IO CBool -> IO Bool
+withBoolResult io
+ = do x <- io
+ return (fromCBool x)
+
+fromCBool :: CBool -> Bool
+fromCBool cb
+ = (cb /= 0)
+
+
+intFromBool :: Bool -> Int
+intFromBool b
+ = if b then 1 else 0
+
+boolFromInt :: Int -> Bool
+boolFromInt i
+ = (i/=0)
+
+{-----------------------------------------------------------------------------------------
+ CString
+-----------------------------------------------------------------------------------------}
+withStringResult :: (Ptr CChar -> IO CInt) -> IO String
+withStringResult f
+ = do len <- f nullPtr
+ if (len<=0)
+ then return ""
+ else withCString (replicate (fromCInt len) ' ') $ \cstr ->
+ do f cstr
+ peekCString cstr
+
+{-----------------------------------------------------------------------------------------
+ Arrays
+-----------------------------------------------------------------------------------------}
+withArrayStringResult :: (Ptr (Ptr CChar) -> IO CInt) -> IO [String]
+withArrayStringResult f
+ = do clen <- f nullPtr
+ let len = fromCInt clen
+ if (len <= 0)
+ then return []
+ else allocaArray len $ \carr ->
+ do f carr
+ arr <- peekArray len carr
+ mapM peekCString arr
+
+withArrayIntResult :: (Ptr CInt -> IO CInt) -> IO [Int]
+withArrayIntResult f
+ = do clen <- f nullPtr
+ let len = fromCInt clen
+ if (len <= 0)
+ then return []
+ else allocaArray len $ \carr ->
+ do f carr
+ xs <- peekArray len carr
+ return (map fromCInt xs)
+
+withArrayObjectResult :: (Ptr (Ptr a) -> IO CInt) -> IO [Ptr a]
+withArrayObjectResult f
+ = do clen <- f nullPtr
+ let len = fromCInt clen
+ if (len <= 0)
+ then return []
+ else allocaArray len $ \carr ->
+ do f carr
+ peekArray len carr
+
+withArrayString :: [String] -> (CInt -> Ptr CString -> IO a) -> IO a
+withArrayString xs f
+ = withCStrings xs [] $ \cxs ->
+ withArray0 ptrNull cxs $ \carr ->
+ f (toCInt len) carr
+ where
+ len = length xs
+
+ withCStrings [] cxs f
+ = f (reverse cxs)
+ withCStrings (x:xs) cxs f
+ = withCString x $ \cx ->
+ withCStrings xs (cx:cxs) f
+
+withArrayInt :: [Int] -> (CInt -> Ptr CInt -> IO a) -> IO a
+withArrayInt xs f
+ = withArray0 0 (map toCInt xs) $ \carr ->
+ f (toCInt (length xs)) carr
+
+withArrayObject :: [Ptr a] -> (CInt -> Ptr (Ptr a) -> IO b) -> IO b
+withArrayObject xs f
+ = withArray0 ptrNull xs $ \carr ->
+ f (toCInt (length xs)) carr
+
+{-----------------------------------------------------------------------------------------
+ CCHar
+-----------------------------------------------------------------------------------------}
+toCChar :: Char -> CChar
+toCChar c
+ = fromIntegral (fromEnum c)
+
+withCharResult :: IO CChar -> IO Char
+withCharResult io
+ = do x <- io
+ return (fromCChar x)
+
+fromCChar :: CChar -> Char
+fromCChar cc
+ = toEnum (fromIntegral cc)
+
+{-----------------------------------------------------------------------------------------
+ CFunPtr
+-----------------------------------------------------------------------------------------}
+toCFunPtr :: FunPtr a -> Ptr a
+toCFunPtr fptr
+ = castFunPtrToPtr fptr
+
+-- | Null pointer, use with care.
+ptrNull :: Ptr a
+ptrNull
+ = nullPtr
+
+-- | Test for null.
+ptrIsNull :: Ptr a -> Bool
+ptrIsNull p
+ = (p == ptrNull)
+
+-- | Cast a pointer type, use with care.
+ptrCast :: Ptr a -> Ptr b
+ptrCast p
+ = castPtr p
+
+{-----------------------------------------------------------------------------------------
+ Marshalling of classes that are managed
+-----------------------------------------------------------------------------------------}
+-- | A @Managed a@ is a pointer to an object of type @a@, just like 'Object'. However,
+-- managed objects are automatically deleted when garbage collected. This is used for
+-- certain classes that are not managed by the wxWindows library, like 'Bitmap's
+type Managed a = ForeignPtr a
+
+-- | Create a managed object. Takes a finalizer as argument. This is normally a
+-- a delete function like 'windowDelete'.
+createManaged :: IO () -> Object a -> IO (Managed a)
+createManaged final obj
+ = newForeignPtr obj final
+
+-- | Add an extra finalizer to a managed object.
+managedAddFinalizer :: IO () -> Managed a -> IO ()
+managedAddFinalizer io managed
+ = addForeignPtrFinalizer managed io
+
+-- | Do something with the object from a managed object.
+withManaged :: Managed a -> (Object a -> IO b) -> IO b
+withManaged fptr f
+ = withForeignPtr fptr f
+
+
+-- | Keep a managed object explicitly alive.
+managedTouch :: Managed a -> IO ()
+managedTouch fptr
+ = touchForeignPtr fptr
+
+-- | A null pointer, use with care.
+{-# NOINLINE managedNull #-}
+managedNull :: Managed a
+managedNull
+ = unsafePerformIO (createManaged (return ()) objectNull)
+
+-- | Test for null.
+managedIsNull :: Managed a -> Bool
+managedIsNull managed
+ = (managed == managedNull)
+
+-- | Cast a managed object, use with care.
+managedCast :: Managed a -> Managed b
+managedCast fptr
+ = castForeignPtr fptr
+
+
+{-----------------------------------------------------------------------------------------
+ Classes assigned by value.
+-----------------------------------------------------------------------------------------}
+assignRef :: IO (Object a) -> (Object a -> IO ()) -> IO (Object a)
+assignRef create f
+ = do p <- create
+ f p
+ return p
+
+withRefBitmap :: (Object a -> IO ()) -> IO (Object a)
+withRefBitmap f
+ = assignRef wxBitmap_Create f
+foreign import ccall "wxBitmap_CreateDefault" wxBitmap_Create :: IO (Object a)
+
+withRefCursor :: (Object a -> IO ()) -> IO (Object a)
+withRefCursor f
+ = assignRef (wx_Cursor_CreateFromStock 1) f
+foreign import ccall "Cursor_CreateFromStock" wx_Cursor_CreateFromStock :: CInt -> IO (Object a)
+
+withRefIcon :: (Object a -> IO ()) -> IO (Object a)
+withRefIcon f
+ = assignRef wxIcon_Create f
+foreign import ccall "wxIcon_CreateDefault" wxIcon_Create :: IO (Object a)
+
+
+withRefFont :: (Object a -> IO ()) -> IO (Object a)
+withRefFont f
+ = assignRef wxFont_Create f
+foreign import ccall "wxFont_CreateDefault" wxFont_Create :: IO (Object a)
+
+
+withRefPen :: (Object a -> IO ()) -> IO (Object a)
+withRefPen f
+ = assignRef wxPen_Create f
+foreign import ccall "wxPen_CreateDefault" wxPen_Create :: IO (Object a)
+
+
+withRefBrush :: (Object a -> IO ()) -> IO (Object a)
+withRefBrush f
+ = assignRef wxBrush_Create f
+foreign import ccall "wxBrush_CreateDefault" wxBrush_Create :: IO (Object a)
+
+withRefDateTime :: (Object a -> IO ()) -> IO (Object a)
+withRefDateTime f
+ = assignRef wxDateTime_Create f
+foreign import ccall "wxDateTime_Create" wxDateTime_Create :: IO (Object a)
+
+withRefListItem :: (Object a -> IO ()) -> IO (Object a)
+withRefListItem f
+ = assignRef wxListItem_Create f
+foreign import ccall "wxListItem_Create" wxListItem_Create :: IO (Object a)
+
+withRefTreeItemId :: (Object a -> IO ()) -> IO (Object a)
+withRefTreeItemId f
+ = assignRef wxTreeItemId_Create f
+foreign import ccall "wxTreeItemId_Create" wxTreeItemId_Create :: IO (Object a)
+
+
+withRefFontData :: (Object a -> IO ()) -> IO (Object a)
+withRefFontData f
+ = assignRef wxFontData_Create f
+foreign import ccall "wxFontData_Create" wxFontData_Create :: IO (Object a)
+
+withRefPrintData :: (Object a -> IO ()) -> IO (Object a)
+withRefPrintData f
+ = assignRef wxPrintData_Create f
+foreign import ccall "wxPrintData_Create" wxPrintData_Create :: IO (Object a)
+
+withRefPrintDialogData :: (Object a -> IO ()) -> IO (Object a)
+withRefPrintDialogData f
+ = assignRef wxPrintDialogData_Create f
+foreign import ccall "wxPrintDialogData_CreateDefault" wxPrintDialogData_Create :: IO (Object a)
+
+withRefPageSetupDialogData :: (Object a -> IO ()) -> IO (Object a)
+withRefPageSetupDialogData f
+ = assignRef wxPageSetupDialogData_Create f
+foreign import ccall "wxPageSetupDialogData_Create" wxPageSetupDialogData_Create :: IO (Object a)
+
+withRefGridCellCoordsArray :: (Object a -> IO ()) -> IO (Object a)
+withRefGridCellCoordsArray f
+ = assignRef wxGridCellCoordsArray_Create f
+foreign import ccall "wxGridCellCoordsArray_Create" wxGridCellCoordsArray_Create :: IO (Object a)
+
+{-----------------------------------------------------------------------------------------
+ Color
+-----------------------------------------------------------------------------------------}
+-- | An abstract data type to define colors.
+data Color = Color Int Int Int deriving Eq
+
+instance Show Color where
+ showsPrec d c
+ = showParen (d > 0) (showString "rgbColor " . shows (colorRed c) .
+ showChar ' ' . shows (colorGreen c) .
+ showChar ' ' . shows (colorBlue c))
+
+-- | Create a color from a red\/green\/blue triple.
+colorRGB :: Int -> Int -> Int -> Color
+colorRGB r g b = Color r g b
+
+-- | Create a color from a red\/green\/blue triple.
+rgb :: Int -> Int -> Int -> Color
+rgb r g b = Color r g b
+
+-- | Returns a red color component
+colorRed :: Color -> Int
+colorRed (Color r g b) = r
+
+-- | Returns a green color component
+colorGreen :: Color -> Int
+colorGreen (Color r g b) = g
+
+-- | Returns a blue color component
+colorBlue :: Color -> Int
+colorBlue (Color r g b) = b
+
+-- | Check of a color is valid (@Colour::Ok@)
+isColorValid :: Color -> Bool
+isColorValid (Color r g b)
+ = bound r && bound g && bound b
+ where
+ bound x = (x >= 0) && (x <= 255)
+
+
+-- marshalling
+type Colour a = Managed (CColour a)
+type ColourObject a = Object (CColour a)
+data CColour a = CColour
+
+withRefColour :: (ColourObject () -> IO ()) -> IO Color
+withRefColour f
+ = withManagedColourResult $
+ assignRef colourCreate f
+
+withManagedColourResult :: IO (ColourObject a) -> IO Color
+withManagedColourResult io
+ = do pcolour <- io
+ color <- do ok <- colourOk pcolour
+ if (ok==0)
+ then return (Color (-1) (-1) (-1))
+ else do r <- colourRed pcolour
+ g <- colourGreen pcolour
+ b <- colourBlue pcolour
+ return (Color (fromIntegral r) (fromIntegral g) (fromIntegral b))
+ colourDelete pcolour
+ return color
+
+withManagedColour :: Color -> (ColourObject () -> IO b) -> IO b
+withManagedColour (Color r g b) f
+ = do pcolour <- colourCreateRGB (fromIntegral r) (fromIntegral g) (fromIntegral b)
+ x <- f pcolour
+ colourDelete pcolour
+ return x
+
+colourFromColor :: Color -> IO (Colour ())
+colourFromColor (Color r g b)
+ = do pcolour <- colourCreateRGB (fromIntegral r) (fromIntegral g) (fromIntegral b)
+ newForeignPtr pcolour (colourDelete pcolour)
+
+colorFromColour :: Colour a -> IO Color
+colorFromColour c
+ = withManaged c $ \pcolour ->
+ do ok <- colourOk pcolour
+ if (ok==0)
+ then return (Color (-1) (-1) (-1))
+ else do r <- colourRed pcolour
+ g <- colourGreen pcolour
+ b <- colourBlue pcolour
+ return (Color (fromIntegral r) (fromIntegral g) (fromIntegral b))
+
+
+foreign import ccall "wxColour_CreateEmpty" colourCreate :: IO (ColourObject ())
+foreign import ccall "wxColour_CreateRGB" colourCreateRGB :: CUChar -> CUChar -> CUChar -> IO (ColourObject ())
+foreign import ccall "wxColour_Delete" colourDelete :: ColourObject a -> IO ()
+foreign import ccall "wxColour_Red" colourRed :: ColourObject a -> IO CUChar
+foreign import ccall "wxColour_Green" colourGreen :: ColourObject a -> IO CUChar
+foreign import ccall "wxColour_Blue" colourBlue :: ColourObject a -> IO CUChar
+foreign import ccall "wxColour_Ok" colourOk :: ColourObject a -> IO CInt
Please sign in to comment.
Something went wrong with that request. Please try again.