reactive-banana-wx 0.5.0.0 → 0.6.0.0
raw patch · 12 files changed
+321/−152 lines, 12 filesdep ~containersdep ~reactive-bananadep ~wxsetup-changednew-component:exe:Animationbinary-added
Dependency ranges changed: containers, reactive-banana, wx, wxcore
Files
- Makefile +9/−3
- Setup.hs +9/−11
- data/banana.png binary
- reactive-banana-wx.cabal +22/−7
- src/Animation.hs +105/−0
- src/Arithmetic.hs +5/−5
- src/Asteroids.hs +7/−22
- src/CRUD.hs +91/−62
- src/CurrencyConverter.hs +2/−2
- src/NetMonitor.hs +2/−2
- src/Paths.hs +26/−0
- src/Reactive/Banana/WX.hs +43/−38
Makefile view
@@ -4,19 +4,25 @@ OBJ=dist/build COMPILE= \ ghc --make -i$(OBJ) -L/usr/lib -L$(OBJ) \- -isrc -i../reactive-banana/src -idist/build/autogen+ -isrc -i../reactive-banana/src -idist/build/autogen \+ -DbuildExamples # Compile all programs with cabal all:- cabal configure && cabal build --ghc-options=-L/usr/lib+ cabal configure -fbuildExamples && cabal build --ghc-options=-L/usr/lib # Compile individual programs for testing+Animation : src/Animation.hs src/Reactive/Banana/WX.hs+ $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/ && macosx-app $@ \+ && cp data/* $@.app/Contents/Resources+ Arithmetic : src/Arithmetic.hs src/Reactive/Banana/WX.hs $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/ && macosx-app $@ Asteroids : src/Asteroids.hs src/Reactive/Banana/WX.hs- $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/ && macosx-app $@+ $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/ && macosx-app $@ \+ && cp data/* $@.app/Contents/Resources Counter : src/Counter.hs src/Reactive/Banana/WX.hs $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/ && macosx-app $@
Setup.hs view
@@ -11,18 +11,16 @@ } guiApps :: [MacApp]-guiApps = [MacApp "Asteroids"- Nothing- Nothing -- Build a default Info.plist for the icon.- files -- bitmaps and .wav- [] -- No other binaries.- DoNotChase -- Try changing to ChaseWithDefaults- ] ++ apps+guiApps =+ [mkApp filesAsteroids "Asteroids", mkApp filesAnimation "Animation"] ++ apps -apps = map app $+apps = map (mkApp []) $ words "Arithmetic Counter CurrencyConverter CRUD" ++ words "NetMonitor TicTacToe TwoCounters Wave"-app name = MacApp name Nothing Nothing [] [] DoNotChase--files = map ("data/" ++) $+filesAsteroids = map ("data/" ++) $ words "burning.ico rock.ico ship.ico explode.wav"+filesAnimation = map ("data/" ++) $+ words "banana.png"+++mkApp files name = MacApp name Nothing Nothing files [] DoNotChase
+ data/banana.png view
binary file changed (absent → 2013 bytes)
reactive-banana-wx.cabal view
@@ -1,5 +1,5 @@ Name: reactive-banana-wx-Version: 0.5.0.0+Version: 0.6.0.0 Synopsis: Examples for the reactive-banana library, using wxHaskell. Description: This library provides some GUI examples for the @reactive-banana@ library,@@ -13,6 +13,10 @@ . @cabal install reactive-banana-wx -fbuildExamples@ .+ IMPORTANT NOTE:+ There are a few issues with WxWidgets 2.9.3 and some examples may crash.+ These problems are only solved in wx-0.90.0.1 and higher.+ . Stability forecast: The wrapper functions are rather provisional. Homepage: http://haskell.org/haskellwiki/Reactive-banana@@ -21,14 +25,14 @@ Author: Heinrich Apfelmus Maintainer: Heinrich Apfelmus <apfelmus quantentunnel de> Category: FRP, GUI-Cabal-version: >=1.6+Cabal-version: >=1.8 Build-type: Custom Extra-source-files: Makefile data-dir: data-data-files: *.ico, *.wav+data-files: *.ico, *.wav, *.png flag buildExamples description: Build example executables@@ -38,8 +42,9 @@ hs-source-dirs: src build-depends: base >= 4.2 && < 5, cabal-macosx >= 0.1 && < 0.3,- reactive-banana >= 0.5.0.0 && < 0.6,- wx==0.12.1.6, wxcore==0.12.1.7+ reactive-banana >= 0.6.0.0 && < 0.7,+ wxcore (>= 0.13.2.3 && < 0.90) || (>= 0.90.0.1 && < 0.91),+ wx (>= 0.13.2.3 && < 0.90) || (>= 0.90.0.1 && < 0.91) extensions: ExistentialQuantification exposed-modules: Reactive.Banana.WX @@ -48,6 +53,15 @@ location: git://github.com/HeinrichApfelmus/reactive-banana.git subdir: reactive-banana-wx +Executable Animation+ if !flag(buildExamples)+ buildable: False+ else+ cpp-options: -DbuildExamples+ hs-source-dirs: src+ other-modules: Paths_reactive_banana_wx, Paths+ main-is: Animation.hs+ Executable Arithmetic if !flag(buildExamples) buildable: False@@ -60,10 +74,11 @@ random == 1.0.*, executable-path == 0.0.*, filepath >= 1.1 && <= 1.4+ cpp-options: -DbuildExamples else buildable: False hs-source-dirs: src- other-modules: Paths_reactive_banana_wx+ other-modules: Paths_reactive_banana_wx, Paths main-is: Asteroids.hs Executable Counter@@ -82,7 +97,7 @@ Executable CRUD if flag(buildExamples)- build-depends: containers >= 0.3 && < 0.5+ build-depends: containers >= 0.3 && < 0.6 else buildable: False hs-source-dirs: src
+ src/Animation.hs view
@@ -0,0 +1,105 @@+{-----------------------------------------------------------------------------+ reactive-banana-wx+ + Example: A simple animation.+------------------------------------------------------------------------------}+{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t"++import Graphics.UI.WX hiding (Event, Vector)+import Reactive.Banana+import Reactive.Banana.WX+import System.Random++import Paths (getDataFile)++{-----------------------------------------------------------------------------+ Constants+------------------------------------------------------------------------------}+height, width :: Int+height = 400+width = 400++dt :: Double+dt = 20 * ms where ms = 1e-3++sprite :: Bitmap ()+sprite = bitmap $ getDataFile "banana.png"++bitmapWidth, bitmapHeight :: Int+bitmapWidth = 128+bitmapHeight = 128++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main :: IO ()+main = start $ do+ ff <- frame [ text := "It's functional programming time"+ , bgcolor := white+ , resizeable := False ]++ t <- timer ff [ interval := ceiling (dt * 1e3) ] + pp <- panel ff [ ]+ set ff [ layout := minsize (sz width height) $ widget pp ]+ + -- event network+ let networkDescription :: forall t. NetworkDescription t ()+ networkDescription = do+ etick <- event0 t command -- frame timer+ emouse <- event1 pp mouse -- mouse events+ + let+ -- mouse pointer position+ bmouse = fromPoint <$> stepper (point 0 0)+ (filterJust $ justMotion <$> emouse)+ + -- sprite velocity+ bvelocity :: Behavior t Vector+ bvelocity =+ (\pos mouse -> speedup $ mouse `vecSub` pos `vecSub` vec 0 45)+ <$> bposition <*> bmouse+ where+ speedup v = v `vecScale` (vecLengthDouble v / 20)+ + -- sprite position+ bposition :: Behavior t Vector+ bposition = accumB (vec 0 0) $+ (\v pos -> clipToFrame $ (v `vecScale` dt) `vecAdd` pos)+ <$> bvelocity <@ etick+ + clipToFrame v = vec+ (clip 0 x (fromIntegral $ width - bitmapWidth ))+ (clip 0 y (fromIntegral $ height - bitmapHeight))+ where+ x = vecX v; y = vecY v+ clip a x b = max a (min x b)+ + drawSprite :: Point -> DC a -> b -> IO ()+ drawSprite pos dc _view = drawBitmap dc sprite pos True []+ + -- animate the sprite+ sink pp [on paint :== drawSprite . toPoint <$> bposition]+ reactimate $ repaint pp <$ etick+ + network <- compile networkDescription + actuate network++{-----------------------------------------------------------------------------+ 2D Geometry+------------------------------------------------------------------------------}+type Vector = Vector2 Double++fromPoint :: Point -> Vector+fromPoint pt = vector (fromIntegral (pointX pt)) (fromIntegral (pointY pt))++toPoint :: Vector -> Point+toPoint v = point (ceiling (vecX v)) (ceiling (vecY v))++{-----------------------------------------------------------------------------+ wx stuff+------------------------------------------------------------------------------}+justMotion :: EventMouse -> Maybe Point+justMotion (MouseMotion pt _) = Just pt+justMotion _ = Nothing++
src/Arithmetic.hs view
@@ -15,14 +15,14 @@ Main ------------------------------------------------------------------------------} main = start $ do- f <- frame [text := "Arithmetic"]- input1 <- entry f [processEnter := True]- input2 <- entry f [processEnter := True]- output <- staticText f [ size := sz 40 20 ]+ f <- frame [text := "Arithmetic"]+ input1 <- entry f []+ input2 <- entry f []+ output <- staticText f [] set f [layout := margin 10 $ row 10 $ [widget input1, label "+", widget input2- , label "=", widget output]]+ , label "=", minsize (sz 40 20) $ widget output]] let networkDescription :: forall t. NetworkDescription t () networkDescription = do
src/Asteroids.hs view
@@ -19,12 +19,7 @@ import Reactive.Banana.WX import System.Random --- boring path stuff-import System.Environment.Executable-import System.FilePath-import System.Info-import System.IO.Unsafe-import qualified Paths_reactive_banana_wx as Paths (getDataDir)+import Paths (getDataFile) {----------------------------------------------------------------------------- Main@@ -39,18 +34,12 @@ chance = 0.1 rock, burning, ship :: Bitmap ()-rock = bitmap $ dataDir </> "rock.ico"-burning = bitmap $ dataDir </> "burning.ico"-ship = bitmap $ dataDir </> "ship.ico"+rock = bitmap $ getDataFile "rock.ico"+burning = bitmap $ getDataFile "burning.ico"+ship = bitmap $ getDataFile "ship.ico" explode :: WXCore.Sound ()-explode = sound $ dataDir </> "explode.wav" --getDataDir- | os == "darwin" =- fmap (\x -> takeDirectory x </> ".." </> "Resources") getExecutablePath - | otherwise = Paths.getDataDir-dataDir = unsafePerformIO $ getDataDir+explode = sound $ getDataFile "explode.wav" main :: IO () main = start asteroids@@ -63,7 +52,6 @@ asteroids = do ff <- frame [ text := "Asteroids" , bgcolor := white- , clientSize := sz width height , resizeable := False ] status <- statusField [text := "Welcome to asteroids"] @@ -86,11 +74,8 @@ set ff [menuBar := [game]] - pp <- panel ff [ clientSize := sz width height- , position := point 1 1- ]- set ff [ layout := widget pp- ]+ pp <- panel ff []+ set ff [ layout := minsize (sz width height) $ widget pp ] set pp [ on (charKey '-') := set t [interval :~ \i -> i * 2] , on (charKey '+') := set t [interval :~ \i -> max 10 (div i 2)] ]
src/CRUD.hs view
@@ -19,9 +19,12 @@ import qualified Graphics.UI.WX as WX import Graphics.UI.WX hiding (Event)+import qualified Graphics.UI.WXCore as WXCore import Reactive.Banana import Reactive.Banana.WX +import Tidings+ {----------------------------------------------------------------------------- Main ------------------------------------------------------------------------------}@@ -31,10 +34,10 @@ listBox <- singleListBox f [] createBtn <- button f [ text := "Create" ] deleteBtn <- button f [ text := "Delete" ]- filterEntry <- entry f [ processEnter := True ]+ filterEntry <- entry f [ ] - firstname <- entry f [ processEnter := True ]- lastname <- entry f [ processEnter := True ]+ firstname <- entry f [ ]+ lastname <- entry f [ ] let dataItem = grid 10 10 [[label "First Name:", widget firstname] ,[label "Last Name:" , widget lastname]]@@ -52,19 +55,23 @@ eCreate <- event0 createBtn command eDelete <- event0 deleteBtn command -- filter string- bFilterString <- behaviorText filterEntry ""- let bFilter :: Behavior t (String -> Bool)- bFilter = isPrefixOf <$> bFilterString-+ tFilterString <- reactiveTextEntry filterEntry bFilterString+ let bFilterString = stepper "" $ rumors tFilterString+ tFilter = isPrefixOf <$> tFilterString+ bFilter = facts tFilter+ eFilter = rumors tFilter+ -- list box with selection- bSelection <- reactiveListDisplay listBox bListItems bShowDataItem+ eSelection <- rumors <$> reactiveListDisplay listBox+ bListBoxItems bSelection bShowDataItem -- data item display- (_,eDataItemIn) <- reactiveDataItem (firstname,lastname) bDataItemOut+ eDataItemIn <- rumors <$> reactiveDataItem (firstname,lastname)+ bSelectionDataItem let -- database bDatabase :: Behavior t (Database DataItem)- bDatabase = accumB emptydb $ mconcat+ bDatabase = accumB emptydb $ unions [ create ("Emil","Example") <$ eCreate , filterJust $ update' <$> bSelection <@> eDataItemIn , delete <$> filterJust (bSelection <@ eDelete)@@ -72,20 +79,28 @@ where update' mkey x = flip update x <$> mkey + -- selection+ bSelection :: Behavior t (Maybe DatabaseKey)+ bSelection = stepper Nothing $ unions+ [ eSelection+ , Nothing <$ eDelete+ , Just . nextKey <$> bDatabase <@ eCreate+ , (\b s p -> b >>= \a -> if p (s a) then Just a else Nothing)+ <$> bSelection <*> bShowDataItem <@> eFilter+ ]+ bLookup :: Behavior t (DatabaseKey -> Maybe DataItem) bLookup = flip lookup <$> bDatabase bShowDataItem :: Behavior t (DatabaseKey -> String) bShowDataItem = (maybe "" showDataItem .) <$> bLookup - bListItems :: Behavior t [DatabaseKey]- bListItems = (\p show -> filter (p. show) . keys)+ bListBoxItems :: Behavior t [DatabaseKey]+ bListBoxItems = (\p show -> filter (p. show) . keys) <$> bFilter <*> bShowDataItem <*> bDatabase - bDataItemOut :: Behavior t (Maybe DataItem)- bDataItemOut = (=<<) <$> bLookup <*> bSelection-- -- TODO: Delete event must change selection!+ bSelectionDataItem :: Behavior t (Maybe DataItem)+ bSelectionDataItem = (=<<) <$> bLookup <*> bSelection -- automatically enable / disable editing let@@ -118,43 +133,34 @@ type DataItem = (String, String) showDataItem (firstname, lastname) = lastname ++ ", " ++ firstname -{- Note: On breaking feedback loops.--The right abstraction for this is a behavior + notifications .-The point is that the notifications do *not* represent every single change-in the behavior. Instead, they represent selected changes.-That's why the applicative instance for this data type is a bit different-than usual.---}---- text entry widgets in terms of discrete time-varying values+-- single text entry reactiveTextEntry :: TextCtrl a- -> Behavior t String -- set text programmatically (view)+ -> Behavior t String -- text value -> NetworkDescription t- (Behavior t String -- current text (both view & controller)- ,Event t String) -- user changes (controller)-reactiveTextEntry entry input = do- sink entry [ text :== input ] -- display value+ (Tidings t String) -- user changes+reactiveTextEntry w btext = do+ eUser <- eventText w -- user changes - eUser <- changes =<< behaviorText entry "" -- user changes- eIn <- changes input -- input changes- x <- initial input- -- programmatic changes will affect the text box *after* user changes.- return (stepper x (eUser `union` eIn), eUser)+ -- filter text setting that are simultaneous with user events+ itext <- initial btext+ etext <- changes btext+ let etext2 = fst $ split $ unionWith (curry snd) (Left <$> etext) (Right <$> eUser)+ btext2 = stepper itext etext2 + sink w [ text :== btext2 ] -- display value+ return $ tidings btext eUser+ -- whole data item (consisting of two text entries) reactiveDataItem :: (TextCtrl a, TextCtrl b) -> Behavior t (Maybe DataItem) -> NetworkDescription t- (Behavior t DataItem, Event t DataItem)-reactiveDataItem (firstname,lastname) input = do- (b1,e1) <- reactiveTextEntry firstname (fst . maybe ("","") id <$> input)- (b2,e2) <- reactiveTextEntry lastname (snd . maybe ("","") id <$> input)- return ( (,) <$> b1 <*> b2 ,- ((,) <$> b1 <@> e2) `union` (flip (,) <$> b2 <@> e1))+ (Tidings t DataItem)+reactiveDataItem (firstname,lastname) binput = do+ t1 <- reactiveTextEntry firstname (fst . maybe ("","") id <$> binput)+ t2 <- reactiveTextEntry lastname (snd . maybe ("","") id <$> binput)+ return $ (,) <$> t1 <*> t2 {-----------------------------------------------------------------------------@@ -168,36 +174,58 @@ reactiveListDisplay :: forall t a b. Ord a => SingleListBox b -- ListBox widget to use -> Behavior t [a] -- list of items+ -> Behavior t (Maybe a) -- selected element -> Behavior t (a -> String) -- display an item -> NetworkDescription t- (Behavior t (Maybe a)) -- current selection as item (possibly empty)-reactiveListDisplay listBox elements display = do- -- retrieve selection index- bSelection <- behaviorListBoxSelection listBox+ (Tidings t (Maybe a)) -- current selection as item (possibly empty)+reactiveListDisplay w bitems bsel bdisplay = do+ -- animate output items+ sink w [ items :== map <$> bdisplay <*> bitems ] - -- display items- sink listBox [ items :== map <$> display <*> elements ]- -- changing the display won't change the current selection- eDisplay <- changes display- sink listBox [ selection :== stepper (-1) $ bSelection <@ eDisplay ]+ -- animate output selection+ let bindices :: Behavior t (Map.Map a Int)+ bindices = (Map.fromList . flip zip [0..]) <$> bitems+ bindex = (\m a -> maybe (-1) id $ flip Map.lookup m =<< a) <$>+ bindices <*> bsel+ sink w [ selection :== bindex ] - -- return current selection as element- let bIndexed :: Behavior t (Map.Map Int a)- bIndexed = Map.fromList . zip [0..] <$> elements- return $ Map.lookup <$> bSelection <*> bIndexed+ -- changing the display won't change the current selection+ -- eDisplay <- changes display+ -- sink listBox [ selection :== stepper (-1) $ bSelection <@ eDisplay ] + -- user selection+ let bindices2 :: Behavior t (Map.Map Int a)+ bindices2 = Map.fromList . zip [0..] <$> bitems+ esel <- eventSelection w+ return $ tidings bsel $ flip Map.lookup <$> bindices2 <@> esel {----------------------------------------------------------------------------- wxHaskell convenience wrappers and bug fixes ------------------------------------------------------------------------------}--- | Return *user* changes to the list box selection.-behaviorListBoxSelection :: SingleListBox b -> NetworkDescription t (Behavior t Int)-behaviorListBoxSelection listBox = do- liftIO $ fixSelectionEvent listBox- a <- liftIO $ event1ToAddHandler listBox (event0ToEvent1 select)- fromChanges (-1) $ mapIO (const $ get listBox selection) a+{- Currently exported from Reactive.Banana.WX +-- user input event - text for text entries+eventText :: TextCtrl w -> NetworkDescription t (Event t String)+eventText w = do+ -- Should probably be wxEVT_COMMAND_TEXT_UPDATED ,+ -- but that's missing from wxHaskell.+ -- Note: Observing keyUp events does create a small lag+ addHandler <- liftIO $ event1ToAddHandler w keyboardUp+ fromAddHandler $ mapIO (const $ get w text) addHandler++-- observe "key up" events (many thanks to Abu Alam)+-- this should probably be in the wxHaskell library+keyboardUp :: WX.Event (Window a) (EventKey -> IO ())+keyboardUp = WX.newEvent "keyboardUp" WXCore.windowGetOnKeyUp WXCore.windowOnKeyUp++-- user input event - selection marker for list events+eventSelection :: SingleListBox b -> NetworkDescription t (Event t Int)+eventSelection w = do+ liftIO $ fixSelectionEvent w+ addHandler <- liftIO $ event1ToAddHandler w (event0ToEvent1 select)+ fromAddHandler $ mapIO (const $ get w selection) addHandler+ -- Fix @select@ event not being fired when items are *un*selected. fixSelectionEvent listbox = liftIO $ set listbox [ on unclick := handler ]@@ -206,3 +234,4 @@ propagateEvent s <- get listbox selection when (s == -1) $ (get listbox (on select)) >>= id+-}
src/CurrencyConverter.hs view
@@ -20,8 +20,8 @@ main = start $ do -- FIXME: Why does tab traversal not work? f <- frame [ text := "Currency Converter", tabTraversal := True ]- dollar <- entry f [ processEnter := True ]- euro <- entry f [ processEnter := True ]+ dollar <- entry f []+ euro <- entry f [] set f [layout := margin 10 $ column 10 [
src/NetMonitor.hs view
@@ -23,12 +23,12 @@ out1 <- staticText f [] out2 <- staticText f [] - set f [layout := margin 10 $+ set f [layout := minsize (sz 250 70) $ margin 10 $ column 10 [label "TCP network statistics", grid 5 5 [[label "Packets sent: ", widget out1] ,[label "Packets received: ", widget out2]] ]- , size := sz 250 70]+ ] t <- timer f [ interval := 500 ] -- timer every 500 ms
+ src/Paths.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE CPP#-}+module Paths (getDataFile) where++import System.FilePath+import System.IO.Unsafe++#if buildExamples+-- using cabal+import System.Environment.Executable+import System.Info+import qualified Paths_reactive_banana_wx (getDataDir)++getDataDir+ | os == "darwin" =+ fmap (\x -> takeDirectory x </> ".." </> "Resources") getExecutablePath + | otherwise = Paths_reactive_banana_wx.getDataDir++#else+-- using GHCi++getDataDir :: IO FilePath+getDataDir = return "../data/"++#endif++getDataFile x = unsafePerformIO $ fmap (</> x) getDataDir
src/Reactive/Banana/WX.hs view
@@ -12,22 +12,22 @@ event1, event0, behavior, Prop'(..), sink, - -- * Specialized for widgets- behaviorText, sinkText, keyboardUp,- + -- * Specific widgets+ eventText, behaviorText, eventSelection,+ -- * Utilities event1ToAddHandler, event0ToEvent1,- mapIO,+ mapIO, filterAddHandler, ) where import Reactive.Banana import qualified Graphics.UI.WX as WX import Graphics.UI.WX hiding (Event, Attr)-import Graphics.UI.WXCore hiding (Event)+import qualified Graphics.UI.WXCore as WXCore -- import Graphics.UI.WX (on, Prop(..)) {------------------------------------------------------------------------------ Connection with events and behaviors+ General ------------------------------------------------------------------------------} -- | Event with exactly one parameter. event1 :: w -> WX.Event w (a -> IO ()) -> NetworkDescription t (Event t a)@@ -65,47 +65,47 @@ reactimate $ (\x -> set widget [attr := x]) <$> e {------------------------------------------------------------------------------ Connection with events and behaviors+ Specific widgets ------------------------------------------------------------------------------}--- | Behavior of the user-entered 'text' of a 'TextCtrl' widget.------ To avoid feedback loops, *only* the user-entered text will--- update the behavior.--- This is probably not what you want, though.-behaviorText- :: WX.TextCtrl w- -> String- -- ^ Initial value supplied "by the user". Not set programmaticaly.- -> NetworkDescription t (Behavior t String)-behaviorText textCtrl initial = do- -- Should probably be wxEVT_COMMAND_TEXT_UPDATED ,- -- but that's missing from wxHaskell.- -- Note: Observing keyUp events does create a small lag- addHandler <- liftIO $ event1ToAddHandler textCtrl keyboardUp- e <- fromAddHandler $ mapIO (const $ get textCtrl text) addHandler- return $ stepper initial e+-- | Event that occurs when the /user/ changed+-- the text in text edit widget.+eventText :: TextCtrl w -> NetworkDescription t (Event t String)+eventText w = do+ addHandler <- liftIO $ event1ToAddHandler w (event0ToEvent1 onText)+ fromAddHandler+ $ filterAddHandler (const $ WXCore.textCtrlIsModified w)+ $ mapIO (const $ get w text) addHandler +onText :: WX.Event (WXCore.Control a) (IO ())+onText = WX.newEvent "onText" WXCore.controlGetOnText WXCore.controlOnText -- observe "key up" events (many thanks to Abu Alam) -- this should probably be in the wxHaskell library-keyboardUp :: WX.Event (Window a) (EventKey -> IO ())-keyboardUp = WX.newEvent "keyboardUp" windowGetOnKeyUp windowOnKeyUp+-- keyboardUp :: WX.Event (Window a) (EventKey -> IO ())+-- keyboardUp = WX.newEvent "keyboardUp" WXCore.windowGetOnKeyUp WXCore.windowOnKeyUp +-- | Behavior corresponding to user input the text field.+behaviorText :: TextCtrl w -> String -> NetworkDescription t (Behavior t String)+behaviorText w s = stepper s <$> eventText w --- | Reactimate the 'text' of a 'TextCtrl' widget.------ To avoid feedback loops, the text will not be updated while--- the widget has the focus.-sinkText :: WX.TextCtrl w -> Behavior t String -> NetworkDescription t ()-sinkText textCtrl b = do- e <- changes b- x <- initial b+-- | Event that occurs when the /user/ changed+-- the selection marker in a list box widget.+eventSelection :: SingleListBox b -> NetworkDescription t (Event t Int)+eventSelection w = do+ liftIO $ fixSelectionEvent w+ addHandler <- liftIO $ event1ToAddHandler w (event0ToEvent1 select)+ fromAddHandler $ mapIO (const $ get w selection) addHandler - bHasFocus <- stepper False <$> event1 textCtrl focus- - let b' = stepper x $ whenE (not <$> bHasFocus) e- sink textCtrl [ text :== b' ]+-- Fix @select@ event not being fired when items are *un*selected.+fixSelectionEvent listbox =+ liftIO $ set listbox [ on unclick := handler ]+ where+ handler _ = do+ propagateEvent+ s <- get listbox selection+ when (s == -1) $ (get listbox (on select)) >>= id + {----------------------------------------------------------------------------- Utilities ------------------------------------------------------------------------------}@@ -123,3 +123,8 @@ -- | Apply a function with side effects to an 'AddHandler' mapIO :: (a -> IO b) -> AddHandler a -> AddHandler b mapIO f addHandler = \h -> addHandler $ \x -> f x >>= h ++-- | Filter event occurrences that don't return 'True'.+filterAddHandler :: (a -> IO Bool) -> AddHandler a -> AddHandler a+filterAddHandler f addHandler = \h ->+ addHandler $ \x -> f x >>= \b -> if b then h x else return ()