diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -24,6 +24,9 @@ $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/ && macosx-app $@ \ && cp data/* $@.app/Contents/Resources +BarTab : src/BarTab.hs src/Reactive/Banana/WX.hs + $(COMPILE) -o $@ $< -outputdir $(OBJ)/$@.tmp/ && macosx-app $@ + 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 @@ -15,7 +15,7 @@ [mkApp filesAsteroids "Asteroids", mkApp filesAnimation "Animation"] ++ apps apps = map (mkApp []) $ - words "Arithmetic Counter CurrencyConverter CRUD" + words "Arithmetic BarTab Counter CurrencyConverter CRUD" ++ words "NetMonitor TicTacToe TwoCounters Wave" filesAsteroids = map ("data/" ++) $ words "burning.ico rock.ico ship.ico explode.wav" diff --git a/data/banana.png b/data/banana.png deleted file mode 100644 Binary files a/data/banana.png and /dev/null 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.6.0.1 +Version: 0.7.0.0 Synopsis: Examples for the reactive-banana library, using wxHaskell. Description: This library provides some GUI examples for the @reactive-banana@ library, @@ -13,10 +13,6 @@ . @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 @@ -25,14 +21,14 @@ Author: Heinrich Apfelmus Maintainer: Heinrich Apfelmus Category: FRP, GUI -Cabal-version: >=1.8 +Cabal-version: >=1.6 Build-type: Custom Extra-source-files: Makefile data-dir: data -data-files: *.ico, *.wav, *.png +data-files: *.ico, *.wav flag buildExamples description: Build example executables @@ -42,9 +38,8 @@ hs-source-dirs: src build-depends: base >= 4.2 && < 5, cabal-macosx >= 0.1 && < 0.3, - reactive-banana >= 0.6.0.0 && < 0.7, - wxcore (>= 0.13.2.1 && < 0.90) || (>= 0.90.0.1 && < 0.91), - wx (>= 0.13.2.1 && < 0.90) || (>= 0.90.0.1 && < 0.91) + reactive-banana >= 0.7.0.0 && < 0.8, + wx >= 0.90 && < 0.91, wxcore >= 0.90 && < 0.91 extensions: ExistentialQuantification exposed-modules: Reactive.Banana.WX @@ -55,17 +50,8 @@ Executable Animation if flag(buildExamples) - build-depends: - process >= 1.0 && < 1.2, - random == 1.0.*, - executable-path == 0.0.*, - filepath >= 1.1 && <= 1.4, - reactive-banana, - wx, - wxcore, - base - cpp-options: -DbuildExamples - + cpp-options: -DbuildExamples + build-depends: reactive-banana, wx, wxcore, base else buildable: False hs-source-dirs: src @@ -74,12 +60,7 @@ Executable Arithmetic if flag(buildExamples) - build-depends: - process >= 1.0 && < 1.2, - reactive-banana, - wx, - wxcore, - base + build-depends: reactive-banana, wx, wxcore, base else buildable: False hs-source-dirs: src @@ -91,10 +72,7 @@ random == 1.0.*, executable-path == 0.0.*, filepath >= 1.1 && <= 1.4, - reactive-banana, - wx, - wxcore, - base + reactive-banana, wx, wxcore, base cpp-options: -DbuildExamples else buildable: False @@ -102,13 +80,17 @@ other-modules: Paths_reactive_banana_wx, Paths main-is: Asteroids.hs +Executable BarTab + if flag(buildExamples) + build-depends: reactive-banana, wx, wxcore, base + else + buildable: False + hs-source-dirs: src + main-is: BarTab.hs + Executable Counter if flag(buildExamples) - build-depends: - reactive-banana, - wx, - wxcore, - base + build-depends: reactive-banana, wx, wxcore, base else buildable: False hs-source-dirs: src @@ -116,12 +98,8 @@ Executable CurrencyConverter if flag(buildExamples) - build-depends: - process >= 1.0.1 && < 1.2, - reactive-banana, - wx, - wxcore, - base + build-depends: process >= 1.0.1 && < 1.2, + reactive-banana, wx, wxcore, base else buildable: False hs-source-dirs: src @@ -129,26 +107,17 @@ Executable CRUD if flag(buildExamples) - build-depends: - containers >= 0.3 && < 0.6, - reactive-banana, - wx, - wxcore, - base + build-depends: containers >= 0.3 && < 0.5, + reactive-banana, wx, wxcore, base else buildable: False hs-source-dirs: src main-is: CRUD.hs - other-modules: Tidings Executable NetMonitor if flag(buildExamples) - build-depends: - process >= 1.0 && < 1.2, - reactive-banana, - wx, - wxcore, - base + build-depends: process >= 1.0 && < 1.2, + reactive-banana, wx, wxcore, base else buildable: False hs-source-dirs: src @@ -156,12 +125,8 @@ Executable TicTacToe if flag(buildExamples) - build-depends: - array >= 0.3 && < 0.5, - reactive-banana, - wx, - wxcore, - base + build-depends: array >= 0.3 && < 0.5, + reactive-banana, wx, wxcore, base else buildable: False hs-source-dirs: src @@ -169,11 +134,7 @@ Executable TwoCounters if flag(buildExamples) - build-depends: - reactive-banana, - wx, - wxcore, - base + build-depends: reactive-banana, wx, wxcore, base else buildable: False hs-source-dirs: src @@ -181,11 +142,7 @@ Executable Wave if flag(buildExamples) - build-depends: - reactive-banana, - wx, - wxcore, - base + build-depends: reactive-banana, wx, wxcore, base else buildable: False hs-source-dirs: src diff --git a/src/Animation.hs b/src/Animation.hs --- a/src/Animation.hs +++ b/src/Animation.hs @@ -3,7 +3,7 @@ Example: A simple animation. ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t" +{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" import Graphics.UI.WX hiding (Event, Vector) import Reactive.Banana @@ -43,7 +43,7 @@ set ff [ layout := minsize (sz width height) $ widget pp ] -- event network - let networkDescription :: forall t. NetworkDescription t () + let networkDescription :: forall t. Frameworks t => Moment t () networkDescription = do etick <- event0 t command -- frame timer emouse <- event1 pp mouse -- mouse events diff --git a/src/Arithmetic.hs b/src/Arithmetic.hs --- a/src/Arithmetic.hs +++ b/src/Arithmetic.hs @@ -3,7 +3,7 @@ Example: Very simple arithmetic ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t" +{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" import Data.Maybe @@ -24,7 +24,7 @@ [widget input1, label "+", widget input2 , label "=", minsize (sz 40 20) $ widget output]] - let networkDescription :: forall t. NetworkDescription t () + let networkDescription :: forall t. Frameworks t => Moment t () networkDescription = do binput1 <- behaviorText input1 "" diff --git a/src/Asteroids.hs b/src/Asteroids.hs --- a/src/Asteroids.hs +++ b/src/Asteroids.hs @@ -11,7 +11,7 @@ https://github.com/killerswan/wxAsteroids/issues/1 http://comments.gmane.org/gmane.comp.lang.haskell.wxhaskell.general/1086 ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t" +{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" import Graphics.UI.WX hiding (Event) import Graphics.UI.WXCore as WXCore @@ -81,7 +81,7 @@ ] -- event network - let networkDescription :: forall t. NetworkDescription t () + let networkDescription :: forall t. Frameworks t => Moment t () networkDescription = do -- timer etick <- event0 t command diff --git a/src/BarTab.hs b/src/BarTab.hs new file mode 100644 --- /dev/null +++ b/src/BarTab.hs @@ -0,0 +1,89 @@ +{----------------------------------------------------------------------------- + reactive-banana-wx + + Example: Bar tab with a variable number of widgets +------------------------------------------------------------------------------} +{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} + +import Data.Maybe (listToMaybe) + +import Graphics.UI.WX hiding (Event) +import Reactive.Banana +import Reactive.Banana.WX + +import Data.Traversable (sequenceA) + +{----------------------------------------------------------------------------- + Main +------------------------------------------------------------------------------} +main = start $ do + f <- frame [text := "Bar Tab"] + msg <- staticText f [ text := "Sum:" ] + total <- staticText f [] + add <- button f [text := "Add"] + remove <- button f [text := "Remove"] + + let networkDescription :: forall t. Frameworks t => Moment t () + networkDescription = do + eAdd <- event0 add command + eRemove <- event0 remove command + + let + newEntry :: Frameworks s + => Moment s (TextCtrl (), AnyMoment Behavior String) + newEntry = do + wentry <- liftIONow $ entry f [] + bentry <- trimB =<< behaviorText wentry "" + return (wentry, bentry) + + eNewEntry <- execute $ (FrameworksMoment newEntry <$ eAdd) + + let + eDoRemove = whenE (not . null <$> bEntries) eRemove + + eEntries :: Event t [(TextCtrl (), AnyMoment Behavior String)] + eEntries = accumE [] $ + ((\x -> (++ [x])) <$> eNewEntry) `union` (init <$ eDoRemove) + + bEntries = stepper [] eEntries + + reactimate $ ((\w -> set w [ visible := False]) . fst . last) + <$> bEntries <@ eDoRemove + + let + ePrices :: Event t [AnyMoment Behavior Number] + ePrices = map (fmap readNumber . snd) <$> eEntries + + bLayout :: Behavior t Layout + bLayout = mkLayout . map fst <$> bEntries + + mkLayout entries = margin 10 $ column 10 $ + [row 10 [widget add, widget remove]] ++ map widget entries + ++ [row 10 $ [widget msg, minsize (sz 40 20) $ widget total]] + + bTotal :: Behavior t Number + bTotal = switchB (pure Nothing) $ + (fmap sum . sequenceA) <$> ePrices + + sink total [text :== showNumber <$> bTotal] + sink f [layout :== bLayout] + + network <- compile networkDescription + actuate network + +{----------------------------------------------------------------------------- + Utilities +------------------------------------------------------------------------------} +type Number = Maybe Double + +instance Num Number where + (+) = liftA2 (+) + (-) = liftA2 (-) + (*) = liftA2 (*) + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + +readNumber s = listToMaybe [x | (x,"") <- reads s] +showNumber = maybe "--" show diff --git a/src/CRUD.hs b/src/CRUD.hs --- a/src/CRUD.hs +++ b/src/CRUD.hs @@ -7,7 +7,7 @@ that the database is updated. This is perfectly fine for rapid prototyping. A more sophisticated approach would use incremental updates. ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t" +{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" {-# LANGUAGE RecursiveDo, NoMonomorphismRestriction #-} import Prelude hiding (lookup) @@ -49,7 +49,7 @@ ]] -- event network - let networkDescription :: forall t. NetworkDescription t () + let networkDescription :: forall t. Frameworks t => Moment t () networkDescription = mdo -- events from buttons eCreate <- event0 createBtn command @@ -60,15 +60,14 @@ tFilter = isPrefixOf <$> tFilterString bFilter = facts tFilter eFilter = rumors tFilter - + -- list box with selection eSelection <- rumors <$> reactiveListDisplay listBox bListBoxItems bSelection bShowDataItem - -- data item display eDataItemIn <- rumors <$> reactiveDataItem (firstname,lastname) bSelectionDataItem - + let -- database bDatabase :: Behavior t (Database DataItem) bDatabase = accumB emptydb $ unions @@ -106,6 +105,7 @@ let bDisplayItem :: Behavior t Bool bDisplayItem = maybe False (const True) <$> bSelection + sink deleteBtn [ enabled :== bDisplayItem ] sink firstname [ enabled :== bDisplayItem ] sink lastname [ enabled :== bDisplayItem ] @@ -134,11 +134,10 @@ showDataItem (firstname, lastname) = lastname ++ ", " ++ firstname -- single text entry -reactiveTextEntry - :: TextCtrl a - -> Behavior t String -- text value - -> NetworkDescription t - (Tidings t String) -- user changes +reactiveTextEntry :: Frameworks t + => TextCtrl a + -> Behavior t String -- text value + -> Moment t (Tidings t String) -- user changes reactiveTextEntry w btext = do eUser <- eventText w -- user changes @@ -152,11 +151,10 @@ return $ tidings btext eUser -- whole data item (consisting of two text entries) -reactiveDataItem - :: (TextCtrl a, TextCtrl b) +reactiveDataItem :: Frameworks t + => (TextCtrl a, TextCtrl b) -> Behavior t (Maybe DataItem) - -> NetworkDescription t - (Tidings t DataItem) + -> Moment t (Tidings t DataItem) reactiveDataItem (firstname,lastname) binput = do t1 <- reactiveTextEntry firstname (fst . maybe ("","") id <$> binput) t2 <- reactiveTextEntry lastname (snd . maybe ("","") id <$> binput) @@ -171,17 +169,18 @@ Changing the set may unselect the current item, but will not change it to another item. ------------------------------------------------------------------------------} -reactiveListDisplay :: forall t a b. Ord a +reactiveListDisplay :: forall t a b. (Ord a, Frameworks t) => 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 + -> Moment t (Tidings t (Maybe a)) -- current selection as item (possibly empty) reactiveListDisplay w bitems bsel bdisplay = do -- animate output items + liftIONow $ putStrLn "test" sink w [ items :== map <$> bdisplay <*> bitems ] - + -- animate output selection let bindices :: Behavior t (Map.Map a Int) bindices = (Map.fromList . flip zip [0..]) <$> bitems @@ -206,7 +205,7 @@ {- Currently exported from Reactive.Banana.WX -- user input event - text for text entries -eventText :: TextCtrl w -> NetworkDescription t (Event t String) +eventText :: TextCtrl w -> Moment t (Event t String) eventText w = do -- Should probably be wxEVT_COMMAND_TEXT_UPDATED , -- but that's missing from wxHaskell. @@ -220,7 +219,7 @@ 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 :: SingleListBox b -> Moment t (Event t Int) eventSelection w = do liftIO $ fixSelectionEvent w addHandler <- liftIO $ event1ToAddHandler w (event0ToEvent1 select) diff --git a/src/Counter.hs b/src/Counter.hs --- a/src/Counter.hs +++ b/src/Counter.hs @@ -3,7 +3,7 @@ Example: Counter ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t" +{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" import Control.Monad @@ -23,7 +23,7 @@ set f [layout := margin 10 $ column 5 [widget bup, widget bdown, widget output]] - let networkDescription :: forall t. NetworkDescription t () + let networkDescription :: forall t. Frameworks t => Moment t () networkDescription = do eup <- event0 bup command diff --git a/src/CurrencyConverter.hs b/src/CurrencyConverter.hs --- a/src/CurrencyConverter.hs +++ b/src/CurrencyConverter.hs @@ -3,7 +3,7 @@ Example: Currency Converter ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t" +{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" {-# LANGUAGE RecursiveDo #-} import Data.Bits @@ -30,7 +30,7 @@ , label "Amounts update while typing." ]] - let networkDescription :: forall t. NetworkDescription t () + let networkDescription :: forall t. Frameworks t => Moment t () networkDescription = do euroIn <- behaviorText euro "0" diff --git a/src/NetMonitor.hs b/src/NetMonitor.hs --- a/src/NetMonitor.hs +++ b/src/NetMonitor.hs @@ -3,7 +3,7 @@ Example: Minuscule network monitor ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t" +{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" import Data.Char import Data.List @@ -32,7 +32,7 @@ t <- timer f [ interval := 500 ] -- timer every 500 ms - let networkDescription :: forall t. NetworkDescription t () + let networkDescription :: forall t. Frameworks t => Moment t () networkDescription = do -- The network statistics are polled when and only when -- the event network handles an event. 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 @@ -11,6 +11,7 @@ -- * General event1, event0, behavior, Prop'(..), sink, + module Reactive.Banana.Frameworks, -- * Specific widgets eventText, behaviorText, eventSelection, @@ -21,6 +22,8 @@ ) where import Reactive.Banana +import Reactive.Banana.Frameworks + import qualified Graphics.UI.WX as WX import Graphics.UI.WX hiding (Event, Attr) import qualified Graphics.UI.WXCore as WXCore @@ -30,9 +33,10 @@ General ------------------------------------------------------------------------------} -- | Event with exactly one parameter. -event1 :: w -> WX.Event w (a -> IO ()) -> NetworkDescription t (Event t a) +event1 :: Frameworks t => + w -> WX.Event w (a -> IO ()) -> Moment t (Event t a) event1 widget e = do - addHandler <- liftIO $ event1ToAddHandler widget e + addHandler <- liftIONow $ event1ToAddHandler widget e fromAddHandler addHandler -- NOTE: Some events don't work, for instance leftKey and rightKey @@ -41,13 +45,15 @@ -- Not sure what to do with this. -- | Event without parameters. -event0 :: w -> WX.Event w (IO ()) -> NetworkDescription t (Event t ()) +event0 :: Frameworks t => + w -> WX.Event w (IO ()) -> Moment t (Event t ()) event0 widget = event1 widget . event0ToEvent1 -- | Behavior from an attribute. -- Uses 'fromPoll', so may behave as you expect. -behavior :: w -> WX.Attr w a -> NetworkDescription t (Behavior t a) -behavior widget attr = fromPoll . liftIO $ get widget attr +behavior :: Frameworks t => + w -> WX.Attr w a -> Moment t (Behavior t a) +behavior widget attr = fromPoll $ get widget attr -- | Variant of wx properties that accept a 'Behavior'. data Prop' t w = forall a. (WX.Attr w a) :== Behavior t a @@ -55,7 +61,8 @@ infixr 0 :== -- | "Animate" a property with a behavior -sink :: w -> [Prop' t w] -> NetworkDescription t () +sink :: Frameworks t => + w -> [Prop' t w] -> Moment t () sink widget props = mapM_ sink1 props where sink1 (attr :== b) = do @@ -69,9 +76,10 @@ ------------------------------------------------------------------------------} -- | Event that occurs when the /user/ changed -- the text in text edit widget. -eventText :: TextCtrl w -> NetworkDescription t (Event t String) +eventText :: Frameworks t => + TextCtrl w -> Moment t (Event t String) eventText w = do - addHandler <- liftIO $ event1ToAddHandler w (event0ToEvent1 onText) + addHandler <- liftIONow $ event1ToAddHandler w (event0ToEvent1 onText) fromAddHandler $ filterAddHandler (const $ WXCore.textCtrlIsModified w) $ mapIO (const $ get w text) addHandler @@ -85,20 +93,22 @@ -- 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 :: Frameworks t => + TextCtrl w -> String -> Moment t (Behavior t String) behaviorText w s = stepper s <$> eventText w -- | Event that occurs when the /user/ changed -- the selection marker in a list box widget. -eventSelection :: SingleListBox b -> NetworkDescription t (Event t Int) +eventSelection :: Frameworks t => + SingleListBox b -> Moment t (Event t Int) eventSelection w = do - liftIO $ fixSelectionEvent w - addHandler <- liftIO $ event1ToAddHandler w (event0ToEvent1 select) + liftIONow $ fixSelectionEvent w + addHandler <- liftIONow $ 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 ] + set listbox [ on unclick := handler ] where handler _ = do propagateEvent @@ -120,11 +130,3 @@ event0ToEvent1 :: WX.Event w (IO ()) -> WX.Event w (() -> IO ()) event0ToEvent1 = mapEvent const (\_ e -> e ()) --- | 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 () diff --git a/src/TicTacToe.hs b/src/TicTacToe.hs --- a/src/TicTacToe.hs +++ b/src/TicTacToe.hs @@ -4,7 +4,7 @@ Example: A version of TicTacToe with eclectic interface elements Original Author: Gideon Sireling ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t" +{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" import Control.Monad import Data.Array @@ -35,7 +35,7 @@ [map widget btns, map widget radios, map widget checks] , floatCenter $ widget label]] - let networkDescription :: forall t. NetworkDescription t () + let networkDescription :: forall t. Frameworks t => Moment t () networkDescription = do -- convert WxHaskell events to FRP events let event0s widgets event = forM widgets $ \x -> event0 x event diff --git a/src/Tidings.hs b/src/Tidings.hs deleted file mode 100644 --- a/src/Tidings.hs +++ /dev/null @@ -1,40 +0,0 @@ -{----------------------------------------------------------------------------- - reactive-banana -------------------------------------------------------------------------------} -module Tidings ( - -- * Synopsis - -- The 'Tidings' data type for composing user events. - -- - -- See - -- for more information. - - -- * Documentation - Tidings, tidings, facts, rumors, - ) where - -import Reactive.Banana.Combinators - --- | Data type representing a behavior 'facts' --- and suggestions to change it 'rumors'. -data Tidings t a = T { facts :: Behavior t a, rumors :: Event t a } - --- | Smart constructor. Combine facts and rumors into 'Tidings'. -tidings :: Behavior t a -> Event t a -> Tidings t a -tidings b e = T b (calm e) - -instance Functor (Tidings t) where - fmap f (T b e) = T (fmap f b) (fmap f e) - --- | The applicative instance combines 'rumors' --- and uses 'facts' when some of the 'rumors' are not available. -instance Applicative (Tidings t) where - pure x = T (pure x) never - f <*> x = uncurry ($) <$> pair f x - -pair :: Tidings t a -> Tidings t b -> Tidings t (a,b) -pair (T bx ex) (T by ey) = T b e - where - b = (,) <$> bx <*> by - x = flip (,) <$> by <@> ex - y = (,) <$> bx <@> ey - e = unionWith (\(x,_) (_,y) -> (x,y)) x y diff --git a/src/TwoCounters.hs b/src/TwoCounters.hs --- a/src/TwoCounters.hs +++ b/src/TwoCounters.hs @@ -3,7 +3,7 @@ Example: Two Counters. ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t" +{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" import Control.Monad @@ -27,7 +27,7 @@ grid 5 5 [[label "First Counter:" , widget out1] ,[label "Second Counter:", widget out2]]]] - let networkDescription :: forall t. NetworkDescription t () + let networkDescription :: forall t. Frameworks t => Moment t () networkDescription = do eup <- event0 bup command diff --git a/src/Wave.hs b/src/Wave.hs --- a/src/Wave.hs +++ b/src/Wave.hs @@ -5,7 +5,7 @@ Demonstrates that reactive-banana is capable of emitting timed events, even though it has no built-in notion of time. ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t" +{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" import Control.Monad import qualified Data.List as List @@ -38,7 +38,7 @@ -- we're going to need a timer t <- timer f [] - let networkDescription :: forall t. NetworkDescription t () + let networkDescription :: forall t. Frameworks t => Moment t () networkDescription = do eLeft <- event0 left command @@ -90,9 +90,10 @@ -- Schedule events to happen after a given duration from their occurrence -- However, new events will *not* be scheduled before the old ones have finished. -scheduleQueue :: Timer -> Event t (Enqueue a) -> NetworkDescription t (Event t a) +scheduleQueue :: Frameworks t => + Timer -> Event t (Enqueue a) -> Moment t (Event t a) scheduleQueue t e = do - liftIO $ set t [ enabled := False ] + liftIONow $ set t [ enabled := False ] eAlarm <- event0 t command let -- (Queue that keeps track of events to schedule