diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 $@ diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/data/banana.png b/data/banana.png new file mode 100644 Binary files /dev/null and b/data/banana.png differ diff --git a/reactive-banana-wx.cabal b/reactive-banana-wx.cabal --- a/reactive-banana-wx.cabal +++ b/reactive-banana-wx.cabal @@ -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 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 diff --git a/src/Animation.hs b/src/Animation.hs new file mode 100644 --- /dev/null +++ b/src/Animation.hs @@ -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 + + diff --git a/src/Arithmetic.hs b/src/Arithmetic.hs --- a/src/Arithmetic.hs +++ b/src/Arithmetic.hs @@ -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 diff --git a/src/Asteroids.hs b/src/Asteroids.hs --- a/src/Asteroids.hs +++ b/src/Asteroids.hs @@ -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)] ] diff --git a/src/CRUD.hs b/src/CRUD.hs --- a/src/CRUD.hs +++ b/src/CRUD.hs @@ -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 +-} diff --git a/src/CurrencyConverter.hs b/src/CurrencyConverter.hs --- a/src/CurrencyConverter.hs +++ b/src/CurrencyConverter.hs @@ -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 [ diff --git a/src/NetMonitor.hs b/src/NetMonitor.hs --- a/src/NetMonitor.hs +++ b/src/NetMonitor.hs @@ -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 diff --git a/src/Paths.hs b/src/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Paths.hs @@ -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 diff --git a/src/Reactive/Banana/WX.hs b/src/Reactive/Banana/WX.hs --- a/src/Reactive/Banana/WX.hs +++ b/src/Reactive/Banana/WX.hs @@ -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 ()