Skip to content
Browse files

[wxhaskell-from-cvs @ 2004-07-27 09:27:48 by dleijen]

- new variable objects
- added atomic swap and update
- new bitmap and sound creators

darcs-hash:20040727092750-deb31-f5eef3ca483e9b29d6e2c196393bc12f6f38a88f.gz
  • Loading branch information...
1 parent 9b7d2e6 commit 9dd137a20c22feb5e95ea733cb9c54c8eccf1fac dleijen committed Jul 27, 2004
View
2 changes.txt
@@ -21,6 +21,8 @@ Non backward compatible changes:
- Renamed "WXCore.WxcClassTypes" to "WXCore.WxcClassInfo".
Backward compatible additions:
+- Added pure "bitmap" and "sound"
+- Added "variable" objects (mutable variables)
- Added custom control demo.
- Made "refresh" erase the background too.
- Added "children" attribute for windows.
View
2 makefile
@@ -62,9 +62,11 @@ WX-SOURCES= \
Graphics/UI/WX/Attributes \
Graphics/UI/WX/Layout \
Graphics/UI/WX/Classes \
+ Graphics/UI/WX/Variable \
Graphics/UI/WX/Events \
Graphics/UI/WX/Window \
Graphics/UI/WX/Frame \
+ Graphics/UI/WX/Media \
Graphics/UI/WX/Menu \
Graphics/UI/WX/Timer \
Graphics/UI/WX/Draw \
View
5 samples/wx/Grid.hs
@@ -11,10 +11,10 @@ main
gui :: IO ()
gui
- = do f <- frame [text := "Grid test"]
+ = do f <- frame [text := "Grid test", visible := False]
-- use text control as logger
- textlog <- textCtrl f [enabled := False, wrap := WrapNone]
+ textlog <- textCtrl f [wrap := WrapNone, enabled := False]
textCtrlMakeLogActiveTarget textlog
logMessage "logging enabled"
@@ -35,6 +35,7 @@ gui
,hfill (widget textlog)]
]
focusOn g
+ set f [visible := True] -- reduce flicker at startup.
return ()
where
onGridKeyDown g (EventKey key mods pt)
View
18 samples/wx/ImageViewer.hs
@@ -12,10 +12,8 @@
-----------------------------------------------------------------------------------------}
module Main where
-import Graphics.UI.WXCore ( bitmapCreateFromFile, bitmapGetSize, dcClear)
import Graphics.UI.WX
-
main :: IO ()
main
= start imageViewer
@@ -37,7 +35,7 @@ imageViewer
f <- frame [text := "ImageViewer", image := "../bitmaps/eye.ico", fullRepaintOnResize := False]
-- use a mutable variable to hold the image
- vbitmap <- varCreate Nothing
+ vbitmap <- variable [value := Nothing]
-- add a scrollable window widget in the frame
sw <- scrolledWindow f [scrollRate := sz 10 10, on paint := onPaint vbitmap
@@ -68,13 +66,15 @@ imageViewer
,fill (widget sw)]
,statusbar := [status]
,menubar := [file,hlp]
+ ,outerSize := sz 400 300 -- niceness
,on (menu about) := infoDialog f "About ImageViewer" "This is a wxHaskell demo"
,on (menu quit) := close f
,on (menu open) := onOpen f sw vbitmap mclose status
,on (menu mclose) := onClose sw vbitmap mclose status
+
+ -- nice close down, but no longer necessary as bitmaps are managed automatically.
,on closing :~ \previous -> do{ closeImage vbitmap; previous }
]
-
where
onOpen :: Frame a -> ScrolledWindow b -> Var (Maybe (Bitmap ())) -> MenuItem c -> StatusField -> IO ()
onOpen f sw vbitmap mclose status
@@ -91,7 +91,7 @@ imageViewer
repaint sw
closeImage vbitmap
- = do mbBitmap <- varSwap vbitmap Nothing
+ = do mbBitmap <- swap vbitmap value Nothing
case mbBitmap of
Nothing -> return ()
Just bm -> objectDelete bm
@@ -100,17 +100,17 @@ imageViewer
= do -- load the new bitmap
bm <- bitmapCreateFromFile fname -- can fail with exception
closeImage vbitmap
- varSet vbitmap (Just bm)
+ set vbitmap [value := Just bm]
set mclose [enabled := True]
set status [text := fname]
-- reset the scrollbars
- bmsize <- bitmapGetSize bm
+ bmsize <- get bm size
set sw [virtualSize := bmsize]
repaint sw
`catch` \err -> repaint sw
onPaint vbitmap dc viewArea
- = do mbBitmap <- varGet vbitmap
+ = do mbBitmap <- get vbitmap value
case mbBitmap of
- Nothing -> dcClear dc
+ Nothing -> return ()
Just bm -> drawBitmap dc bm pointZero False []
View
4 wx/src/Graphics/UI/WX.hs
@@ -21,12 +21,14 @@ module Graphics.UI.WX
, module Graphics.UI.WX.Types
, module Graphics.UI.WX.Attributes
, module Graphics.UI.WX.Classes
+ , module Graphics.UI.WX.Variable
, module Graphics.UI.WX.Layout
, module Graphics.UI.WX.Events
, module Graphics.UI.WX.Window
, module Graphics.UI.WX.Frame
, module Graphics.UI.WX.Timer
+ , module Graphics.UI.WX.Media
, module Graphics.UI.WX.Menu
, module Graphics.UI.WX.Controls
, module Graphics.UI.WX.Dialogs
@@ -36,12 +38,14 @@ module Graphics.UI.WX
import Graphics.UI.WX.Types
import Graphics.UI.WX.Attributes
import Graphics.UI.WX.Classes
+import Graphics.UI.WX.Variable
import Graphics.UI.WX.Layout
import Graphics.UI.WX.Events
import Graphics.UI.WX.Window
import Graphics.UI.WX.Frame
import Graphics.UI.WX.Timer
+import Graphics.UI.WX.Media
import Graphics.UI.WX.Menu
import Graphics.UI.WX.Controls
View
71 wx/src/Graphics/UI/WX/Attributes.hs
@@ -57,14 +57,14 @@ module Graphics.UI.WX.Attributes
(
-- * Attributes
Attr, Prop((:=),(:~),(::=),(::~)), ReadAttr, WriteAttr, CreateAttr
- , get, set
+ , get, set, swap
, mapAttr, mapAttrW
-- * Internal
-- ** Attributes
- , newAttr, readAttr, writeAttr, nullAttr, constAttr
+ , newAttr, readAttr, writeAttr, nullAttr, constAttr, makeAttr
-- ** Reflection
, attrName, propName, containsProperty
@@ -104,13 +104,16 @@ type ReadAttr w a = Attr w a
type WriteAttr w a = Attr w a
-- | Widgets @w@ can have attributes of type @a@.
-data Attr w a = Attr String (Maybe (a -> Dynamic, Dynamic -> Maybe a)) (w -> IO a) (w -> a -> IO ()) -- name, getter, setter
+data Attr w a = Attr String (Maybe (a -> Dynamic, Dynamic -> Maybe a)) -- name, dynamic conversion
+ (w -> IO a) (w -> a -> IO ()) -- getter setter
+ (w -> (a -> a) -> IO a) -- updater
-- | Cast attributes.
castAttr :: (v -> w) -> Attr w a -> Attr v a
-castAttr coerce (Attr name mbdyn getter setter)
+castAttr coerce (Attr name mbdyn getter setter upd)
= Attr name mbdyn (\v -> getter (coerce v)) (\v x -> (setter (coerce v) x))
+ (\v f -> upd (coerce v) f)
-- | Cast properties
castProp :: (v -> w) -> Prop w -> Prop v
@@ -131,7 +134,9 @@ castProps coerce props
-- as it leads to non-compositional code.
reflectiveAttr :: Typeable a => String -> (w -> IO a) -> (w -> a -> IO ()) -> Attr w a
reflectiveAttr name getter setter
- = Attr name (Just (toDyn, fromDynamic)) getter setter
+ = Attr name (Just (toDyn, fromDynamic)) getter setter updater
+ where
+ updater w f = do x <- getter w; setter w (f x); return x
-- | Create a /reflective/ attribute with a specified name: value can possibly
-- retrieved using 'getPropValue'. Note: the use of this function is discouraged
@@ -140,10 +145,19 @@ createAttr :: Typeable a => String -> (w -> IO a) -> (w -> a -> IO ()) -> Create
createAttr name getter setter
= reflectiveAttr name getter setter
+-- | Create a new attribute with a specified name, getter, setter, and updater function.
+makeAttr :: String -> (w -> IO a) -> (w -> a -> IO ()) -> (w -> (a -> a) -> IO a) -> Attr w a
+makeAttr name getter setter updater
+ = Attr name Nothing getter setter updater
+
+
-- | Create a new attribute with a specified name, getter and setter function.
newAttr :: String -> (w -> IO a) -> (w -> a -> IO ()) -> Attr w a
newAttr name getter setter
- = Attr name Nothing getter setter
+ = makeAttr name getter setter updater
+ where
+ updater w f = do x <- getter w; setter w (f x); return x
+
-- | Define a read-only attribute.
readAttr :: String -> (w -> IO a) -> ReadAttr w a
@@ -171,26 +185,25 @@ constAttr name x
-- requested and (@set :: a -> b -> a@) is applied to current
-- value when the attribute is set.
mapAttr :: (a -> b) -> (a -> b -> a) -> Attr w a -> Attr w b
-mapAttr get set (Attr name reflect getter setter)
+mapAttr get set (Attr name reflect getter setter updater)
= Attr name Nothing
(\w -> do a <- getter w; return (get a))
(\w b -> do a <- getter w; setter w (set a b))
-
+ (\w f -> do a <- updater w (\a -> set a (f (get a))); return (get a))
-- | (@mapAttrW conv attr@) maps an attribute of @Attr w a@ to
-- @Attr v a@ where (@conv :: v -> w@) is used to convert a widget
-- @v@ into a widget of type @w@.
mapAttrW :: (v -> w) -> Attr w a -> Attr v a
-mapAttrW f (Attr name reflect getter setter)
- = Attr name reflect (\v -> getter (f v)) (\v x -> setter (f v) x)
-
+mapAttrW f attr
+ = castAttr f attr
-- | Get the value of an attribute
--
-- > t <- get w text
--
get :: w -> Attr w a -> IO a
-get w (Attr name reflect getter setter)
+get w (Attr name reflect getter setter updater)
= getter w
-- | Set a list of properties.
@@ -201,21 +214,23 @@ set :: w -> [Prop w] -> IO ()
set w props
= mapM_ setprop props
where
- setprop ((Attr name reflect getter setter) := x)
+ setprop ((Attr name reflect getter setter updater) := x)
= setter w x
- setprop ((Attr name reflect getter setter) :~ f)
- = do x <- getter w
- setter w (f x)
- setprop ((Attr name reflect getter setter) ::= f)
+ setprop ((Attr name reflect getter setter updater) :~ f)
+ = do updater w f; return ()
+ setprop ((Attr name reflect getter setter updater) ::= f)
= setter w (f w)
- setprop ((Attr name reflect getter setter) ::~ f)
- = do x <- getter w
- setter w (f w x)
+ setprop ((Attr name reflect getter setter updater) ::~ f)
+ = do updater w (f w); return ()
+-- | Set the value of an attribute and return the old value.
+swap :: w -> Attr w a -> a -> IO a
+swap w (Attr name reflect getter setter updater) x
+ = updater w (const x)
-- | Retrieve the name of an attribute
attrName :: Attr w a -> String
-attrName (Attr name _ _ _)
+attrName (Attr name _ _ _ _)
= name
-- | Retrieve the name of a property.
@@ -249,21 +264,21 @@ instance Show a => Show (PropValue a) where
-- | Retrieve the value of a property and the list with the property removed.
filterProperty :: Typeable a => Attr w a -> [Prop w] -> (PropValue a, [Prop w])
-filterProperty (Attr name _ _ _) props
+filterProperty (Attr name _ _ _ _) props
= walk [] PropNone props
where
-- Daan: oh, how a simple thing like properties can result into this... ;-)
walk :: Typeable a => [Prop w] -> PropValue a -> [Prop w] -> (PropValue a, [Prop w])
walk acc res props
= case props of
-- Property setter found.
- (((Attr attr (Just (todyn,fromdyn)) _ _) := x):rest) | name == attr
+ (((Attr attr (Just (todyn,fromdyn)) _ _ _) := x):rest) | name == attr
-> case fromDynamic (todyn x) of
Just x -> walk acc (PropValue x) rest
Nothing -> walk acc res props
-- Property modifier found.
- (((Attr attr (Just (todyn,fromdyn)) _ _) :~ f):rest) | name == attr
+ (((Attr attr (Just (todyn,fromdyn)) _ _ _) :~ f):rest) | name == attr
-> let dynf x = case fromdyn (toDyn x) of
Just xx -> case fromDynamic (todyn (f xx)) of
Just y -> y
@@ -275,10 +290,10 @@ filterProperty (Attr name _ _ _) props
PropNone -> walk acc (PropModify dynf) rest
-- Property found, but with the wrong arguments
- (((Attr attr _ _ _) := _):rest) | name == attr -> stop
- (((Attr attr _ _ _) :~ _):rest) | name == attr -> stop
- (((Attr attr _ _ _) ::= _):rest) | name == attr -> stop
- (((Attr attr _ _ _) ::~ _):rest) | name == attr -> stop
+ (((Attr attr _ _ _ _) := _):rest) | name == attr -> stop
+ (((Attr attr _ _ _ _) :~ _):rest) | name == attr -> stop
+ (((Attr attr _ _ _ _) ::= _):rest) | name == attr -> stop
+ (((Attr attr _ _ _ _) ::~ _):rest) | name == attr -> stop
-- Defaults
(prop:rest)
View
19 wx/src/Graphics/UI/WX/Classes.hs
@@ -53,6 +53,8 @@ module Graphics.UI.WX.Classes
, Checkable( checkable, checked )
, Dockable( dockable )
, HasImage( image )
+ , Valued( value )
+ , Sized( size )
) where
import Data.Dynamic
@@ -351,3 +353,20 @@ class Items w a | w -> a where
itemsDelete w
= do count <- get w itemCount
sequence_ (replicate count (itemDelete w 0))
+
+{--------------------------------------------------------------------------
+ Values
+--------------------------------------------------------------------------}
+-- | Items with a value.
+class Valued w where
+ -- | The value of an object.
+ value :: Attr (w a) a
+
+{--------------------------------------------------------------------------
+ Size
+--------------------------------------------------------------------------}
+-- | Sized objects (like bitmaps)
+class Sized w where
+ -- | The size of an object. (is 'outerSize' for 'Dimensions' widgets).
+ size :: Attr w Size
+
View
2 wx/src/Graphics/UI/WX/Draw.hs
@@ -27,7 +27,7 @@ module Graphics.UI.WX.Draw
, drawPoint, drawRect, roundedRect
, drawText, rotatedText, drawBitmap
-- * Internal
- , dcWith
+ , dcWith, dcClear
) where
import Graphics.UI.WXCore
View
65 wx/src/Graphics/UI/WX/Media.hs
@@ -0,0 +1,65 @@
+{-# OPTIONS -fglasgow-exts #-}
+--------------------------------------------------------------------------------
+{-| Module : Media
+ Copyright : (c) Daan Leijen 2003
+ License : wxWindows
+
+ Maintainer : daan@cs.uu.nl
+ Stability : provisional
+ Portability : portable
+
+ Images, Sounds, and action!
+-}
+--------------------------------------------------------------------------------
+module Graphics.UI.WX.Media
+ ( -- * Sound
+ , sound, play, playLoop, playWait
+ -- * Images
+ , bitmap, bitmapCreateFromFile
+ ) where
+
+import System.IO.Unsafe( unsafePerformIO )
+import Graphics.UI.WXCore
+import Graphics.UI.WX.Types( Var, varGet, varSet, varCreate )
+import Graphics.UI.WX.Attributes
+import Graphics.UI.WX.Classes
+
+{--------------------------------------------------------------------
+ Images
+--------------------------------------------------------------------}
+-- | Return a managed bitmap object. The file path should point to
+-- a valid bitmap file, normally a @.ico@, @.bmp@, @.xpm@, or @.png@,
+-- but any file format supported by |Image| is correctly loaded.
+--
+-- Instances: 'Sized'.
+bitmap :: FilePath -> Bitmap ()
+bitmap fname
+ = unsafePerformIO $ bitmapCreateFromFile fname
+
+instance Sized (Bitmap a) where
+ size = newAttr "size" bitmapGetSize bitmapSetSize
+
+{--------------------------------------------------------------------
+ Sounds
+--------------------------------------------------------------------}
+-- | Return a managed sound object. The file path points to
+-- a valid sound file, normally a @.wav@.
+sound :: FilePath -> Wave ()
+sound fname
+ = unsafePerformIO $ waveCreate fname False
+
+-- | Play a sound fragment asynchronously.
+play :: Wave a -> IO ()
+play wave
+ = unitIO (wavePlay wave True False)
+
+-- | Play a sound fragment repeatedly (and asynchronously).
+playLoop :: Wave a -> IO ()
+playLoop wave
+ = unitIO (wavePlay wave True True)
+
+-- | Play a sound fragment synchronously (i.e. wait till completion).
+playWait :: Wave a -> IO ()
+playWait wave
+ = unitIO (wavePlay wave False False)
+
View
2 wx/src/Graphics/UI/WX/Types.hs
@@ -71,7 +71,7 @@ module Graphics.UI.WX.Types
, pointMove, pointMoveBySize, pointAdd, pointSub, pointScale
-- ** Sizes
- , Size(Size,sizeW,sizeH), size, sz, sizeFromPoint, sizeFromVec, sizeZero, sizeNull, sizeEncloses
+ , Size(Size,sizeW,sizeH), sz, sizeFromPoint, sizeFromVec, sizeZero, sizeNull, sizeEncloses
, sizeMin, sizeMax
-- ** Vectors
View
33 wx/src/Graphics/UI/WX/Variable.hs
@@ -0,0 +1,33 @@
+--------------------------------------------------------------------------------
+{-| Module : Variable
+ Copyright : (c) Daan Leijen 2003
+ License : wxWindows
+
+ Maintainer : daan@cs.uu.nl
+ Stability : provisional
+ Portability : portable
+
+ Mutable variables.
+-}
+--------------------------------------------------------------------------------
+module Graphics.UI.WX.Variable
+ ( variable
+ ) where
+
+import Data.IORef
+import Graphics.UI.WX.Types( Var, varGet, varSet, varCreate, varUpdate )
+import Graphics.UI.WX.Attributes
+import Graphics.UI.WX.Classes
+
+{--------------------------------------------------------------------
+
+--------------------------------------------------------------------}
+instance Valued IORef where
+ value = makeAttr "value" varGet varSet varUpdate
+
+-- | Create a mutable variable. Change the value using the |value| attribute.
+variable :: [Prop (Var a)] -> IO (Var a)
+variable props
+ = do v <- varCreate (error "Graphics.UI.WX.Variable: uninitialized variable, use the 'value' attribute at creation")
+ set v props
+ return v
View
3 wx/src/Graphics/UI/WX/Window.hs
@@ -174,6 +174,9 @@ instance Dimensions (Window a) where
= newAttr "virtualSize" windowGetVirtualSize windowSetVirtualSize
+instance Sized (Window a) where
+ size = outerSize
+
-- | Retrieve the initial creation area from the |area|, or the |position| and
-- |outerSize| properties.
initialArea :: Dimensions w => (Rect -> [Prop w] -> a) -> [Prop w] -> a

0 comments on commit 9dd137a

Please sign in to comment.
Something went wrong with that request. Please try again.