diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c)2011, Heinrich Apfelmus +Copyright (c)20112015, Heinrich Apfelmus All rights reserved. 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.9.0.2 +Version: 1.0.0.0 Synopsis: Examples for the reactive-banana library, using wxHaskell. Description: This library provides some GUI examples for the @reactive-banana@ library, @@ -13,7 +13,7 @@ . @cabal install reactive-banana-wx -fbuildExamples@ . - Stability forecast: The wrapper functions are rather provisional. + /Stability forecast/ The wrapper functions are rather provisional. Homepage: http://wiki.haskell.org/Reactive-banana License: BSD3 @@ -39,7 +39,7 @@ hs-source-dirs: src build-depends: base >= 4.2 && < 5, cabal-macosx >= 0.1 && < 0.3, - reactive-banana >= 0.8 && < 0.10, + reactive-banana >= 1.0 && < 1.1, wxcore (>= 0.13.2.1 && < 0.90) || (>= 0.90.0.1 && < 0.93), wx (>= 0.13.2.1 && < 0.90) || (>= 0.90.0.1 && < 0.93) extensions: ExistentialQuantification @@ -54,9 +54,9 @@ if flag(buildExamples) build-depends: process >= 1.0 && < 1.4, - random == 1.0.*, + random >= 1.0 && <= 1.1, executable-path == 0.0.*, - filepath >= 1.1 && <= 1.4, + filepath >= 1.1 && <= 1.4.0.0, reactive-banana, wx, wxcore, base cpp-options: -DbuildExamples else @@ -76,9 +76,9 @@ Executable Asteroids if flag(buildExamples) build-depends: - random == 1.0.*, + random >= 1.0 && <= 1.1, executable-path == 0.0.*, - filepath >= 1.1 && <= 1.4, + filepath >= 1.1 && <= 1.4.0.0, reactive-banana, wx, wxcore, base cpp-options: -DbuildExamples else diff --git a/src/Animation.hs b/src/Animation.hs --- a/src/Animation.hs +++ b/src/Animation.hs @@ -3,7 +3,14 @@ Example: A simple animation. ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" +{-# LANGUAGE ScopedTypeVariables #-} + -- allows pattern signatures like + -- do + -- (b :: Behavior Int) <- stepper 0 ... +{-# LANGUAGE RecursiveDo #-} + -- allows recursive do notation + -- mdo + -- ... import Graphics.UI.WX hiding (Event, Vector) import Reactive.Banana @@ -42,30 +49,32 @@ set ff [ layout := minsize (sz width height) $ widget pp ] -- event network - let networkDescription :: forall t. Frameworks t => Moment t () - networkDescription = do + let networkDescription :: MomentIO () + networkDescription = mdo etick <- event0 t command -- frame timer emouse <- event1 pp mouse -- mouse events - let - -- mouse pointer position - bmouse = fromPoint <$> stepper (point 0 0) + -- mouse pointer position + (bmouse :: Behavior Vector) <- + fmap fromPoint <$> stepper (point 0 0) (filterJust $ justMotion <$> emouse) - + + let -- sprite velocity - bvelocity :: Behavior t Vector + bvelocity :: Behavior 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) $ + -- sprite position + (bposition :: Behavior Vector) + <- accumB (vec 0 0) $ (\v pos -> clipToFrame $ (v `vecScale` dt) `vecAdd` pos) <$> bvelocity <@ etick + let clipToFrame v = vec (clip 0 x (fromIntegral $ width - bitmapWidth )) (clip 0 y (fromIntegral $ height - bitmapHeight)) diff --git a/src/Arithmetic.hs b/src/Arithmetic.hs --- a/src/Arithmetic.hs +++ b/src/Arithmetic.hs @@ -3,7 +3,6 @@ Example: Very simple arithmetic ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" import Data.Maybe @@ -25,14 +24,14 @@ [widget input1, label "+", widget input2 , label "=", minsize (sz 40 20) $ widget output]] - let networkDescription :: forall t. Frameworks t => Moment t () + let networkDescription :: MomentIO () networkDescription = do binput1 <- behaviorText input1 "" binput2 <- behaviorText input2 "" let - result :: Behavior t (Maybe Int) + result :: Behavior (Maybe Int) result = f <$> binput1 <*> binput2 where f x y = liftA2 (+) (readNumber x) (readNumber y) diff --git a/src/Asteroids.hs b/src/Asteroids.hs --- a/src/Asteroids.hs +++ b/src/Asteroids.hs @@ -1,17 +1,24 @@ {----------------------------------------------------------------------------- reactive-banana-wx - + Example: Asteroids, adapted from http://wiki.haskell.org/WxAsteroids - + The original example has a few graphics issues and I didn't put much work into correcting them. - For more, see also + For more, see also https://github.com/killerswan/wxAsteroids/issues/1 http://comments.gmane.org/gmane.comp.lang.haskell.wxhaskell.general/1086 ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" +{-# LANGUAGE ScopedTypeVariables #-} + -- allows pattern signatures like + -- do + -- (b :: Behavior Int) <- stepper 0 ... +{-# LANGUAGE RecursiveDo #-} + -- allows recursive do notation + -- mdo + -- ... import Graphics.UI.WX hiding (Event) import Graphics.UI.WXCore as WXCore @@ -30,7 +37,7 @@ width = 300 diameter = 24 -chance :: Double +chance :: Double chance = 0.1 rock, burning, ship :: Bitmap () @@ -39,13 +46,13 @@ ship = bitmap $ getDataFile "ship.ico" explode :: WXCore.Sound () -explode = sound $ getDataFile "explode.wav" +explode = sound $ getDataFile "explode.wav" main :: IO () main = start asteroids {----------------------------------------------------------------------------- - Game Logic + Game Logic ------------------------------------------------------------------------------} -- main game function asteroids :: IO () @@ -54,71 +61,74 @@ , bgcolor := white , resizeable := False ] - status <- statusField [text := "Welcome to asteroids"] - set ff [statusBar := [status]] + status <- statusField [text := "Welcome to asteroids"] + set ff [statusBar := [status]] t <- timer ff [ interval := 50 ] - game <- menuPane [ text := "&Game" ] + game <- menuPane [ text := "&Game" ] new <- menuItem game [ text := "&New\tCtrl+N", help := "New game" ] - pause <- menuItem game [ text := "&Pause\tCtrl+P" - , help := "Pause game" + pause <- menuItem game [ text := "&Pause\tCtrl+P" + , help := "Pause game" , checkable := True - ] + ] menuLine game - quit <- menuQuit game [help := "Quit the game"] - - set new [on command := asteroids] - set pause [on command := set t [enabled :~ not]] + quit <- menuQuit game [help := "Quit the game"] + + set new [on command := asteroids] + set pause [on command := set t [enabled :~ not]] set quit [on command := close ff] - + set ff [menuBar := [game]] - + 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)] + set pp [ on (charKey '-') := set t [interval :~ \i -> i * 2] + , on (charKey '+') := set t [interval :~ \i -> max 10 (div i 2)] ] - + -- event network - let networkDescription :: forall t. Frameworks t => Moment t () - networkDescription = do + let networkDescription :: MomentIO () + networkDescription = mdo -- timer etick <- event0 t command - + -- keyboard events ekey <- event1 pp keyboard let eleft = filterE ((== KeyLeft ) . keyKey) ekey eright = filterE ((== KeyRight) . keyKey) ekey - + -- ship position + (bship :: Behavior Int) + <- accumB (width `div` 2) $ unions + [ goLeft <$ eleft + , goRight <$ eright + ] let - bship :: Behavior t Int - bship = accumB (width `div` 2) $ - (goLeft <$ eleft) `union` (goRight <$ eright) - goLeft x = max 0 (x - 5) goRight x = min (width-30) (x + 5) - + -- rocks brandom <- fromPoll (randomRIO (0,1) :: IO Double) - let - brocks :: Behavior t [Rock] - brocks = accumB [] $ - (advanceRocks <$ etick) `union` - (newRock <$> filterE (< chance) (brandom <@ etick)) - + + (brocks :: Behavior [Rock]) + <- accumB [] $ unions + [ advanceRocks <$ etick + , newRock <$> filterE (< chance) (brandom <@ etick) + ] + -- draw the game state - sink pp [on paint :== stepper (\_dc _ -> return ()) $ - (drawGameState <$> bship <*> brocks) <@ etick] + bpaint <- stepper (\_dc _ -> return ()) $ + (drawGameState <$> bship <*> brocks) <@ etick + sink pp [on paint :== bpaint] reactimate $ repaint pp <$ etick - + -- status bar - let bstatus :: Behavior t String + let bstatus :: Behavior String bstatus = (\r -> "rocks: " ++ show (length r)) <$> brocks sink status [text :== bstatus] - - network <- compile networkDescription + + network <- compile networkDescription actuate network @@ -146,19 +156,19 @@ collisions = map (collide shipLocation) positions drawShip dc shipLocation - mapM (drawRock dc) (zip positions collisions) + mapM (drawRock dc) (zip positions collisions) when (or collisions) (play explode) collide :: Position -> Position -> Bool -collide pos0 pos1 = - let distance = vecLength (vecBetween pos0 pos1) - in distance <= fromIntegral diameter +collide pos0 pos1 = + let distance = vecLength (vecBetween pos0 pos1) + in distance <= fromIntegral diameter drawShip :: DC a -> Point -> IO () -drawShip dc pos = drawBitmap dc ship pos True [] +drawShip dc pos = drawBitmap dc ship pos True [] drawRock :: DC a -> (Point, Bool) -> IO () -drawRock dc (pos, collides) = +drawRock dc (pos, collides) = let rockPicture = if collides then burning else rock in drawBitmap dc rockPicture pos True [] diff --git a/src/BarTab.hs b/src/BarTab.hs --- a/src/BarTab.hs +++ b/src/BarTab.hs @@ -1,9 +1,16 @@ {----------------------------------------------------------------------------- reactive-banana-wx - + Example: Bar tab with a variable number of widgets ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" +{-# LANGUAGE ScopedTypeVariables #-} + -- allows pattern signatures like + -- do + -- (b :: Behavior Int) <- stepper 0 ... +{-# LANGUAGE RecursiveDo #-} + -- allows recursive do notation + -- mdo + -- ... {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} import Data.Maybe (listToMaybe) @@ -24,53 +31,52 @@ total <- staticText f [] add <- button f [text := "Add"] remove <- button f [text := "Remove"] - - let networkDescription :: forall t. Frameworks t => Moment t () - networkDescription = do + + let networkDescription :: MomentIO () + networkDescription = mdo eAdd <- event0 add command eRemove <- event0 remove command - + let - newEntry :: Frameworks s - => Moment s (TextCtrl (), AnyMoment Behavior String) + newEntry :: MomentIO (TextCtrl (), Behavior String) newEntry = do wentry <- liftIO $ entry f [] - bentry <- trimB =<< behaviorText wentry "" + bentry <- 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 - + + eNewEntry <- execute $ newEntry <$ eAdd + + let eDoRemove = whenE (not . null <$> bEntries) eRemove + + (eEntries :: Event [(TextCtrl (), Behavior String)]) + <- accumE [] $ unions + [ (\x -> (++ [x])) <$> eNewEntry + , init <$ eDoRemove + ] + bEntries <- stepper [] eEntries + reactimate $ ((\w -> set w [ visible := False]) . fst . last) <$> bEntries <@ eDoRemove - + let - ePrices :: Event t [AnyMoment Behavior Number] + ePrices :: Event [Behavior Number] ePrices = map (fmap readNumber . snd) <$> eEntries - - bLayout :: Behavior t Layout + + bLayout :: Behavior 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 :: Behavior Number bTotal = switchB (pure Nothing) $ (fmap sum . sequenceA) <$> ePrices sink total [text :== showNumber <$> bTotal] sink f [layout :== bLayout] - - network <- compile networkDescription + + network <- compile networkDescription actuate network {----------------------------------------------------------------------------- @@ -87,7 +93,7 @@ fromInteger = pure . fromInteger readNumber :: Read a => String -> Maybe a -readNumber s = listToMaybe [x | (x,"") <- reads s] +readNumber s = listToMaybe [x | (x,"") <- reads s] showNumber :: Maybe Double -> String showNumber = maybe "--" show diff --git a/src/CRUD.hs b/src/CRUD.hs --- a/src/CRUD.hs +++ b/src/CRUD.hs @@ -7,8 +7,14 @@ 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. Moment t" -{-# LANGUAGE RecursiveDo, NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} + -- allows pattern signatures like + -- do + -- (b :: Behavior Int) <- stepper 0 ... +{-# LANGUAGE RecursiveDo #-} + -- allows recursive do notation + -- mdo + -- ... import Prelude hiding (lookup) import Data.List (isPrefixOf) @@ -46,15 +52,15 @@ ]] -- event network - let networkDescription :: forall t. Frameworks t => Moment t () + let networkDescription :: MomentIO () networkDescription = mdo -- events from buttons eCreate <- event0 createBtn command eDelete <- event0 deleteBtn command -- filter string tFilterString <- reactiveTextEntry filterEntry bFilterString - let bFilterString = stepper "" $ rumors tFilterString - tFilter = isPrefixOf <$> tFilterString + bFilterString <- stepper "" $ rumors tFilterString + let tFilter = isPrefixOf <$> tFilterString bFilter = facts tFilter eFilter = rumors tFilter @@ -65,42 +71,42 @@ eDataItemIn <- rumors <$> reactiveDataItem (firstname,lastname) bSelectionDataItem - let -- database - bDatabase :: Behavior t (Database DataItem) - bDatabase = accumB emptydb $ unions + -- database + (bDatabase :: Behavior (Database DataItem)) + <- accumB emptydb $ unions [ create ("Emil","Example") <$ eCreate , filterJust $ update' <$> bSelection <@> eDataItemIn , delete <$> filterJust (bSelection <@ eDelete) ] - where - update' mkey x = flip update x <$> mkey + let update' mkey x = flip update x <$> mkey - -- selection - bSelection :: Behavior t (Maybe DatabaseKey) - bSelection = stepper Nothing $ unions + -- selection + (bSelection :: Behavior (Maybe DatabaseKey)) + <- stepper Nothing $ foldr1 (unionWith const) [ 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) + + let + bLookup :: Behavior (DatabaseKey -> Maybe DataItem) bLookup = flip lookup <$> bDatabase - bShowDataItem :: Behavior t (DatabaseKey -> String) + bShowDataItem :: Behavior (DatabaseKey -> String) bShowDataItem = (maybe "" showDataItem .) <$> bLookup - bListBoxItems :: Behavior t [DatabaseKey] + bListBoxItems :: Behavior [DatabaseKey] bListBoxItems = (\p show -> filter (p. show) . keys) <$> bFilter <*> bShowDataItem <*> bDatabase - bSelectionDataItem :: Behavior t (Maybe DataItem) + bSelectionDataItem :: Behavior (Maybe DataItem) bSelectionDataItem = (=<<) <$> bLookup <*> bSelection -- automatically enable / disable editing let - bDisplayItem :: Behavior t Bool + bDisplayItem :: Behavior Bool bDisplayItem = isJust <$> bSelection sink deleteBtn [ enabled :== bDisplayItem ] @@ -143,10 +149,10 @@ showDataItem (firstname, lastname) = lastname ++ ", " ++ firstname -- single text entry -reactiveTextEntry :: Frameworks t - => TextCtrl a - -> Behavior t String -- text value - -> Moment t (Tidings t String) -- user changes +reactiveTextEntry + :: TextCtrl a + -> Behavior String -- text value + -> MomentIO (Tidings String) -- user changes reactiveTextEntry w btext = do eUser <- eventText w -- user changes @@ -160,10 +166,10 @@ return $ tidings btext eUser -- whole data item (consisting of two text entries) -reactiveDataItem :: Frameworks t - => (TextCtrl a, TextCtrl b) - -> Behavior t (Maybe DataItem) - -> Moment t (Tidings t DataItem) +reactiveDataItem + :: (TextCtrl a, TextCtrl b) + -> Behavior (Maybe DataItem) + -> MomentIO (Tidings DataItem) reactiveDataItem (firstname,lastname) binput = do t1 <- reactiveTextEntry firstname (fst . fromMaybe ("","") <$> binput) t2 <- reactiveTextEntry lastname (snd . fromMaybe ("","") <$> binput) @@ -178,19 +184,19 @@ Changing the set may unselect the current item, but will not change it to another item. ------------------------------------------------------------------------------} -reactiveListDisplay :: forall t a b. (Ord a, Frameworks t) +reactiveListDisplay :: forall 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 - -> Moment t - (Tidings t (Maybe a)) -- current selection as item (possibly empty) + -> Behavior [a] -- list of items + -> Behavior (Maybe a) -- selected element + -> Behavior (a -> String) -- display an item + -> MomentIO + (Tidings (Maybe a)) -- current selection as item (possibly empty) reactiveListDisplay w bitems bsel bdisplay = do -- animate output items sink w [ items :== map <$> bdisplay <*> bitems ] -- animate output selection - let bindices :: Behavior t (Map.Map a Int) + let bindices :: Behavior (Map.Map a Int) bindices = (Map.fromList . flip zip [0..]) <$> bitems bindex = (\m a -> fromMaybe (-1) $ flip Map.lookup m =<< a) <$> bindices <*> bsel @@ -201,7 +207,7 @@ -- sink listBox [ selection :== stepper (-1) $ bSelection <@ eDisplay ] -- user selection - let bindices2 :: Behavior t (Map.Map Int a) + let bindices2 :: Behavior (Map.Map Int a) bindices2 = Map.fromList . zip [0..] <$> bitems esel <- eventSelection w return $ tidings bsel $ flip Map.lookup <$> bindices2 <@> esel diff --git a/src/Counter.hs b/src/Counter.hs --- a/src/Counter.hs +++ b/src/Counter.hs @@ -3,7 +3,10 @@ Example: Counter ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" +{-# LANGUAGE ScopedTypeVariables #-} + -- allows pattern signatures like + -- do + -- (b :: Behavior Int) <- stepper 0 ... import Graphics.UI.WX hiding (Event) import Reactive.Banana @@ -22,16 +25,18 @@ set f [layout := margin 10 $ column 5 [widget bup, widget bdown, widget output]] - let networkDescription :: forall t. Frameworks t => Moment t () + let networkDescription :: MomentIO () networkDescription = do eup <- event0 bup command edown <- event0 bdown command - let - counter :: Behavior t Int - counter = accumB 0 $ ((+1) <$ eup) `union` (subtract 1 <$ edown) - + (counter :: Behavior Int) + <- accumB 0 $ unions + [ (+1) <$ eup + , subtract 1 <$ edown + ] + sink output [text :== show <$> counter] network <- compile networkDescription diff --git a/src/CurrencyConverter.hs b/src/CurrencyConverter.hs --- a/src/CurrencyConverter.hs +++ b/src/CurrencyConverter.hs @@ -3,7 +3,6 @@ Example: Currency Converter ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" import Data.Maybe import Text.Printf @@ -31,7 +30,7 @@ set f [layout := widget p] focusOn dollar - let networkDescription :: forall t. Frameworks t => Moment t () + let networkDescription :: MomentIO () networkDescription = do euroIn <- behaviorText euro "0" @@ -43,7 +42,7 @@ $ listToMaybe [x | (x,"") <- reads s] -- define output values in terms of input values - dollarOut, euroOut :: Behavior t String + dollarOut, euroOut :: Behavior String dollarOut = withString (/ rate) <$> euroIn euroOut = withString (* rate) <$> dollarIn diff --git a/src/NetMonitor.hs b/src/NetMonitor.hs --- a/src/NetMonitor.hs +++ b/src/NetMonitor.hs @@ -3,7 +3,6 @@ Example: Minuscule network monitor ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" import Data.Char import Data.List @@ -33,7 +32,7 @@ t <- timer f [ interval := 500 ] -- timer every 500 ms - let networkDescription :: forall t. Frameworks t => Moment t () + let networkDescription :: MomentIO () 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 @@ -32,8 +32,7 @@ General ------------------------------------------------------------------------------} -- | Event with exactly one parameter. -event1 :: Frameworks t => - w -> WX.Event w (a -> IO ()) -> Moment t (Event t a) +event1 :: w -> WX.Event w (a -> IO ()) -> MomentIO (Event a) event1 widget e = do addHandler <- liftIO $ event1ToAddHandler widget e fromAddHandler addHandler @@ -44,28 +43,25 @@ -- Not sure what to do with this. -- | Event without parameters. -event0 :: Frameworks t => - w -> WX.Event w (IO ()) -> Moment t (Event t ()) +event0 :: w -> WX.Event w (IO ()) -> MomentIO (Event ()) event0 widget = event1 widget . event0ToEvent1 -- | Behavior from an attribute. -- Uses 'fromPoll', so may behave as you expect. -behavior :: Frameworks t => - w -> WX.Attr w a -> Moment t (Behavior t a) +behavior :: w -> WX.Attr w a -> MomentIO (Behavior 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 +data Prop' w = forall a. (WX.Attr w a) :== Behavior a infixr 0 :== -- | "Animate" a property with a behavior -sink :: Frameworks t => - w -> [Prop' t w] -> Moment t () +sink :: w -> [Prop' w] -> MomentIO () sink widget = mapM_ sink1 where sink1 (attr :== b) = do - x <- initial b + x <- valueBLater b liftIOLater $ set widget [attr := x] e <- changes b reactimate' $ (fmap $ \x -> set widget [attr := x]) <$> e @@ -75,8 +71,7 @@ ------------------------------------------------------------------------------} -- | Event that occurs when the /user/ changed -- the text in text edit widget. -eventText :: Frameworks t => - TextCtrl w -> Moment t (Event t String) +eventText :: TextCtrl w -> MomentIO (Event String) eventText w = do addHandler <- liftIO $ event1ToAddHandler w (event0ToEvent1 onText) fromAddHandler @@ -92,14 +87,12 @@ -- keyboardUp = WX.newEvent "keyboardUp" WXCore.windowGetOnKeyUp WXCore.windowOnKeyUp -- | Behavior corresponding to user input the text field. -behaviorText :: Frameworks t => - TextCtrl w -> String -> Moment t (Behavior t String) -behaviorText w s = stepper s <$> eventText w +behaviorText :: TextCtrl w -> String -> MomentIO (Behavior String) +behaviorText w s = stepper s =<< eventText w -- | Event that occurs when the /user/ changed -- the selection marker in a list box widget. -eventSelection :: Frameworks t => - SingleListBox b -> Moment t (Event t Int) +eventSelection :: SingleListBox b -> MomentIO (Event Int) eventSelection w = do liftIO $ fixSelectionEvent w addHandler <- liftIO $ event1ToAddHandler w (event0ToEvent1 select) diff --git a/src/TicTacToe.hs b/src/TicTacToe.hs --- a/src/TicTacToe.hs +++ b/src/TicTacToe.hs @@ -4,7 +4,14 @@ Example: A version of TicTacToe with eclectic interface elements Original Author: Gideon Sireling ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" +{-# LANGUAGE ScopedTypeVariables #-} + -- allows pattern signatures like + -- do + -- (b :: Behavior Int) <- stepper 0 ... +{-# LANGUAGE RecursiveDo #-} + -- allows recursive do notation + -- mdo + -- ... import Control.Monad import Data.Array @@ -20,7 +27,7 @@ User Interface ------------------------------------------------------------------------------} -main :: IO () +main :: IO () main = start $ do -- create the main window window <- frame [text := "OX"] @@ -35,29 +42,30 @@ [map widget btns, map widget radios, map widget checks] , floatCenter $ widget label]] - let networkDescription :: forall t. Frameworks t => Moment t () - networkDescription = do + let networkDescription :: MomentIO () + networkDescription = mdo -- convert WxHaskell events to FRP events let event0s widgets event = forM widgets $ \x -> event0 x event events <- liftM concat $ sequence [event0s btns command, event0s radios select, event0s checks command] let - moves :: Event t (Game -> Game) - moves = foldl1 union $ zipWith (\e s -> move s <$ e) events + moves :: Event (Game -> Game) + moves = unions $ zipWith (\e s -> move s <$ e) events [(x,y) | y <- [1..3], x <- [1..3]] - eState :: Event t Game - eState = accumE newGame moves + (eState :: Event Game) + <- accumE newGame moves - state :: Behavior t Game - state = stepper newGame eState + (state :: Behavior Game) + <- stepper newGame eState - currentPlayer :: Behavior t String + let + currentPlayer :: Behavior String currentPlayer = (show . player) <$> state - tokens :: [Behavior t String] - tokens = map (\e -> stepper "" (currentPlayer <@ e)) events + (tokens :: [Behavior String]) + <- mapM (\e -> stepper "" (currentPlayer <@ e)) events -- wire up the widget event handlers zipWithM_ (\b e -> sink b [text :== e, enabled :== null <$> e]) diff --git a/src/Tidings.hs b/src/Tidings.hs --- a/src/Tidings.hs +++ b/src/Tidings.hs @@ -16,22 +16,22 @@ -- | 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 } +data Tidings a = T { facts :: Behavior a, rumors :: Event 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) +tidings :: Behavior a -> Event a -> Tidings a +tidings b e = T b e -instance Functor (Tidings t) where +instance Functor Tidings 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 +instance Applicative Tidings 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 :: Tidings a -> Tidings b -> Tidings (a,b) pair (T bx ex) (T by ey) = T b e where b = (,) <$> bx <*> by diff --git a/src/TwoCounters.hs b/src/TwoCounters.hs --- a/src/TwoCounters.hs +++ b/src/TwoCounters.hs @@ -3,7 +3,14 @@ Example: Two Counters. ------------------------------------------------------------------------------} -{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t" +{-# LANGUAGE ScopedTypeVariables #-} + -- allows pattern signatures like + -- do + -- (b :: Behavior Int) <- stepper 0 ... +{-# LANGUAGE RecursiveDo #-} + -- allows recursive do notation + -- mdo + -- ... import Graphics.UI.WX hiding (Event) import Reactive.Banana @@ -26,24 +33,25 @@ grid 5 5 [[label "First Counter:" , widget out1] ,[label "Second Counter:", widget out2]]]] - let networkDescription :: forall t. Frameworks t => Moment t () - networkDescription = do + let networkDescription :: forall t. MomentIO () + networkDescription = mdo eup <- event0 bup command edown <- event0 bdown command eswitch <- event0 bswitch command let - -- do we act on the left button? - firstcounter :: Behavior t Bool - firstcounter = accumB True $ not <$ eswitch + -- do we act on the left button? + (firstcounter :: Behavior Bool) + <- accumB True $ not <$ eswitch - -- joined state of the two counters - counters :: Behavior t (Int, Int) - counters = accumB (0,0) $ - union ((increment <$> firstcounter) `apply` eup) - ((decrement <$> firstcounter) `apply` edown) - + -- joined state of the two counters + (counters :: Behavior (Int, Int)) + <- accumB (0,0) $ unions + [ increment <$> firstcounter <@> eup + , decrement <$> firstcounter <@> edown + ] + let increment left _ (x,y) = if left then (x+1,y) else (x,y+1) decrement left _ (x,y) = if left then (x-1,y) else (x,y-1) diff --git a/src/Wave.hs b/src/Wave.hs --- a/src/Wave.hs +++ b/src/Wave.hs @@ -1,11 +1,18 @@ {----------------------------------------------------------------------------- reactive-banana-wx - + Example: Emit a wave of lights. 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. Moment t" +{-# LANGUAGE ScopedTypeVariables #-} + -- allows pattern signatures like + -- do + -- (b :: Behavior Int) <- stepper 0 ... +{-# LANGUAGE RecursiveDo #-} + -- allows recursive do notation + -- mdo + -- ... import Control.Monad import qualified Data.List as List @@ -34,37 +41,39 @@ left <- button f [text := "Left"] right <- button f [text := "Right"] lights <- replicateM lightCount $ staticText f [text := "•"] - + set f [layout := margin 10 $ column 10 [row 5 [widget left, widget right], row 5 $ map widget lights] ] - + -- we're going to need a timer t <- timer f [] - - let networkDescription :: forall t. Frameworks t => Moment t () + + let networkDescription :: MomentIO () networkDescription = do eLeft <- event0 left command eRight <- event0 right command - + -- event describing all the lights - eWave <- scheduleQueue t $ (waveLeft <$ eLeft ) `union` - (waveRight <$ eRight) - + eWave <- scheduleQueue t $ unionWith (++) + (waveLeft <$ eLeft ) + (waveRight <$ eRight) + -- animate the lights forM_ [1 .. lightCount] $ \k -> do let bulb = lights !! (k-1) - bBulb = stepper False $ snd <$> filterE ((== k) . fst) eWave - + colorize True = red colorize False = black - - sink bulb [ color :== colorize <$> bBulb ] - network <- compile networkDescription + bBulb <- stepper False $ snd <$> filterE ((== k) . fst) eWave + + sink bulb [ color :== colorize <$> bBulb ] + + network <- compile networkDescription actuate network @@ -78,7 +87,7 @@ merge xs ys = List.sortBy (comparing fst) $ xs ++ ys deltas xs = zipWith relativize (0 : map fst xs) xs where relativize dt1 (dt2,x) = (dt2-dt1, x) - + ons = [(k*2*dt, (f k, True)) | k <- [1..lightCount]] offs = [(dt+(waveLength+k)*2*dt, (f k, False)) | k <- [1..lightCount]] @@ -98,34 +107,30 @@ -- 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 :: Frameworks t => - Timer -> Event t (Enqueue a) -> Moment t (Event t a) -scheduleQueue t e = do +scheduleQueue :: Timer -> Event (Enqueue a) -> MomentIO (Event a) +scheduleQueue t e = mdo liftIO $ set t [ enabled := False ] eAlarm <- event0 t command + + -- (Queue that keeps track of events to schedule + -- , duration of the new alarm if applicable) + (eSetNewAlarmDuration, bQueue) + <- mapAccum [] $ unionWith const (remove <$ eAlarm) (add <$> e) + let - -- (Queue that keeps track of events to schedule - -- , duration of the new alarm if applicable) - (eSetNewAlarmDuration, bQueue) = - mapAccum [] $ (remove <$ eAlarm) `union` (add <$> e) - -- change queue and change timer remove (_:[]) = (stop, []) remove (_:xs) = (wait (fst $ head xs), xs) add ys [] = (wait (fst $ head ys), ys) add ys xs = (idle, xs ++ ys) - + wait dt = set t [ enabled := True, interval := dt ] stop = set t [ enabled := False ] idle = return () - + -- Return topmost value from the queue whenever the alarm rings. -- The queue is never empty when the alarm rings. eout = fmap (snd . head) $ bQueue <@ eAlarm - + reactimate eSetNewAlarmDuration return eout - - - -