diff --git a/doc/examples/ActuatePause.hs b/doc/examples/ActuatePause.hs --- a/doc/examples/ActuatePause.hs +++ b/doc/examples/ActuatePause.hs @@ -11,7 +11,7 @@ import Debug.Trace import Data.IORef -import Reactive.Banana as R +import Reactive.Banana main :: IO () diff --git a/doc/examples/SlotMachine.hs b/doc/examples/SlotMachine.hs --- a/doc/examples/SlotMachine.hs +++ b/doc/examples/SlotMachine.hs @@ -3,6 +3,8 @@ Example: Slot machine ------------------------------------------------------------------------------} +{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t" + import Control.Monad (when) import Data.Maybe (isJust, fromJust) import Data.List (nub) @@ -18,7 +20,7 @@ main = do displayHelpMessage sources <- makeSources - network <- setupNetwork sources + network <- compile $ setupNetwork sources actuate network eventLoop sources @@ -82,9 +84,8 @@ -- Set up the program logic in terms of events and behaviors. -setupNetwork :: (EventSource (), EventSource ()) -> IO EventNetwork -setupNetwork (escoin,esplay) = compile $ do - +setupNetwork :: forall t. (EventSource (), EventSource ()) -> NetworkDescription t () +setupNetwork (escoin,esplay) = do -- initial random number generator initialStdGen <- liftIO $ newStdGen @@ -99,8 +100,8 @@ -- The ecoin event adds a coin to the credits -- The edoesplay event removes money -- The ewin event adds credits because the player has won - bcredits :: Behavior Money - ecredits :: Event Money + bcredits :: Behavior t Money + ecredits :: Event t Money (ecredits, bcredits) = mapAccum 0 . fmap (\f x -> (f x,f x)) $ ((addCredit <$ ecoin) `union` (removeCredit <$ edoesplay) @@ -113,20 +114,20 @@ addWin Triple = (+20) -- Event: does the player have enough money to play the game? - emayplay :: Event Bool + emayplay :: Event t Bool emayplay = apply ((\credits _ -> credits > 0) <$> bcredits) eplay -- Event: player has enough coins and plays - edoesplay :: Event () + edoesplay :: Event t () edoesplay = () <$ filterE id emayplay -- Event: event that fires when the player doesn't have enough money - edenied :: Event () + edenied :: Event t () edenied = () <$ filterE not emayplay -- State: random number generator - bstdgen :: Behavior StdGen - eroll :: Event Reels + bstdgen :: Behavior t StdGen + eroll :: Event t Reels -- accumulate the random number generator while rolling the reels (eroll, bstdgen) = mapAccum initialStdGen (roll <$> edoesplay) @@ -140,7 +141,7 @@ (z3,gen3) = random gen2 -- Event: it's a win! - ewin :: Event Win + ewin :: Event t Win ewin = fmap fromJust $ filterE isJust $ fmap checkWin eroll checkWin (z1,z2,z3) | length (nub [z1,z2,z3]) == 1 = Just Triple diff --git a/reactive-banana.cabal b/reactive-banana.cabal --- a/reactive-banana.cabal +++ b/reactive-banana.cabal @@ -1,32 +1,18 @@ Name: reactive-banana -Version: 0.4.3.2 -Synopsis: Small but solid library for - functional reactive programming (FRP). +Version: 0.5.0.0 +Synopsis: Practical library for functional reactive programming (FRP). Description: - A small but solid library for functional reactive programming (FRP). - . - The current focus of this library is to implement - a subset of the semantic model for functional reactive programming - pioneered by Conal Elliott. - . - Moreover, this library can hooked into /any/ - existing event-based framework. - It is especially useful in conjunction with existing - GUI frameworks like @wxHaskell@ or @gtk2hs@. + Reactive-banana is a practical library for Functional Reactive Programming (FRP). . - This also means that your code can be a mix of FRP and imperative parts. - Bored of programming imperative GUIs? Write some parts with FRP! - Don't know how to express something with FRP? - Switch back to imperative style! + FRP offers an elegant and concise way to express interactive programs such as graphical user interfaces, animations, computer music or robot controllers. Thus, the reactive-banana library promises to avoid the spagethetti code commonly used in traditional GUI technologies. . - In the spectrum of possible FRP implementations, - this one features simple semantics but modest expressivity. - Predicting space & time usage should be easy. + See the project homepage + for a more detailed introduction and features. . Stability forecast: - Known inefficiencies that will be addressed. No semantic bugs expected. - Significant API changes are likely in future versions. + Significant API changes are likely in future versions, + though the main interface is beginning to stabilize. Homepage: http://haskell.org/haskellwiki/Reactive-banana License: BSD3 @@ -43,7 +29,8 @@ Library hs-source-dirs: src - extensions: TypeFamilies, FlexibleContexts, + extensions: + TypeFamilies, FlexibleContexts, FlexibleInstances, EmptyDataDecls, GADTs, BangPatterns, TupleSections, Rank2Types, NoMonomorphismRestriction, @@ -52,13 +39,21 @@ base >= 4.2 && < 5, containers >= 0.3 && < 0.5, transformers == 0.2.*, QuickCheck >= 1.2 && < 2.5, - vault == 0.1.* - exposed-modules: Reactive.Banana, - Reactive.Banana.Incremental, - Reactive.Banana.Model, - Reactive.Banana.Implementation, + vault == 0.1.*, unordered-containers == 0.2.*, hashable == 1.1.*, + fclabels == 1.1.* + exposed-modules: + Reactive.Banana, + Reactive.Banana.Combinators, + Reactive.Banana.Frameworks, + Reactive.Banana.Experimental.Calm, + Reactive.Banana.Internal.Model + other-modules: + Reactive.Banana.Internal.AST, + Reactive.Banana.Internal.InputOutput, + Reactive.Banana.Internal.PushGraph, + Reactive.Banana.Internal.TotalOrder, Reactive.Banana.Tests - other-modules: Reactive.Banana.PushIO + Source-repository head type: git diff --git a/src/Reactive/Banana.hs b/src/Reactive/Banana.hs --- a/src/Reactive/Banana.hs +++ b/src/Reactive/Banana.hs @@ -5,19 +5,9 @@ ------------------------------------------------------------------------------} module Reactive.Banana ( - module Reactive.Banana.Incremental, - module Reactive.Banana.Model, - module Reactive.Banana.Implementation, - - Event, Behavior, Discrete, + module Reactive.Banana.Combinators, + module Reactive.Banana.Frameworks, ) where -import Reactive.Banana.Incremental hiding (Discrete) -import qualified Reactive.Banana.Incremental as Polymorph -import Reactive.Banana.Model hiding (interpret, Event, Behavior) -import qualified Reactive.Banana.Model as Polymorph -import Reactive.Banana.Implementation - -type Event = Polymorph.Event PushIO -type Behavior = Polymorph.Behavior PushIO -type Discrete = Polymorph.Discrete PushIO +import Reactive.Banana.Combinators +import Reactive.Banana.Frameworks diff --git a/src/Reactive/Banana/Combinators.hs b/src/Reactive/Banana/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Combinators.hs @@ -0,0 +1,318 @@ +{----------------------------------------------------------------------------- + Reactive Banana +------------------------------------------------------------------------------} +{-# LANGUAGE Rank2Types, MultiParamTypeClasses, TupleSections, FlexibleInstances #-} + +module Reactive.Banana.Combinators ( + -- * Synopsis + -- | Combinators for building event graphs. + + -- * Introduction + -- $intro1 + Event(..), Behavior(..), + -- $intro2 + interpretModel, interpretPushGraph, + + -- * Core Combinators + module Control.Applicative, + module Data.Monoid, + never, union, filterE, collect, spill, accumE, + apply, stepper, + -- $classes + + -- * Derived Combinators + -- ** Filtering + filterJust, filterApply, whenE, split, + -- ** Accumulation + -- $Accumulation. + accumB, mapAccum, + -- ** Simultaneous event occurrences + calm, unionWith, + -- ** Apply class + Apply(..), + ) where + +import Control.Applicative +import Control.Monad + +import Data.Maybe (isJust) +import Data.Monoid (Monoid(..)) + +import Reactive.Banana.Internal.InputOutput +import qualified Reactive.Banana.Internal.AST as AST +import qualified Reactive.Banana.Internal.Model as Model +import Reactive.Banana.Internal.PushGraph + +{----------------------------------------------------------------------------- + Introduction +------------------------------------------------------------------------------} +{-$intro1 + +At its core, Functional Reactive Programming (FRP) is about two +data types 'Event' and 'Behavior' and the various ways to combine them. + +-} + +{-| @Event t a@ represents a stream of events as they occur in time. +Semantically, you can think of @Event t a@ as an infinite list of values +that are tagged with their corresponding time of occurence, + +> type Event t a = [(Time,a)] +-} +newtype Event t a = E { unE :: AST.Event AST.Expr [a] } + -- ^ (Constructor exported for internal use only.) + +{-| @Behavior t a@ represents a value that varies in time. Think of it as + +> type Behavior t a = Time -> a +-} +newtype Behavior t a = B { unB :: AST.Behavior AST.Expr a } + -- ^ (Constructor exported for internal use only.) + +{-$intro2 + +As you can see, both types seem to have a superfluous parameter @t@. +The library uses it to rule out certain gross inefficiencies, +in particular in connection with dynamic event switching. +For basic stuff, you can completely ignore it, +except of course for the fact that it will annoy you in your type signatures. + +While the type synonyms mentioned above are the way you should think about +'Behavior' and 'Event', they are a bit vague for formal manipulation. +To remedy this, the library provides a very simple but authoritative +model implementation. See 'Reactive.Banana.Model' for more. + +-} + +{----------------------------------------------------------------------------- + Interpetation +------------------------------------------------------------------------------} +-- | Interpret with model implementation. +-- Useful for testing. +interpretModel :: (forall t. Event t a -> Event t b) -> [[a]] -> IO [[b]] +interpretModel f xs = + map toList <$> Model.interpretModel (unE . f . E) (map Just xs) + +-- | Interpret with push-based implementation. +-- Useful for testing. +interpretPushGraph :: (forall t. Event t a -> Event t b) -> [[a]] -> IO [[b]] +interpretPushGraph f xs = do + i <- newInputChannel + automaton <- compileToAutomaton (unE . f . E $ AST.inputE i) + map toList <$> unfoldAutomaton automaton i xs + +toList :: Maybe [a] -> [a] +toList Nothing = [] +toList (Just xs) = xs + +{----------------------------------------------------------------------------- + Basic combinators + + Implemented in terms of Reactive.Banana.Internal.AST +------------------------------------------------------------------------------} +singleton :: a -> [a] +singleton x = [x] + +-- | Event that never occurs. +-- Think of it as @never = []@. +never :: Event t a +never = E $ singleton <$> AST.never + +-- | Merge two event streams of the same type. +-- In case of simultaneous occurrences, the left argument comes first. +-- Think of it as +-- +-- > union ((timex,x):xs) ((timey,y):ys) +-- > | timex <= timey = (timex,x) : union xs ((timey,y):ys) +-- > | timex > timey = (timey,y) : union ((timex,x):xs) ys +union :: Event t a -> Event t a -> Event t a +union e1 e2 = E $ AST.unionWith (++) (unE e1) (unE e2) + +-- | Allow all events that fulfill the predicate, discard the rest. +-- Think of it as +-- +-- > filterE p es = [(time,a) | (time,a) <- es, p a] +filterE :: (a -> Bool) -> Event t a -> Event t a +filterE p = E . AST.filterE (not . null) . (filter p <$>) . unE + +-- | Collect simultaneous event occurences. +-- The result will never contain an empty list. +-- Example: +-- +-- > collect [(time1, e1), (time1, e2)] = [(time1, [e1,e2])] +collect :: Event t a -> Event t [a] +collect e = E $ singleton <$> unE e + +-- | Emit simultaneous event occurrences. +-- Up to strictness, we have +-- +-- > spill . collect = id +spill :: Event t [a] -> Event t a +spill e = E $ concat <$> unE e + +-- | Construct a time-varying function from an initial value and +-- a stream of new values. Think of it as +-- +-- > stepper x0 ex = \time -> last (x0 : [x | (timex,x) <- ex, timex < time]) +-- +-- Note that the smaller-than-sign in the comparision @timex < time@ means +-- that the value of the behavior changes \"slightly after\" +-- the event occurrences. This allows for recursive definitions. +-- +-- Also note that in the case of simultaneous occurrences, +-- only the last one is kept. +stepper :: a -> Event t a -> Behavior t a +stepper x e = B $ AST.stepperB x (last <$> unE e) + +-- | The 'accumE' function accumulates a stream of events. +-- Example: +-- +-- > accumE "x" [(time1,(++"y")),(time2,(++"z"))] +-- > = [(time1,"xy"),(time2,"xyz")] +-- +-- Note that the output events are simultaneous with the input events, +-- there is no \"delay\" like in the case of 'accumB'. +accumE :: a -> Event t (a -> a) -> Event t a +accumE acc = E . mapAccumE acc . fmap concatenate . unE + where + concatenate :: [a -> a] -> a -> ([a],a) + concatenate fs acc = (tail values, last values) + where values = scanl' (flip ($)) acc fs + + mapAccumE :: s -> AST.Event AST.Expr (s -> (a,s)) -> AST.Event AST.Expr a + mapAccumE acc = fmap fst . AST.accumE (undefined,acc) . fmap (. snd) + +-- strict version of scanl +scanl' :: (a -> b -> a) -> a -> [b] -> [a] +scanl' f x ys = x : case ys of + [] -> [] + y:ys -> let z = f x y in z `seq` scanl' f z ys + +-- | Apply a time-varying function to a stream of events. +-- Think of it as +-- +-- > apply bf ex = [(time, bf time x) | (time, x) <- ex] +apply :: Behavior t (a -> b) -> Event t a -> Event t b +apply bf ex = E $ AST.applyE (map <$> unB bf) (unE ex) + +{-$classes + +/Further combinators that Haddock can't document properly./ + +> instance Monoid (Event t (a -> a)) + +This monoid instance is /not/ the straightforward instance +that you would obtain from 'never' and 'union'. +Instead of just merging event streams, we use 'unionWith' to compose +the functions. This is very useful in the context of 'accumE' and 'accumB' +where simultaneous event occurrences are best avoided. + +> instance Applicative (Behavior t) + +'Behavior' is an applicative functor. In particular, we have the following functions. + +> pure :: a -> Behavior t a + +The constant time-varying value. Think of it as @pure x = \\time -> x@. + +> (<*>) :: Behavior t (a -> b) -> Behavior t a -> Behavior t b + +Combine behaviors in applicative style. +Think of it as @bf \<*\> bx = \\time -> bf time $ bx time@. + +-} + +instance Monoid (Event t (a -> a)) where + mempty = never + mappend = unionWith (flip (.)) + +instance Functor (Event t) where + fmap f e = E $ (map f) <$> (unE e) + +instance Applicative (Behavior t) where + pure x = B $ AST.pureB x + bf <*> bx = B $ AST.applyB (unB bf) (unB bx) + +instance Functor (Behavior t) where + fmap = liftA + +{----------------------------------------------------------------------------- + Derived Combinators +------------------------------------------------------------------------------} +-- | Keep only the 'Just' values. +-- Variant of 'filterE'. +filterJust :: Event t (Maybe a) -> Event t a +filterJust = fmap (maybe err id) . filterE isJust + where err = error "Reactive.Banana.Model.filterJust: Internal error. :(" + +-- | Allow all events that fulfill the time-varying predicate, discard the rest. +-- Generalization of 'filterE'. +filterApply :: Behavior t (a -> Bool) -> Event t a -> Event t a +filterApply bp = fmap snd . filterE fst . apply ((\p a-> (p a,a)) <$> bp) + +-- | Allow events only when the behavior is 'True'. +-- Variant of 'filterApply'. +whenE :: Behavior t Bool -> Event t a -> Event t a +whenE bf = filterApply (const <$> bf) + +-- | Split event occurrences according to a tag. +split :: Event t (Either a b) -> (Event t a, Event t b) +split e = (filterJust $ fromLeft <$> e, filterJust $ fromRight <$> e) + where + fromLeft (Left a) = Just a + fromLeft (Right b) = Nothing + fromRight (Left a) = Nothing + fromright (Right b) = Just b + + +-- | Combine simultaneous event occurrences into a single occurrence. +-- +-- > unionWith f e1 e2 = fmap (foldr1 f) <$> collect (e1 `union` e2) +unionWith :: (a -> a -> a) -> Event t a -> Event t a -> Event t a +unionWith f e1 e2 = E $ AST.unionWith g (unE e1) (unE e2) + where g xs ys = singleton $ foldr1 f (xs ++ ys) + +-- | Keep only the last occurrence when simultaneous occurrences happen. +calm :: Event t a -> Event t a +calm = fmap last . collect + + + +-- $Accumulation. +-- Note: all accumulation functions are strict in the accumulated value! +-- acc -> (x,acc) is the order used by 'unfoldr' and 'State'. + +-- | The 'accumB' function is similar to a /strict/ left fold, 'foldl''. +-- It starts with an initial value and combines it with incoming events. +-- For example, think +-- +-- > accumB "x" [(time1,(++"y")),(time2,(++"z"))] +-- > = stepper "x" [(time1,"xy"),(time2,"xyz")] +-- +-- Note that the value of the behavior changes \"slightly after\" +-- the events occur. This allows for recursive definitions. +accumB :: a -> Event t (a -> a) -> Behavior t a +-- accumB x (Event e) = behavior $ AccumB x e +accumB acc = stepper acc . accumE acc + +-- | Efficient combination of 'accumE' and 'accumB'. +mapAccum :: acc -> Event t (acc -> (x,acc)) -> (Event t x, Behavior t acc) +mapAccum acc ef = (fst <$> e, stepper acc (snd <$> e)) + where e = accumE (undefined,acc) ((. snd) <$> ef) + + +infixl 4 <@>, <@ + +-- | Class for overloading the 'apply' function. +class (Functor f, Functor g) => Apply f g where + -- | Infix operation for the 'apply' function, similar to '<*>' + (<@>) :: f (a -> b) -> g a -> g b + -- | Convenience function, similar to '<*' + (<@) :: f a -> g b -> g a + + f <@ g = (const <$> f) <@> g + +instance Apply (Behavior t) (Event t) where + (<@>) = apply + + diff --git a/src/Reactive/Banana/Experimental/Calm.hs b/src/Reactive/Banana/Experimental/Calm.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Experimental/Calm.hs @@ -0,0 +1,131 @@ +{----------------------------------------------------------------------------- + Reactive Banana +------------------------------------------------------------------------------} +{-# LANGUAGE Rank2Types, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} + +module Reactive.Banana.Experimental.Calm ( + -- * Synopsis + -- | Experimental module: API change very likely. + -- + -- 'Event' type that disallows simultaneous event occurrences. + -- + -- The combinators behave essentially as their counterparts + -- in "Reactive.Banana.Combinators". + + -- * Main types + Event, Behavior, collect, fromCalm, + interpretModel, interpretPushGraph, + + -- * Core Combinators + module Control.Applicative, + never, unionWith, filterE, accumE, + apply, stepper, + -- $classes + + -- * Derived Combinators + -- ** Filtering + filterJust, + -- ** Accumulation + -- $Accumulation. + accumB, mapAccum, + -- ** Apply class + Reactive.Banana.Combinators.Apply(..), + ) where + +import Control.Applicative +import Control.Monad + +import Data.Maybe (listToMaybe) + +import qualified Reactive.Banana.Combinators as Prim +import qualified Reactive.Banana.Combinators + +{----------------------------------------------------------------------------- + Main types +------------------------------------------------------------------------------} +newtype Event t a = E { unE :: Prim.Event t a } + +type Behavior t = Reactive.Banana.Combinators.Behavior t + +-- | Convert event with possible simultaneous occurrences +-- into an 'Event' with a single occurrence. +collect :: Reactive.Banana.Combinators.Event t a -> Event t [a] +collect = E . Prim.collect + +-- | Convert event with single occurrences into +-- event with possible simultaneous occurrences +fromCalm :: Event t a -> Reactive.Banana.Combinators.Event t a +fromCalm = unE + +singleton x = [x] + +-- | Interpret with model implementation. +-- Useful for testing. +interpretModel :: (forall t. Event t a -> Event t b) -> [a] -> IO [Maybe b] +interpretModel f xs = + map listToMaybe <$> Prim.interpretModel (unE . f . E) (map singleton xs) + +-- | Interpret with push-based implementation. +-- Useful for testing. +interpretPushGraph :: (forall t. Event t a -> Event t b) -> [a] -> IO [Maybe b] +interpretPushGraph f xs = + map listToMaybe <$> Prim.interpretPushGraph (unE . f . E) (map singleton xs) + +{----------------------------------------------------------------------------- + Core Combinators +------------------------------------------------------------------------------} +-- | Event that never occurs. +-- Think of it as @never = []@. +never :: Event t a +never = E $ Prim.never + +-- | Merge two event streams of the same type. +-- Combine simultaneous values if necessary. +unionWith :: (a -> a -> a) -> Event t a -> Event t a -> Event t a +unionWith f e1 e2 = E $ Prim.unionWith f (unE e1) (unE e2) + +-- | Allow all events that fulfill the predicate, discard the rest. +filterE :: (a -> Bool) -> Event t a -> Event t a +filterE p = E . Prim.filterE p . unE + +-- | Construct a time-varying function from an initial value and +-- a stream of new values. +stepper :: a -> Event t a -> Behavior t a +stepper x e = Prim.stepper x (unE e) + +-- | The 'accumE' function accumulates a stream of events. +accumE :: a -> Event t (a -> a) -> Event t a +accumE acc = E . Prim.accumE acc . unE + +-- | Apply a time-varying function to a stream of events. +apply :: Behavior t (a -> b) -> Event t a -> Event t b +apply b = E . Prim.apply b . unE + +instance Functor (Event t) where + fmap f = E . fmap f . unE + +{----------------------------------------------------------------------------- + Derived Combinators +------------------------------------------------------------------------------} +-- | Keep only the 'Just' values. +-- Variant of 'filterE'. +filterJust :: Event t (Maybe a) -> Event t a +filterJust = E . Prim.filterJust . unE + +-- | The 'accumB' function is similar to a /strict/ left fold, 'foldl''. +-- It starts with an initial value and combines it with incoming events. +accumB :: a -> Event t (a -> a) -> Behavior t a +accumB acc = Prim.accumB acc . unE + +-- $Accumulation. +-- Note: all accumulation functions are strict in the accumulated value! +-- acc -> (x,acc) is the order used by 'unfoldr' and 'State'. + +-- | Efficient combination of 'accumE' and 'accumB'. +mapAccum :: acc -> Event t (acc -> (x,acc)) -> (Event t x, Behavior t acc) +mapAccum acc ef = let (e,b) = Prim.mapAccum acc (unE ef) in (E e, b) + +instance Reactive.Banana.Combinators.Apply (Behavior t) (Event t) where + (<@>) = apply + + diff --git a/src/Reactive/Banana/Frameworks.hs b/src/Reactive/Banana/Frameworks.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Frameworks.hs @@ -0,0 +1,403 @@ +{----------------------------------------------------------------------------- + Reactive Banana +------------------------------------------------------------------------------} +{-# LANGUAGE Rank2Types, DeriveDataTypeable #-} + +module Reactive.Banana.Frameworks ( + -- * Synopsis + -- | Build event networks using existing event-based frameworks and run them. + + -- * Simple use + interpret, interpretAsHandler, + + -- * Building event networks with input/output + -- $build + NetworkDescription, compile, + AddHandler, fromAddHandler, fromChanges, fromPoll, + reactimate, initial, changes, + liftIO, liftIOLater, + + -- * Running event networks + EventNetwork, actuate, pause, + + -- * Utilities + -- $utilities + newAddHandler, newEvent, + ) where + +import Control.Applicative +import Control.Arrow (second) +import Control.Concurrent +import Control.Monad +import Control.Monad.Fix (MonadFix(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.RWS + +import Data.Dynamic (Typeable) +import Data.IORef +import Data.List (nub) +import Data.Monoid + +import qualified Data.HashMap.Strict as Map + +import Reactive.Banana.Internal.InputOutput +import Reactive.Banana.Combinators +import qualified Reactive.Banana.Internal.AST as AST +import qualified Reactive.Banana.Internal.PushGraph as Implementation + +type Map = Map.HashMap + +{----------------------------------------------------------------------------- + AST specific functions +------------------------------------------------------------------------------} +inputE :: InputChannel [a] -> Event t a +inputE = E . AST.inputE + +{----------------------------------------------------------------------------- + NetworkDescription, setting up event networks +------------------------------------------------------------------------------} +{-$build + + After having read all about 'Event's and 'Behavior's, + you want to hook them up to an existing event-based framework, + like @wxHaskell@ or @Gtk2Hs@. + How do you do that? + + This "Reactive.Banana.Implementation" module allows you to obtain /input/ events + from external sources + and it allows you perform /output/ in reaction to events. + + In constrast, the functions from "Reactive.Banana.Model" allow you + to express the output events in terms of the input events. + This expression is called an /event graph/. + + An /event network/ is an event graph together with inputs and outputs. + To build an event network, + describe the inputs, outputs and event graph in the 'NetworkDescription' monad + and use the 'compile' function to obtain an event network from that. + + To /activate/ an event network, use the 'actuate' function. + The network will register its input event handlers and start producing output. + + A typical setup looks like this: + +> main = do +> -- initialize your GUI framework +> window <- newWindow +> ... +> +> -- describe the event network +> let networkDescription :: forall t. NetworkDescription t () +> networkDescription = do +> -- input: obtain Event from functions that register event handlers +> emouse <- fromAddHandler $ registerMouseEvent window +> ekeyboard <- fromAddHandler $ registerKeyEvent window +> -- input: obtain Behavior from changes +> btext <- fromChanges "" $ registerTextChange editBox +> -- input: obtain Behavior from mutable data by polling +> bdie <- fromPoll $ randomRIO (1,6) +> +> -- express event graph +> let +> behavior1 = accumB ... +> ... +> event15 = union event13 event14 +> +> -- output: animate some event occurences +> reactimate $ fmap print event15 +> reactimate $ fmap drawCircle eventCircle +> +> -- compile network description into a network +> network <- compile networkDescription +> -- register handlers and start producing outputs +> actuate network + + In short, you use 'fromAddHandler' to obtain /input/ events. + The library uses this to register event handlers + with your event-based framework. + + To animate /output/ events, use the 'reactimate' function. + +-} + +type AddHandler' = AddHandler InputValue +type Preparations t = + ( [Event t (IO ())] -- reactimate outputs + , [AddHandler'] -- fromAddHandler events + , [IO InputValue] -- fromPoll events + , [IO ()] -- liftIOLater + ) + +-- | Monad for describing event networks. +-- +-- The 'NetworkDescription' monad is an instance of 'MonadIO', +-- so 'IO' is allowed inside. +-- +-- Note: The phantom type @t@ prevents you from smuggling +-- values of types 'Event' or 'Behavior' +-- outside the 'NetworkDescription' monad. +newtype NetworkDescription t a + = Prepare { unPrepare :: RWST () (Preparations t) () IO a } + +instance Monad (NetworkDescription t) where + return = Prepare . return + m >>= k = Prepare $ unPrepare m >>= unPrepare . k +instance MonadIO (NetworkDescription t) where + liftIO = Prepare . liftIO +instance Functor (NetworkDescription t) where + fmap f = Prepare . fmap f . unPrepare +instance Applicative (NetworkDescription t) where + pure = Prepare . pure + f <*> a = Prepare $ unPrepare f <*> unPrepare a +instance MonadFix (NetworkDescription t) where + mfix f = Prepare $ mfix (unPrepare . f) + +{- | Output. + Execute the 'IO' action whenever the event occurs. + + + Note: If two events occur very close to each other, + there is no guarantee that the @reactimate@s for one + event will have finished before the ones for the next event start executing. + This does /not/ affect the values of events and behaviors, + it only means that the @reactimate@ for different events may interleave. + Fortuantely, this is a very rare occurrence, and only happens if + + * you call an event handler from inside 'reactimate', + + * or you use concurrency. + + In these cases, the @reactimate@s follow the control flow + of your event-based framework. + +-} +reactimate :: Event t (IO ()) -> NetworkDescription t () +reactimate e = Prepare $ tell ([e],[],[],[]) + +-- | A value of type @AddHandler a@ is just a facility for registering +-- callback functions, also known as event handlers. +-- +-- The type is a bit mysterious, it works like this: +-- +-- > do unregisterMyHandler <- addHandler myHandler +-- +-- The argument is an event handler that will be registered. +-- The return value is an action that unregisters this very event handler again. +type AddHandler a = (a -> IO ()) -> IO (IO ()) + +-- | Input, +-- obtain an 'Event' from an 'AddHandler'. +-- +-- When the event network is actuated, +-- this will register a callback function such that +-- an event will occur whenever the callback function is called. +fromAddHandler :: AddHandler a -> NetworkDescription t (Event t a) +fromAddHandler addHandler = Prepare $ do + i <- liftIO $ newInputChannel + let addHandler' k = addHandler $ k . toValue i . (\x -> [x]) + tell ([],[addHandler'],[],[]) + return $ inputE i + +-- | Input, +-- obtain a 'Behavior' by frequently polling mutable data, like the current time. +-- +-- The resulting 'Behavior' will be updated on whenever the event +-- network processes an input event. +-- +-- This function is occasionally useful, but +-- the recommended way to obtain 'Behaviors' is by using 'fromChanges'. +-- +-- Ideally, the argument IO action just polls a mutable variable, +-- it should not perform expensive computations. +-- Neither should its side effects affect the event network significantly. +fromPoll :: IO a -> NetworkDescription t (Behavior t a) +fromPoll poll = Prepare $ do + i <- liftIO $ newInputChannel + let poll' = toValue i . (:[]) <$> poll + tell ([],[],[poll'],[]) + initial <- liftIO $ poll + return $ stepper initial (inputE i) + +-- | Input, +-- obtain a 'Behavior' from an 'AddHandler' that notifies changes. +-- +-- This is essentially just an application of the 'stepper' combinator. +fromChanges :: a -> AddHandler a -> NetworkDescription t (Behavior t a) +fromChanges initial changes = stepper initial <$> fromAddHandler changes + +-- | Output, +-- observe when a 'Behavior' changes. +-- +-- Strictly speaking, a 'Behavior' denotes a value that varies *continuously* in time, +-- so there is no well-defined event which indicates when the behavior changes. +-- +-- Still, for reasons of efficiency, the library provides a way to observe +-- changes when the behavior is a step function, for instance as +-- created by 'stepper'. There are no formal guarantees, +-- but the idea is that +-- +-- > changes (stepper x e) = return (calm e) +changes :: Behavior t a -> NetworkDescription t (Event t a) +changes ~(B (AST.Pair _ (AST.Stepper x e))) = return $ E $ fmap (:[]) e + +-- | Output, +-- observe the initial value contained in a 'Behavior'. +-- +-- Similar to 'updates', this function is not well-defined, +-- but exists for reasons of efficiency. +initial :: Behavior t a -> NetworkDescription t a +initial ~(B (AST.Pair _ (AST.Stepper x e))) = return x + +-- | Lift an 'IO' action into the 'NetworkDescription' monad, +-- but defer its execution until compilation time. +-- This can be useful for recursive definitions using 'MonadFix'. +liftIOLater :: IO () -> NetworkDescription t () +liftIOLater m = Prepare $ tell ([],[],[],[m]) + +-- | Compile a 'NetworkDescription' into an 'EventNetwork' +-- that you can 'actuate', 'pause' and so on. +compile :: (forall t. NetworkDescription t ()) -> IO EventNetwork +compile (Prepare m) = do + -- execute the NetworkDescription monad + (_,_,(outputs,inputs,polls,liftIOs)) <- runRWST m () () + sequence_ liftIOs + + let -- union of all reactimates + E graph = foldr union never outputs + + automaton <- Implementation.compileToAutomaton graph + + -- allocate new variable for the automaton + rautomaton <- newEmptyMVar + putMVar rautomaton automaton + + let -- run the graph on a single input value + run :: InputValue -> IO () + run input = do + -- takeMVar makes sure that event graph updates are sequential. + automaton <- takeMVar rautomaton + -- poll mutable data + pollValues <- sequence polls + -- percolate inputs through event graph + (reactimates,automaton') <- runStep automaton $ input:pollValues + putMVar rautomaton automaton' + -- Run corresponding IO actions afterwards. + -- Under certain circumstances, they can *interleave*. + case reactimates of + Just actions -> sequence_ actions + Nothing -> return () + + -- register event handlers + register :: IO (IO ()) + register = fmap sequence_ . sequence . map ($ run) $ inputs + + makeEventNetwork register + + +{----------------------------------------------------------------------------- + Running event networks +------------------------------------------------------------------------------} +-- | Data type that represents a compiled event network. +-- It may be paused or already running. +data EventNetwork = EventNetwork { + -- | Actuate an event network. + -- The inputs will register their event handlers, so that + -- the networks starts to produce outputs in response to input events. + actuate :: IO (), + + -- | Pause an event network. + -- Immediately stop producing output and + -- unregister all event handlers for inputs. + -- Hence, the network stops responding to input events, + -- but it's state will be preserved. + -- + -- You can resume the network with 'actuate'. + -- + -- Note: You can stop a network even while it is processing events, + -- i.e. you can use 'pause' as an argument to 'reactimate'. + -- The network will /not/ stop immediately though, only after + -- the current event has been processed completely. + pause :: IO () + } deriving (Typeable) + +-- Make an event network from a function that registers all event handlers +makeEventNetwork :: IO (IO ()) -> IO EventNetwork +makeEventNetwork register = do + let nop = return () + unregister <- newIORef nop + let + actuate = register >>= writeIORef unregister + pause = readIORef unregister >>= id >> writeIORef unregister nop + return $ EventNetwork actuate pause + + +{----------------------------------------------------------------------------- + Simple use +------------------------------------------------------------------------------} +-- | Simple way to run an event graph. Very useful for testing. +-- Uses the efficient push-driven implementation. +interpret :: (forall t. Event t a -> Event t b) -> [a] -> IO [[b]] +interpret f xs = do + output <- newIORef [] + (addHandler, runHandlers) <- newAddHandler + network <- compile $ do + e <- fromAddHandler addHandler + reactimate $ fmap (\b -> modifyIORef output (++[b])) (f e) + + actuate network + bs <- forM xs $ \x -> do + runHandlers x + bs <- readIORef output + writeIORef output [] + return bs + return bs + +-- | Simple way to write a single event handler with functional reactive programming. +interpretAsHandler + :: (forall t. Event t a -> Event t b) + -> AddHandler a -> AddHandler b +interpretAsHandler f addHandlerA = \handlerB -> do + network <- compile $ do + e <- fromAddHandler addHandlerA + reactimate $ handlerB <$> f e + actuate network + return (pause network) + + +{----------------------------------------------------------------------------- + Utilities +------------------------------------------------------------------------------} +{-$utilities + + This section collects a few convenience functions + for unusual use cases. For instance: + + * The event-based framework you want to hook into is poorly designed + + * You have to write your own event loop and roll a little event framework + +-} + +-- | Build a facility to register and unregister event handlers. +newAddHandler :: IO (AddHandler a, a -> IO ()) +newAddHandler = do + handlers <- newIORef Map.empty + let addHandler k = do + key <- newUnique + modifyIORef handlers $ Map.insert key k + return $ modifyIORef handlers $ Map.delete key + runHandlers x = + mapM_ ($ x) . map snd . Map.toList =<< readIORef handlers + return (addHandler, runHandlers) + + +-- | Build an 'Event' together with an 'IO' action that can +-- fire occurrences of this event. Variant of 'newAddHandler'. +-- +-- This function is mainly useful for passing callback functions +-- inside a 'reactimate'. +newEvent :: NetworkDescription t (Event t a, a -> IO ()) +newEvent = do + (addHandler, fire) <- liftIO $ newAddHandler + e <- fromAddHandler addHandler + return (e,fire) diff --git a/src/Reactive/Banana/Implementation.hs b/src/Reactive/Banana/Implementation.hs deleted file mode 100644 --- a/src/Reactive/Banana/Implementation.hs +++ /dev/null @@ -1,371 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{----------------------------------------------------------------------------- - Reactive Banana - - Linking the push-based implementation to an event-based framework -------------------------------------------------------------------------------} -module Reactive.Banana.Implementation ( - -- * Synopsis - -- | Build event networks using existing event-based frameworks - -- and run them. - - -- * Simple use - PushIO, interpret, interpretAsHandler, - - -- * Building event networks with input/output - -- $build - NetworkDescription, compile, - AddHandler, fromAddHandler, fromPoll, reactimate, liftIO, liftIOLater, - - -- * Running event networks - EventNetwork, actuate, pause, - - -- * Utilities - -- $utilities - newAddHandler, - - module Data.Dynamic, -- remove this when bumping to 0.5 - ) where - -import Control.Applicative -import Control.Arrow (second) -import Control.Concurrent -import Control.Monad -import Control.Monad.Fix (MonadFix(..)) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.RWS - -import Data.Dynamic -import Data.IORef -import Data.List (nub) -import Data.Monoid -import qualified Data.Map as Map -import Data.Unique - -import Reactive.Banana.PushIO hiding (compile) -import qualified Reactive.Banana.PushIO as Implementation -import qualified Reactive.Banana.Model as Model - -{----------------------------------------------------------------------------- - PushIO specific functions -------------------------------------------------------------------------------} -type Flavor = Implementation.PushIO - -poll :: IO a -> Model.Behavior Flavor a -poll = behavior . Poll - -input :: Channel -> Key a -> Model.Event Flavor a -input c = event . Input c - -compileHandlers :: Model.Event Flavor (IO ()) -> IO [(Channel, Universe -> IO ())] -compileHandlers graph = do - -- compile event graph - let graph' = Implementation.unEvent graph - (paths1,cache) <- Implementation.compile (invalidRef, Reactimate graph') - - -- prepare threading the cache as state - rcache <- newEmptyMVar - putMVar rcache cache - let -- run a single path - run m = do - -- takeMVar makes sure that event graph updates are sequential. - cache <- takeMVar rcache - (reactimates,cache') <- runRun m cache - putMVar rcache cache' - -- However, the corresponding IO actions are run afterwards, - -- and under certain circumstances, they can *interleave*. - reactimates - - appendReactimates - :: [Universe -> Run (IO ())] - -> (Universe -> Run (IO ())) - appendReactimates ps x = do - reactimates <- sequence $ map ($ x) ps - return $ sequence_ reactimates - - paths2 = map (second $ (run .) . appendReactimates) $ groupByChannel paths1 - - return paths2 - - --- FIXME: make this faster -groupByChannel :: [(Channel, a)] -> [(Channel, [a])] -groupByChannel xs = [(i, [x | (j,x) <- xs, i == j]) | i <- channels] - where channels = nub . map fst $ xs - -{----------------------------------------------------------------------------- - NetworkDescription, setting up event networks -------------------------------------------------------------------------------} -{-$build - - After having read all about 'Event's and 'Behavior's, - you want to hook them up to an existing event-based framework, - like @wxHaskell@ or @Gtk2Hs@. - How do you do that? - - This "Reactive.Banana.Implementation" module allows you to obtain /input/ events - from external sources - and it allows you perform /output/ in reaction to events. - - In constrast, the functions from "Reactive.Banana.Model" allow you - to express the output events in terms of the input events. - This expression is called an /event graph/. - - An /event network/ is an event graph together with inputs and outputs. - To build an event network, - describe the inputs, outputs and event graph in the 'NetworkDescription' monad - and use the 'compile' function to obtain an event network from that. - - To /activate/ an event network, use the 'actuate' function. - The network will register its input event handlers and start producing output. - - A typical setup looks like this: - -> main = do -> -- initialize your GUI framework -> window <- newWindow -> ... -> -> -- build the event network -> network <- compile $ do -> -- input: obtain Event from functions that register event handlers -> emouse <- fromAddHandler $ registerMouseEvent window -> ekeyboard <- fromAddHandler $ registerKeyEvent window -> -- input: obtain Behavior from mutable data by polling -> btext <- fromPoll $ getTextValue editBox -> bdie <- fromPoll $ randomRIO (1,6) -> -> -- express event graph -> let -> behavior1 = accumB ... -> ... -> event15 = union event13 event14 -> -> -- output: animate some event occurences -> reactimate $ fmap print event15 -> reactimate $ fmap drawCircle eventCircle -> -> -- register handlers and start producing outputs -> actuate network - - In short, you use 'fromAddHandler' to obtain /input/ events. - The library uses this to register event handlers - with your event-based framework. - - To animate /output/ events, use the 'reactimate' function. - --} - -type AddHandler' = (Channel, AddHandler Universe) -type Preparations = ([Model.Event Flavor (IO ())], [AddHandler'], [IO ()]) - --- | Monad for describing event networks. --- --- The 'NetworkDescription' monad is an instance of 'MonadIO', --- so 'IO' is allowed inside. --- --- Note: It is forbidden to smuggle values of types 'Event' or 'Behavior' --- outside the 'NetworkDescription' monad. This shouldn't be possible by default, --- but you might get clever and use 'IORef' to circumvent this. --- Don't do that, it won't work and also has a 99,98% chance of --- destroying the earth by summoning time-traveling zygohistomorphisms. -newtype NetworkDescription a = Prepare { unPrepare :: RWST () Preparations Channel IO a } - -instance Monad (NetworkDescription) where - return = Prepare . return - m >>= k = Prepare $ unPrepare m >>= unPrepare . k -instance MonadIO (NetworkDescription) where - liftIO = Prepare . liftIO -instance Functor (NetworkDescription) where - fmap f = Prepare . fmap f . unPrepare -instance Applicative (NetworkDescription) where - pure = Prepare . pure - f <*> a = Prepare $ unPrepare f <*> unPrepare a -instance MonadFix (NetworkDescription) where - mfix f = Prepare $ mfix (unPrepare . f) - -{- | Output. - Execute the 'IO' action whenever the event occurs. - - - Note: If two events occur very close to each other, - there is no guarantee that the @reactimate@s for one - event will have finished before the ones for the next event start executing. - This does /not/ affect the values of events and behaviors, - it only means that the @reactimate@ for different events may interleave. - Fortuantely, this is a very rare occurrence, and only happens if - - * you call an event handler from inside 'reactimate', - - * or you use concurrency. - - In these cases, the @reactimate@s follow the control flow - of your event-based framework. - --} -reactimate :: Model.Event PushIO (IO ()) -> NetworkDescription () -reactimate e = Prepare $ tell ([e], [], []) - --- | A value of type @AddHandler a@ is just a facility for registering --- callback functions, also known as event handlers. --- --- The type is a bit mysterious, it works like this: --- --- > do unregisterMyHandler <- addHandler myHandler --- --- The argument is an event handler that will be registered. --- The return value is an action that unregisters this very event handler again. -type AddHandler a = (a -> IO ()) -> IO (IO ()) - --- | Input, --- obtain an 'Event' from an 'AddHandler'. --- --- When the event network is actuated, --- this will register a callback function such that --- an event will occur whenever the callback function is called. -fromAddHandler :: AddHandler a -> NetworkDescription (Model.Event PushIO a) -fromAddHandler addHandler = Prepare $ do - channel <- newChannel - key <- liftIO $ newUniverseKey - let addHandler' k = addHandler $ k . toUniverse key - tell ([], [(channel, addHandler')], []) - return $ input channel key - where - newChannel = do c <- get; put $! c+1; return c - --- | Input, --- obtain a 'Behavior' by polling mutable data, like mutable variables or GUI widgets. --- --- Ideally, the argument IO action just polls a mutable variable, --- it should not perform expensive computations. --- Neither should its side effects affect the event network significantly. --- --- Internally, the event network will take a snapshot of each mutable --- datum before processing an input event, so that the obtained behavior --- is well-defined. This snapshot is guaranteed to happen before --- any 'reactimate' is performed. The network may omit taking a snapshot altogether --- if the behavior is not needed. -fromPoll :: IO a -> NetworkDescription (Model.Behavior PushIO a) -fromPoll m = return $ poll m - --- | Lift an 'IO' action into the 'NetworkDescription' monad, --- but defer its execution until compilation time. --- This can be useful for recursive definitions using 'MonadFix'. -liftIOLater :: IO () -> NetworkDescription () -liftIOLater m = Prepare $ tell ([],[], [m]) - --- | Compile a 'NetworkDescription' into an 'EventNetwork' --- that you can 'actuate', 'pause' and so on. -compile :: NetworkDescription () -> IO EventNetwork -compile (Prepare m) = do - (_,_,(outputs,inputs,liftIOs)) <- runRWST m () 0 - sequence_ liftIOs - - let -- union of all reactimates - graph = mconcat outputs :: Model.Event Flavor (IO ()) - paths <- compileHandlers graph - - let -- register event handlers - register = fmap sequence_ . sequence . map snd . applyChannels inputs - $ paths - makeEventNetwork register - --- FIXME: make this faster -applyChannels :: [(Channel, a -> b)] -> [(Channel, a)] -> [(Channel, b)] -applyChannels fs xs = - [(i, f x) | (i,f) <- fs, (j,x) <- xs, i == j] - -{----------------------------------------------------------------------------- - Running event networks -------------------------------------------------------------------------------} --- | Data type that represents a compiled event network. --- It may be paused or already running. -data EventNetwork = EventNetwork { - -- | Actuate an event network. - -- The inputs will register their event handlers, so that - -- the networks starts to produce outputs in response to input events. - actuate :: IO (), - - -- | Pause an event network. - -- Immediately stop producing output and - -- unregister all event handlers for inputs. - -- Hence, the network stops responding to input events, - -- but it's state will be preserved. - -- - -- You can resume the network with 'actuate'. - -- - -- Note: You can stop a network even while it is processing events, - -- i.e. you can use 'pause' as an argument to 'reactimate'. - -- The network will /not/ stop immediately though, only after - -- the current event has been processed completely. - pause :: IO () - } deriving (Typeable) - --- Make an event network from a function that registers all event handlers -makeEventNetwork :: IO (IO ()) -> IO EventNetwork -makeEventNetwork register = do - let nop = return () - unregister <- newIORef nop - let - actuate = register >>= writeIORef unregister - pause = readIORef unregister >>= id >> writeIORef unregister nop - return $ EventNetwork actuate pause - - -{----------------------------------------------------------------------------- - Simple use -------------------------------------------------------------------------------} --- | Simple way to run an event graph. Very useful for testing. -interpret :: (Model.Event PushIO a -> Model.Event PushIO b) -> [a] -> IO [[b]] -interpret f xs = do - output <- newIORef [] - (addHandler, runHandlers) <- newAddHandler - network <- compile $ do - e <- fromAddHandler addHandler - reactimate $ fmap (\b -> modifyIORef output (++[b])) (f e) - - actuate network - bs <- forM xs $ \x -> do - runHandlers x - bs <- readIORef output - writeIORef output [] - return bs - return bs - --- | Simple way to write a single event handler with functional reactive programming. -interpretAsHandler - :: (Model.Event PushIO a -> Model.Event PushIO b) - -> AddHandler a -> AddHandler b -interpretAsHandler f addHandlerA = \handlerB -> do - network <- compile $ do - e <- fromAddHandler addHandlerA - reactimate $ handlerB <$> f e - actuate network - return (pause network) - -{----------------------------------------------------------------------------- - Utilities -------------------------------------------------------------------------------} -{-$utilities - - This section collects a few convenience functions - for unusual use cases. For instance: - - * The event-based framework you want to hook into is poorly designed - - * You have to write your own event loop and roll a little event framework - --} - --- | Build a facility to register and unregister event handlers. -newAddHandler :: IO (AddHandler a, a -> IO ()) -newAddHandler = do - handlers <- newIORef Map.empty - let addHandler k = do - key <- newUnique - modifyIORef handlers $ Map.insert key k - return $ modifyIORef handlers $ Map.delete key - runHandlers x = - mapM_ ($ x) . map snd . Map.toList =<< readIORef handlers - return (addHandler, runHandlers) - diff --git a/src/Reactive/Banana/Incremental.hs b/src/Reactive/Banana/Incremental.hs deleted file mode 100644 --- a/src/Reactive/Banana/Incremental.hs +++ /dev/null @@ -1,118 +0,0 @@ -{----------------------------------------------------------------------------- - Reactive Banana - - Derived data type, a hybrid between Event and Behavior -------------------------------------------------------------------------------} -{-# LANGUAGE MultiParamTypeClasses #-} -module Reactive.Banana.Incremental ( - -- * Why a third type Discrete? - -- $discrete - - -- * Discrete time-varying values - Discrete, initial, changes, value, stepperD, - accumD, applyD, - ) where - -import Control.Applicative -import Reactive.Banana.Model - -{----------------------------------------------------------------------------- - Data Type -------------------------------------------------------------------------------} -{-$discrete - -In an ideal world, users of functional reactive programming would -only need to use the notions of 'Behavior' and 'Event', -the first corresponding to value that vary in time -and the second corresponding to a stream of event ocurrences. - -However, there is the problem of /incremental updates/. -Ideally, users would describe, say, the value of a GUI text field -as a 'Behavior' and the reactive-banana implementation would figure -out how to map this onto the screen without needless redrawing. -In other words, the screen should only be updated when the behavior changes. - -While this would be easy to implement in simple cases, -it may not always suit the user; -there are many different ways of implementing -/incremental computations/. -But I don't know a unified theory for them, so -I have decided that the reactive-banana will give -/explicit control over updates to the user/ -in the form of specialized data types like 'Discrete', -and shall not attempt to bake experimental optimizations into the 'Behavior' type. - -To sum it up: - -* You get explicit control over updates (the 'changes' function), - -* but you need to learn a third data type 'Discrete', -which almost duplicates the 'Behavior' type. - -* Even though the type 'Behavior' is more fundamental, -you will probably use 'Discrete' more often. - -That said, 'Discrete' is not a new primitive type, -but built from exising types and combinators; -you are encouraged to look at the source code. - -If you are an FRP implementor, I encourage you to find a better solution. -But if you are a user, you may want to accept the trade-off for now. - --} - --- | Like 'Behavior', the type 'Discrete' denotes a value that varies in time. --- However, unlike 'Behavior', --- it also provides a stream of events that indicate when the value has changed. --- In other words, we can now observe updates. -data Discrete f a = D { - -- | Initial value. - initial :: a, - -- | Event that records when the value changes. - -- Simultaneous events may be pruned for efficiency reasons. - changes :: Event f a, - -- | Behavior corresponding to the value. It is always true that - -- - -- > value x = stepper (initial x) (changes x) - value :: Behavior f a - } - --- | Construct a discrete time-varying value from an initial value and --- a stream of new values. -stepperD :: FRP f => a -> Event f a -> Discrete f a -stepperD x e = D { initial = x, changes = calm e, value = stepper x e} - where - -- in case of simultaneous occurence: keep only the last event? - calm = id - --- | Accumulate a stream of events into a discrete time-varying value. -accumD :: FRP f => a -> Event f (a -> a) -> Discrete f a -accumD x = stepperD x . accumE x - --- | Apply a discrete time-varying value to a stream of events. --- --- > applyD = apply . value -applyD :: FRP f => Discrete f (a -> b) -> Event f a -> Event f b -applyD = apply . value - --- | Overloading 'applyD' -instance FRP f => Apply (Discrete f) (Event f) where - (<@>) = applyD - --- | Functor instance -instance FRP f => Functor (Discrete f) where - fmap f r = stepperD (f $ initial r) $ fmap f (changes r) - --- | Applicative instance -instance FRP f => Applicative (Discrete f) where - pure x = D { initial = x, changes = never, value = pure x } - df <*> dx = stepperD b e - where - b = initial df $ initial dx - e = uncurry ($) <$> pairs - pairs = accumE (initial df, initial dx) $ - (left <$> changes df) `union` (right <$> changes dx) - - left f (_,x) = (f,x) - right x (f,_) = (f,x) - diff --git a/src/Reactive/Banana/Internal/AST.hs b/src/Reactive/Banana/Internal/AST.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Internal/AST.hs @@ -0,0 +1,222 @@ +{----------------------------------------------------------------------------- + Reactive-Banana +------------------------------------------------------------------------------} +{-# LANGUAGE GADTs, TypeFamilies, TupleSections, EmptyDataDecls, + TypeSynonymInstances, FlexibleInstances #-} + +module Reactive.Banana.Internal.AST where +-- Abstract syntax tree and assorted data types. + +import Control.Applicative +import qualified Data.Vault as Vault +import System.IO.Unsafe + +import Data.Hashable + +import Reactive.Banana.Internal.InputOutput + +{----------------------------------------------------------------------------- + Abstract syntax tree +------------------------------------------------------------------------------} +-- Type families allow us to support multiple tags in the AST +type family Event t :: * -> * +type family Behavior t :: * -> * + +-- | Constructors for events. +data EventD t :: * -> * where + Never :: EventD t a + UnionWith :: (a -> a -> a) -> Event t a -> Event t a -> EventD t a + FilterE :: (a -> Bool) -> Event t a -> EventD t a + ApplyE :: Behavior t (a -> b) -> Event t a -> EventD t b + AccumE :: a -> Event t (a -> a) -> EventD t a + + InputE :: InputChannel a -> EventD t a -- represent external inputs + InputPure :: InputChannel (EventModel a) + -> EventD t a -- input for model implementation + +-- | Constructors for behaviors. +data BehaviorD t :: * -> * where + Stepper :: a -> Event t a -> BehaviorD t a + + InputB :: InputChannel a -> BehaviorD t a -- represent external inputs + +{----------------------------------------------------------------------------- + Observable sharing + + Each constructor is paired with a @Node@ value. + The @Node@ serves as a unique identifier and stores various keys + into various vaults. +------------------------------------------------------------------------------} +data Pair f g a = Pair !(f a) (g a) + +fstPair :: Pair f g a -> f a +fstPair (Pair x y) = x + +-- | Type index indicating expressions with observable sharing +data Expr +type instance Event Expr = Pair Node (EventD Expr) +type instance Behavior Expr = Pair Node (BehaviorD Expr) + +-- smart constructor that handles observable sharing +shareE :: EventD Expr a -> Event Expr a +shareE e = pair + where + {-# NOINLINE pair #-} + -- mention argument to prevent let-floating + pair = unsafePerformIO (fmap (flip Pair e) newNode) + +shareB :: BehaviorD Expr a -> Behavior Expr a +shareB b = pair + where + {-# NOINLINE pair #-} + pair = unsafePerformIO (fmap (flip Pair b) newNode) + +{----------------------------------------------------------------------------- + Smart constructors and class instances +------------------------------------------------------------------------------} +unE = id; unB = id + +{- Note: +There is a fundamental problem with using Unique's for observable sharing. + +The problem is the following: + + module Test where .. + module Implementation where never = sharedE $ Never + module Data.Unique + +Imagine that the Test module contains an expression that contains sharing. +The never value contains a constant Unique , which is evaluated as +soon as you evaluate Test.expression . +Now, reload the Test module. This will reset the counter for Data.Unique, +but it will *not* reset the Unique that is already contained in never , +because the CAF never itself will not be reset. This invariably leads to +a Unique being reused, leading to a program crash. + +We solve the problem in Reactive.Banana.InputOutput +by using a better implementation of Unique . + +-} +{- Note: + +Another good reason for not sharing `never` is that +it is *polymorphic*. The shared value may be instantiated to different types, +which is really bad. + +-} +never = shareE $ Never + +unionWith f e1 e2 = shareE $ UnionWith f (unE e1) (unE e2) +filterE p e = shareE $ FilterE p (unE e) +applyE b e = shareE $ ApplyE (unB b) (unE e) +accumE acc e = shareE $ AccumE acc (unE e) +inputE i = shareE $ InputE i +inputPure i = shareE $ InputPure i + +stepperB acc e = shareB $ Stepper acc (unE e) +inputB i = shareB $ InputB i + +mapE f = applyE (pureB f) +pureB x = stepperB x never + +applyB :: Behavior Expr (a -> b) -> Behavior Expr a -> Behavior Expr b +applyB (Pair _ (Stepper f fe)) (Pair _ (Stepper x xe)) = + stepperB (f x) $ mapE (uncurry ($)) pair + where + pair = accumE (f,x) $ unionWith (.) (mapE changeL fe) (mapE changeR xe) + changeL f (_,x) = (f,x) + changeR x (f,_) = (f,x) +applyB _ _ = error "TODO: Don't know what to do with external behaviors." + +-- instance Functor (Event Expr) where +instance Functor (Pair Node (EventD Expr)) where + fmap = mapE +-- instance Functor (Behavior Expr) where +instance Functor (Pair Node (BehaviorD Expr)) where + fmap f = applyB (pureB f) + +{----------------------------------------------------------------------------- + The 'Node' type is used for observable sharing and must be defined here. +------------------------------------------------------------------------------} +-- | A 'Node' represents a unique identifier for an expression. +-- It actually contains keys for various 'Vault'. +-- +-- TODO: Make a special case for the 'Never' constructor, +-- which cannot be shared. +data Node a + = Node + { -- use for Reactive.Banana.Internal.PushGraph + keyValue :: !(Vault.Key a) + , keyFormula :: !(Vault.Key (FormulaD Nodes a)) + , keyOrder :: !Unique + -- use for Reactive.Banana.Internal.Model + , keyModelE :: !(Vault.Key (EventModel a)) + , keyModelB :: !(Vault.Key (BehaviorModel a)) + } + +newNode :: IO (Node a) +newNode = Node + <$> Vault.newKey <*> Vault.newKey <*> newUnique + <*> Vault.newKey <*> Vault.newKey + +{----------------------------------------------------------------------------- + Reactive.Banana.Internal.Model +------------------------------------------------------------------------------} +-- we have to define the interpretation types here +type EventModel a = [Maybe a] +data BehaviorModel a = StepperB a (EventModel a) + +{----------------------------------------------------------------------------- + Reactive.Banana.Internal.PushGraph +------------------------------------------------------------------------------} +data Nodes +type instance Event Nodes = Node +type instance Behavior Nodes = Node + +-- | Formula that represents events and behaviors as one entity +data FormulaD t a where + E :: EventD t a -> FormulaD t a + B :: BehaviorD t a -> FormulaD t a + +caseFormula :: (EventD t a -> c) -> (BehaviorD t a -> c) -> FormulaD t a -> c +caseFormula e b (E x) = e x +caseFormula e b (B x) = b x + +type family Formula t :: * -> * +type instance Formula Expr = Pair Node (FormulaD Expr) +type instance Formula Nodes = Node + +-- Helper class for embedding polymorphically in the type index +class ToFormula t where + -- e :: Event t a -> Formula t a + -- b :: Behavior t a -> Formula t a + + ee :: Event t a -> SomeFormula t + bb :: Behavior t a -> SomeFormula t + +instance ToFormula Expr where + ee (Pair node e1) = Exists (Pair node $ E e1) + bb (Pair node b1) = Exists (Pair node $ B b1) + +instance ToFormula Nodes where + ee node = Exists node + bb node = Exists node + + +-- | Formula, existentially quantified over the result type +data SomeFormula t where + Exists :: Formula t a -> SomeFormula t +type SomeNode = SomeFormula Nodes + +-- instances to store SomeNode in efficient maps +instance Eq SomeNode where + (Exists x) == (Exists y) = (keyOrder x) == (keyOrder y) +instance Hashable SomeNode where + hash (Exists x) = hash (keyOrder x) + +instance Eq (SomeFormula Expr) where + (Exists (Pair x _)) == (Exists (Pair y _)) = (keyOrder x) == (keyOrder y) +instance Hashable (SomeFormula Expr) where + hash (Exists (Pair x _)) = hash (keyOrder x) + + diff --git a/src/Reactive/Banana/Internal/InputOutput.hs b/src/Reactive/Banana/Internal/InputOutput.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Internal/InputOutput.hs @@ -0,0 +1,91 @@ +{----------------------------------------------------------------------------- + Reactive Banana +------------------------------------------------------------------------------} +module Reactive.Banana.Internal.InputOutput ( + -- * Synopsis + -- | Manage the input and output of event graphs. + + -- * Input + -- | Utilities for managing heterogenous input values. + Channel, InputChannel, InputValue, + + newInputChannel, getChannel, + fromValue, toValue, + + -- * Output + -- | Stepwise execution of an event graph. + Automaton(..), fromStateful, unfoldAutomaton, + + -- * Uniques + -- | Doesn't belong here, but we also have some stuff about uniques + -- that we use for observable sharing. + Unique, newUnique, + ) where + +import Control.Applicative +import Control.Exception (evaluate) + +import qualified Data.Unique as Unique +import qualified Data.Vault as Vault +import Data.Hashable +import System.Mem.StableName + +{----------------------------------------------------------------------------- + Better Uniques +------------------------------------------------------------------------------} +type ReallyUnique = StableName Unique.Unique +type Unique = ReallyUnique + +-- instance Hashable Unique + +newUnique :: IO Unique +newUnique = do + x <- Unique.newUnique + evaluate x + makeStableName x + +{----------------------------------------------------------------------------- + Storing heterogenous input values +------------------------------------------------------------------------------} +type Channel = ReallyUnique -- identifies an input +type Key = Vault.Key -- key to retrieve a value +type Value = Vault.Vault -- value storage + +data InputChannel a = InputChannel { getChannelC :: Channel, getKey :: Key a } +data InputValue = InputValue { getChannelV :: Channel, getValue :: Value } + +newInputChannel :: IO (InputChannel a) +newInputChannel = InputChannel <$> newUnique <*> Vault.newKey + +fromValue :: InputChannel a -> InputValue -> Maybe a +fromValue i v = Vault.lookup (getKey i) (getValue v) + +toValue :: InputChannel a -> a -> InputValue +toValue i a = InputValue (getChannelC i) $ Vault.insert (getKey i) a Vault.empty + +-- convenience class for overloading +class HasChannel a where + getChannel :: a -> Channel +instance HasChannel (InputChannel a) where getChannel = getChannelC +instance HasChannel (InputValue) where getChannel = getChannelV + + +{----------------------------------------------------------------------------- + Stepwise execution +------------------------------------------------------------------------------} +-- Automaton that takes input values and produces a result +data Automaton a = Step { runStep :: [InputValue] -> IO (Maybe a, Automaton a) } + +fromStateful :: ([InputValue] -> s -> IO (Maybe a,s)) -> s -> Automaton a +fromStateful f s = Step $ \i -> do + (a,s') <- f i s + return (a, fromStateful f s') + +-- | Apply an automaton to a list of input values +unfoldAutomaton :: Automaton b -> InputChannel a -> [a] -> IO [Maybe b] +unfoldAutomaton _ _ [] = return [] +unfoldAutomaton auto i (x:xs) = do + (b, auto) <- runStep auto $ [toValue i x] + bs <- unfoldAutomaton auto i xs + return (b:bs) + diff --git a/src/Reactive/Banana/Internal/Model.hs b/src/Reactive/Banana/Internal/Model.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Internal/Model.hs @@ -0,0 +1,141 @@ +{----------------------------------------------------------------------------- + Reactive-Banana +------------------------------------------------------------------------------} +{-# LANGUAGE GADTs #-} +module Reactive.Banana.Internal.Model ( + -- * Synopsis + -- | Model implementation of the abstract syntax tree. + + -- * Description + -- $model + + -- Combinators + -- Event(..), Behavior(..), + -- never, filterE, unionWith, applyE, accumE, stepper, + + -- * Interpretation + interpretModel, + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Trans.State +import qualified Data.Vault as Vault + +import qualified Reactive.Banana.Internal.AST as AST +import Reactive.Banana.Internal.InputOutput + +{-$model + +This module contains the model implementation for the primitive combinators +defined "Reactive.Banana.Internal.AST" +which in turn are the basis for the official combinators +documented in "Reactive.Banana.Combinators". + +This module does not export any combinators, +you have to look at the source code to make use of it. +(If there is no link to the source code at every type signature, +then you have to run cabal with --hyperlink-source flag.) + +This model is /authoritative/: when observed with the 'interpretModel' function, +both the actual implementation and its model /must/ agree on the result. +Note that this must also hold for recursive and partial definitions +(at least in spirit, I'm not going to split hairs over @_|_@ vs @\\_ -> _|_@). + +Concerning time and space complexity, the model is not authoritative, however. +Implementations are free to be much more efficient. +-} + +{----------------------------------------------------------------------------- + Combinators +------------------------------------------------------------------------------} +-- due to observable sharing, the types have to be imported from +-- the module Reactive.Banana.Internal.AST +type Event a = AST.EventModel a -- = [Maybe a] +type Behavior a = AST.BehaviorModel a -- = StepperB a (Event a) + +never :: Event a +never = repeat Nothing + +filterE :: (a -> Bool) -> Event a -> Event a +filterE p = map (>>= \x -> if p x then Just x else Nothing) + +unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a +unionWith f = zipWith g + where + g (Just x) (Just y) = Just $ f x y + g (Just x) Nothing = Just x + g Nothing (Just y) = Just y + g Nothing Nothing = Nothing + +applyE :: Behavior (a -> b) -> Event a -> Event b +applyE _ [] = [] +applyE (AST.StepperB f fe) (x:xs) = fmap f x : applyE (step f fe) xs + where + step a (Nothing:b) = stepper a b + step _ (Just a :b) = stepper a b + +accumE :: a -> Event (a -> a) -> Event a +accumE x [] = [] +accumE x (Nothing:fs) = Nothing : accumE x fs +accumE x (Just f :fs) = let y = f x in y `seq` (Just y:accumE y fs) + +stepper :: a -> [Maybe a] -> Behavior a +stepper = AST.StepperB + +{----------------------------------------------------------------------------- + Interpretation, pays attention to observable sharing +------------------------------------------------------------------------------} +-- state monad for evaluation +type Eval = State Vault.Vault + +-- | Interpret an event graph with the model implementation. +-- Mainly useful for testing library internals. +interpretModel + :: (AST.Event AST.Expr a -> AST.Event AST.Expr b) + -> Event a -> IO (Event b) +interpretModel f input = do + i0 <- newInputChannel + + let + evalE :: AST.EventD AST.Expr a -> Eval (Event a) + evalE (AST.Never) = return $ never + evalE (AST.UnionWith f e1 e2) = unionWith f <$> goE e1 <*> goE e2 + evalE (AST.FilterE p e) = filterE p <$> goE e + evalE (AST.ApplyE b e ) = applyE <$> goB b <*> goE e + evalE (AST.AccumE x e ) = accumE x <$> goE e + evalE (AST.InputPure i) = + return $ maybe err id $ fromValue i (toValue i0 input) + where err = error "Reactive.Banana.PushIO.interpretModel: internal error: Input" + evalE _ = + error "Reactive.Banana.PushIO.interpretModel: internal error: E" + + evalB :: AST.BehaviorD AST.Expr a -> Eval (Behavior a) + evalB (AST.Stepper x e) = stepper x <$> goE e + evalB _ = + error "Reactive.Banana.PushIO.interpretModel: internal error: B" + + goE :: AST.Event AST.Expr a -> Eval (Event a) + goE (AST.Pair node e) = do + values <- get + case Vault.lookup (AST.keyModelE node) values of + Nothing -> mfix $ \v -> do + modify $ Vault.insert (AST.keyModelE node) v + evalE e + Just v -> return v + + goB :: AST.Behavior AST.Expr a -> Eval (Behavior a) + goB (AST.Pair node b) = do + values <- get + case Vault.lookup (AST.keyModelB node) values of + Nothing -> mfix $ \v -> do + modify $ Vault.insert (AST.keyModelB node) v + evalB b + Just v -> return v + + return $ + zipWith const + (evalState (goE $ f $ AST.inputPure i0) Vault.empty) + input + diff --git a/src/Reactive/Banana/Internal/PushGraph.hs b/src/Reactive/Banana/Internal/PushGraph.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Internal/PushGraph.hs @@ -0,0 +1,410 @@ +{----------------------------------------------------------------------------- + Reactive-Banana +------------------------------------------------------------------------------} +{-# LANGUAGE GADTs, TypeFamilies, RankNTypes, TypeOperators, + TypeSynonymInstances, FlexibleInstances, + ScopedTypeVariables #-} + +module Reactive.Banana.Internal.PushGraph ( + -- * Synopsis + -- | Push-driven implementation. + + compileToAutomaton + ) where + +import Control.Applicative +import Control.Arrow (first) +import Control.Category +import Prelude hiding ((.),id) + +import Data.Label +import Data.Maybe +import Data.Monoid (Dual, Endo, Monoid(..)) +import qualified Data.Vault as Vault + +import Data.Hashable +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set + +import Reactive.Banana.Internal.AST +import Reactive.Banana.Internal.InputOutput +import Reactive.Banana.Internal.TotalOrder as TotalOrder + +import Debug.Trace + +type Map = Map.HashMap +type Set = Set.HashSet + +{----------------------------------------------------------------------------- + Representation of the dependency graph + and associated lenses +------------------------------------------------------------------------------} +-- Dependency graph +data Graph b + = Graph + { grFormulas :: Formulas -- formulas for calculation + , grChildren :: Map SomeNode [SomeNode] -- reverse dependencies + , grEvalOrder :: EvalOrder -- evaluation order + , grOutput :: Node b -- root node + , grInputs :: Inputs -- input dispatcher + } +type Formulas = Vault.Vault -- mapping from nodes to formulas +type EvalOrder = TotalOrder SomeNode -- evaluation order +type Values = Vault.Vault -- current event values +type Inputs = Map Channel [SomeNode] -- mapping from input channels to nodes + +-- | Turn a 'Vault.Key' into a lens for the vault +vaultLens :: Vault.Key a -> (Vault.Vault :-> Maybe a) +vaultLens key = lens (Vault.lookup key) (adjust) + where + adjust Nothing = Vault.delete key + adjust (Just x) = Vault.insert key x + +-- | Formula used to calculate the value at a node. +formula :: Node a -> (Graph b :-> Maybe (FormulaD Nodes a)) +formula node = vaultLens (keyFormula node) . formulaLens + where formulaLens = lens grFormulas (\x g -> g { grFormulas = x}) + +-- | All nodes that directly depend on this one via the formula. +children :: Node a -> (Graph b :-> [SomeNode]) +children node = lens (Map.lookupDefault [] (Exists node) . grChildren) + (error "TODO: can't set children yet") + +-- | Current value for a node. +value :: Node a -> (Values :-> Maybe a) +value node = vaultLens (keyValue node) + +{----------------------------------------------------------------------------- + Operations specific to the DSL +------------------------------------------------------------------------------} +-- | Extract the dependencies of a node from its formula. +-- (boilerplate) +dependencies :: ToFormula t => FormulaD t a -> [SomeFormula t] +dependencies = caseFormula goE goB + where + goE :: ToFormula t => EventD t a -> [SomeFormula t] + goE (Never) = [] + goE (UnionWith f e1 e2) = [ee e1,ee e2] + goE (FilterE _ e1) = [ee e1] + goE (ApplyE b1 e1) = [bb b1, ee e1] + goE (AccumE _ e1) = [ee e1] + goE _ = [] + + goB :: ToFormula t => BehaviorD t a -> [SomeFormula t] + goB (Stepper x e1) = [ee e1] + goB _ = [] + +-- | Nodes whose *current* values are needed to calculate +-- the current value of the given node. +-- (boilerplate) +dependenciesEval :: ToFormula t => FormulaD t a -> [SomeFormula t] +dependenciesEval (E (ApplyE b e)) = [ee e] +dependenciesEval formula = dependencies formula + +-- | Replace expressions by nodes. +-- (boilerplate) +toFormulaNodes :: FormulaD Expr a -> FormulaD Nodes a +toFormulaNodes = caseFormula (E . goE) (B . goB) + where + node :: Pair Node f a -> Node a + node = fstPair + + goE :: forall a. EventD Expr a -> EventD Nodes a + goE (Never) = Never + goE (UnionWith f e1 e2) = UnionWith f (node e1) (node e2) + goE (FilterE p e) = FilterE p (node e) + goE (ApplyE b e) = ApplyE (node b) (node e) + goE (AccumE x e) = AccumE x (node e) + goE (InputE x) = InputE x + + goB :: BehaviorD Expr a -> BehaviorD Nodes a + goB (Stepper x e) = Stepper x (node e) + goB (InputB x) = InputB x + + +-- Evaluation + +-- | Evaluate the current value of a given event expression. +calculateE + :: forall a b. + (forall e. Node e -> Maybe e) -- retrieve current event values + -> (forall b. Node b -> b) -- retrieve old behavior values + -> Node a -- node ID + -> EventD Nodes a -- formula to evaluate + -> ( Maybe a -- current event value + , Graph b -> Graph b) -- (maybe) change formulas in the graph +calculateE valueE valueB node = + maybe (Nothing,id) (\(x,f) -> (Just x, f)) . goE + where + goE :: EventD Nodes a -> Maybe (a, Graph b -> Graph b) + goE (Never) = nothing + goE (UnionWith f e1 e2) = case (valueE e1, valueE e2) of + (Just e1, Just e2) -> just $ f e1 e2 + (Just e1, Nothing) -> just e1 + (Nothing, Just e2) -> just e2 + (Nothing, Nothing) -> nothing + goE (FilterE p e) = valueE e >>= + \e -> if p e then just e else nothing + goE (ApplyE b e) = (just . (valueB b $)) =<< valueE e + goE (AccumE x e) = case valueE e of + Nothing -> just x + Just f -> let y = f x in + Just (y, set (formula node) . Just $ E (AccumE y e)) + goE (InputE _) = -- input values can be retrieved by node + just =<< valueE node + +just x = Just (x, id) +nothing = Nothing + +-- | Evalute the new value of a given behavior expression +calculateB + :: forall a b. + (forall e. Node e -> Maybe e) -- retrieve current event values + -> Node a -- node ID + -> BehaviorD Nodes a -- formula to evaluate + -> Graph b -> Graph b -- (maybe) change formulas in the graph +calculateB valueE node = maybe id id . goB + where + goB :: BehaviorD Nodes a -> Maybe (Graph b -> Graph b) + goB (Stepper x e) = + (\y -> set (formula node) $ Just $ B (Stepper y e)) <$> valueE e + goB (InputB x) = error "TODO" + + +{----------------------------------------------------------------------------- + Building the dependency graph +------------------------------------------------------------------------------} +-- | Build full graph from an expression. +buildGraph :: Formula Expr b -> Graph b +buildGraph expr = graph + where + graph = Graph + { grFormulas = grFormulas + , grChildren = buildChildren (Exists root) grFormulas + , grEvalOrder = buildEvalOrder graph + , grOutput = root + , grInputs = buildInputs (Exists root) grFormulas + } + grFormulas = buildFormulas (Exists expr) + root = fstPair expr + +-- | Build a graph of formulas from an expression +buildFormulas :: SomeFormula Expr -> Formulas +buildFormulas expr = + unfoldGraphDFSWith leftComposition f expr $ Vault.empty + where + f (Exists (Pair node formula)) = + ( \formulas -> Vault.insert (keyFormula node) formula' formulas + , dependencies formula ) + where + formula' = toFormulaNodes formula + +-- | Build reverse dependencies, starting from one node. +buildChildren :: SomeNode -> Formulas -> Map SomeNode [SomeNode] +buildChildren root formulas = + unfoldGraphDFSWith leftComposition f root $ Map.empty + where + f (Exists node) = (addChild deps, deps) + where + addChild = concatenate . map (\node -> Map.insertWith (++) node [child]) + child = Exists node :: SomeNode + Just formula' = getFormula' node formulas + deps = dependencies formula' + +getFormula' node formulas = Vault.lookup (keyFormula node) formulas + +concatenate :: [a -> a] -> (a -> a) +concatenate = foldr (.) id + +-- | Start at some node and update the evaluation order of +-- the node and all of its dependencies. +updateEvalOrder :: SomeNode -> Formulas -> EvalOrder -> EvalOrder +updateEvalOrder = error "TODO" + +-- | Build evaluation order from scratch +-- = topological sort +buildEvalOrder :: Graph a -> EvalOrder +buildEvalOrder graph = + -- we have to build an evaluation order for the root node + -- and for all the dependencies of a behavior + TotalOrder.fromAscList $ + concatMap (\x -> unfoldGraphDFSWith leftComposition f x []) + (root:findBehaviors) + where + root = Exists $ grOutput graph + f (Exists node) = ((Exists node:), dependenciesEval formula') + where Just formula' = get (formula node) graph + + -- find all the behavior nodes in the graph + findBehaviors :: [SomeNode] + findBehaviors = traverseNodes g graph + where + g :: Node a -> FormulaD Nodes a -> [SomeNode] + g node (B _) = [Exists node] + g _ _ = [] + +-- | Build collection of input nodes from scratch +buildInputs :: SomeNode -> Formulas -> Inputs +buildInputs root formulas = + unfoldGraphDFSWith leftComposition f root Map.empty + where + f (Exists node) = (addInput, dependencies formula') + where + Just formula' = getFormula' node formulas + addInput :: Inputs -> Inputs + addInput = case formula' of + E (InputE i) -> Map.insertWith (++) (getChannel i) [Exists node] + _ -> id + +-- | Traverse all nodes of the graph. +-- The order in which this happens is left unspecified. +traverseNodes + :: Monoid t + => (forall a. Node a -> FormulaD Nodes a -> t) -- map nodes to monoid values + -> Graph b + -> t +traverseNodes f graph = + unfoldGraphDFSWith reifyMonoid g (Exists $ grOutput graph) + where + g (Exists node) = (f node formula', dependencies formula') + where Just formula' = get (formula node) graph + +{----------------------------------------------------------------------------- + Generic Graph Traversals +------------------------------------------------------------------------------} +-- | Dictionary for defining monoids on the fly. +data MonoidDict t = MonoidDict t (t -> t -> t) + +reifyMonoid :: Monoid t => MonoidDict t +reifyMonoid = MonoidDict mempty mappend + +-- | Unfold a graph, +-- i.e. unfold a given state s into a concatenation of monoid values +-- while ignoring duplicate states. +-- Depth-first order. +unfoldGraphDFSWith + :: forall s t. (Hashable s, Eq s) => MonoidDict t -> (s -> (t,[s])) -> s -> t +unfoldGraphDFSWith (MonoidDict empty append) f s = go Set.empty [s] + where + go :: Set s -> [s] -> t + go seen [] = empty + go seen (x:xs) + | x `Set.member` seen = go seen xs + | otherwise = t `append` go (Set.insert x seen) (ys++xs) + where + (t,ys) = f x + +-- | Monoid of endomorphisms, leftmost function is applied *last*. +leftComposition :: MonoidDict (a -> a) +leftComposition = MonoidDict id (flip (.)) + +{- +testDFS :: Int -> [Int] +testDFS = unfoldGraphDFSWith (MonoidDict [] (++)) go + where go n = ([n],if n <= 0 then [] else [n-2,n-1]) +-} + +{----------------------------------------------------------------------------- + Reduction and Evaluation +------------------------------------------------------------------------------} +-- type Queue = [SomeNode] + +-- | Perform evaluation steps until all values have percolated through the graph. +evaluate :: Queue q => q SomeNode -> Graph b -> Values -> (Maybe b, Graph b) +evaluate startQueue startGraph startValues = + (get (value (grOutput startGraph)) endValues, endGraph) + where + (_,endValues,endGraph) = + until (isEmpty . queue) step (startQueue,startValues,startGraph) + + queue (q,_,_) = q + step (q,v,g) = (q',v',f g) + where (q',v',f) = evaluationStep startGraph q v + +-- | Perform a single evaluation step. +evaluationStep + :: forall q b. Queue q + => Graph b -- initial graph shape + -> q SomeNode -- queue of nodes to process + -> Values -- current event values + -> (q SomeNode, Values, Graph b -> Graph b) +evaluationStep graph queue values = case minView queue of + Just (Exists node, queue) -> go node queue + Nothing -> error "evaluationStep: queue empty" + where + go :: forall a b. + Node a -> q SomeNode -> (q SomeNode, Values, Graph b -> Graph b) + go node queue = + let -- lookup functions + valueE :: forall e. Node e -> Maybe e + valueE node = get (value node) values + valueB :: forall b. Node b -> b + valueB node = case get (formula node) graph of + Just (B (Stepper b _)) -> b + _ -> error "evaluationStep: behavior not found" + + err = error "evaluationStep: formula not found" + in -- evaluation + case maybe err id $ get (formula node) graph of + B formulaB -> -- evalute behavior + (queue, values, calculateB valueE node formulaB) + E formulaE -> -- evaluate event + let -- calculate current value + (maybeval, f) = + calculateE valueE valueB node formulaE + -- set value if applicable + setValue = case maybeval of + Just x -> set (value node) (Just x) + Nothing -> id + -- evaluate children only if node doesn't return Nothing + setQueue = case maybeval of + Just _ -> insertList $ get (children node) graph + Nothing -> id + in (setQueue queue, setValue values, f) + +{----------------------------------------------------------------------------- + Convert into an automaton +------------------------------------------------------------------------------} +compileToAutomaton :: Event Expr b -> IO (Automaton b) +compileToAutomaton expr = return $ fromStateful automatonStep $ buildGraph (e expr) + where + e :: Event Expr b -> Formula Expr b + e (Pair n x) = Pair n (E x) + +-- single step function of the automaton +automatonStep :: [InputValue] -> Graph b -> IO (Maybe b, Graph b) +automatonStep inputs graph = return (b, graph') + where + -- figure out nodes corresponding to input values + inputNodes :: [(InputValue, SomeNode)] + inputNodes = + [ (i, node) + | i <- inputs + , nodes <- maybeToList $ Map.lookup (getChannel i) (grInputs graph) + , node <- nodes] + + -- fill up values for start/input nodes + startValues = foldr insertInput Vault.empty inputNodes + -- insert a single input into the start values + insertInput :: (InputValue, SomeNode) -> Values -> Values + insertInput (i,somenode) = maybe id id $ + withInputNode somenode (\node channel -> + maybe id (Vault.insert (keyValue node)) $ fromValue channel i + ) + + -- unpack InputE node if applicable + withInputNode :: SomeNode + -> (forall a. Node a -> InputChannel a -> b) -> Maybe b + withInputNode somenode f = case somenode of + Exists node -> + let theformula = get (formula node) graph + in case theformula of + Just (E (InputE channel)) -> Just $ f node channel + _ -> Nothing + + -- perform evaluation + (b,graph') = withTotalOrder (grEvalOrder graph) $ \qempty -> + evaluate (insertList (map snd inputNodes) qempty) graph startValues + + + diff --git a/src/Reactive/Banana/Internal/TotalOrder.hs b/src/Reactive/Banana/Internal/TotalOrder.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/Internal/TotalOrder.hs @@ -0,0 +1,123 @@ +{----------------------------------------------------------------------------- + Reactive Banana +------------------------------------------------------------------------------} +{-# LANGUAGE Rank2Types, BangPatterns #-} +module Reactive.Banana.Internal.TotalOrder ( + -- * Synopsis + -- | Data structure that represents a total order. + + -- * TotalOrder + TotalOrder, TotalOrderZipper, + open, close, fromAscList, ascend, descend, insertBeforeFocus, delete, + withTotalOrder, + + -- * Queue + Queue(..), insertList, isEmpty, + ) where + + +import Control.Applicative +import Control.Arrow (second) + +import qualified Data.List +import Data.Maybe +import Data.Ord + +import Data.Hashable +import qualified Data.HashMap.Strict as Map +import qualified Data.Set as Set + +type Map = Map.HashMap +type Set = Set.Set + +{----------------------------------------------------------------------------- + Total Order implementation +------------------------------------------------------------------------------} +-- Data type representing a total order between elements +-- It's simply an ordered list of elements +newtype TotalOrder a = TO { unTO :: Map a Int } + +-- Zipper variant of a total order. +data TotalOrderZipper a = TOZ { down :: [a], up :: [a] } + +open :: TotalOrder a -> TotalOrderZipper a +open (TO order) = TOZ { down = [], up = Map.keys order } + +close :: (Hashable a, Eq a) => TotalOrderZipper a -> TotalOrder a +close order = TO $ Map.fromList $ zip (reverse (down order) ++ up order) [1..] + +fromAscList :: (Hashable a, Eq a) => [a] -> TotalOrder a +fromAscList xs = close $ TOZ { down = [], up = xs } + + +-- move to the next larger element +ascend :: TotalOrderZipper a -> TotalOrderZipper a +ascend (TOZ xs [] ) = TOZ xs [] +ascend (TOZ xs (y:ys)) = TOZ (y:xs) ys + +-- move to the next smaller element +descend :: TotalOrderZipper a -> TotalOrderZipper a +descend (TOZ [] ys) = TOZ [] ys +descend (TOZ (x:xs) ys) = TOZ xs (x:ys) + +-- insert an element before the current one +insertBeforeFocus :: a -> TotalOrderZipper a -> TotalOrderZipper a +insertBeforeFocus x (TOZ xs ys) = TOZ (x:xs) ys + +-- delete an element from a total order +delete :: Eq a => a -> TotalOrderZipper a -> TotalOrderZipper a +delete x (TOZ xs ys) = TOZ (delete' x xs) (delete' x ys) + where delete' = Data.List.delete + +{----------------------------------------------------------------------------- + Queue based on a total order +------------------------------------------------------------------------------} +-- | Obtain a queue based on a particular total order. +-- +-- The type system ensures that the queue is only used temporarily. +-- The argument passed to the function is the empty queue. +withTotalOrder :: TotalOrder a -> (forall q. Queue q => q a -> b) -> b +withTotalOrder order f = f empty + where empty = Q { order = order, queue = Set.empty } + +-- public interface +class Queue q where + insert :: (Hashable a, Eq a) => a -> q a -> q a + minView :: q a -> Maybe (a, q a) + size :: q a -> Int + +-- | Check whether a queue is empty. +isEmpty :: Queue q => q a -> Bool +isEmpty = isNothing . minView + +-- | Insert a collection of elements +insertList :: (Queue q, Hashable a, Eq a) => [a] -> q a -> q a +insertList xs q = foldl (flip insert) q xs + +-- concrete implementation +data MyQueue a = Q { order :: TotalOrder a, queue :: Set (Pair Int a) } + +data Pair a b = Pair !a b +fstPair (Pair a _) = a +instance Eq a => Eq (Pair a b) where + x == y = fstPair x == fstPair y +instance Ord a => Ord (Pair a b) where + compare = comparing fstPair + +-- set the queue field +setQueue :: MyQueue a -> Set (Pair Int a) -> MyQueue a +setQueue q b = q { queue = b } + +-- find the index of a particular element in a Total Order +position :: (Hashable a, Eq a) => TotalOrder a -> a -> Int +position (TO order) x = pos + where Just pos = Map.lookup x order + +instance Queue MyQueue where + insert x q = q { queue = Set.insert (Pair pos x) (queue q) } + where pos = position (order q) x + minView q = f <$> Set.minView (queue q) + where f (Pair _ a,set) = (a, setQueue q set) + size q = Set.size (queue q) + + diff --git a/src/Reactive/Banana/Model.hs b/src/Reactive/Banana/Model.hs deleted file mode 100644 --- a/src/Reactive/Banana/Model.hs +++ /dev/null @@ -1,290 +0,0 @@ -{----------------------------------------------------------------------------- - Reactive Banana - - Class interface + Semantic model -------------------------------------------------------------------------------} -{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, EmptyDataDecls, - MultiParamTypeClasses #-} -module Reactive.Banana.Model ( - -- * Synopsis - -- | Combinators for building event networks and their semantics. - - -- * Core Combinators - module Control.Applicative, - FRP(..), - Event, Behavior, - -- $classes - - -- * Derived Combinators - whenE, filterJust, mapAccum, Apply(..), - - -- * Model implementation - Model, - Time, interpretTime, interpret, - ) where - -import Control.Applicative -import qualified Data.List -import Data.Maybe -import Prelude hiding (filter) -import Data.Monoid - -{----------------------------------------------------------------------------- - Class interface -------------------------------------------------------------------------------} -data family Event f :: * -> * -data family Behavior f :: * -> * - -{- | The 'FRP' class defines the primitive API for functional reactive programming. -Each instance 'f' defines two type constructors @Event f@ and @Behavior f@ -and corresponding combinators. - -@Event f a@ represents a stream of events as they occur in time. -Semantically, you can think of @Event f a@ as an infinite list of values -that are tagged with their corresponding time of occurence, - -> type Event f a = [(Time,a)] - -@Behavior f a@ represents a value that varies in time. Think of it as - -> type Behavior f a = Time -> a - -While these type synonyms are the way you should think about -'Behavior' and 'Event', they are a bit vague for formal manipulation. -To remedy this, the library provides a very simple model implementation, -called 'Model'. -This model is /authoritative/: every instance of the 'FRP' class /must/ -give the same results as the model when observed with the 'interpret' function. -Note that this must also hold for recursive and partial definitions -(at least in spirit, I'm not going to split hairs over @_|_@ vs @\\_ -> _|_@). - -Concerning time and space complexity, the model is not authoritative, however. -Implementations are free to be much more efficient. - -Minimal complete definition of the 'FRP' class: One of 'filter' or 'filterApply' -and one of 'accumB' or 'stepper'. - --} - -class (Functor (Event f), - Functor (Behavior f), Applicative (Behavior f)) => FRP f where - - -- | Event that never occurs. - -- Think of it as @never = []@. - never :: Event f a - - -- | Merge two event streams of the same type. - -- In case of simultaneous occurrences, the left argument comes first. - -- Think of it as - -- - -- > union ((timex,x):xs) ((timey,y):ys) - -- > | timex <= timey = (timex,x) : union xs ((timey,y):ys) - -- > | timex > timey = (timey,y) : union ((timex,x):xs) ys - union :: Event f a -> Event f a -> Event f a - - -- | Apply a time-varying function to a stream of events. - -- Think of it as - -- - -- > apply bf ex = [(time, bf time x) | (time, x) <- ex] - apply :: Behavior f (a -> b) -> Event f a -> Event f b - - - -- | Allow all events that fulfill the predicate, discard the rest. - -- Think of it as - -- - -- > filterE p es = [(time,a) | (time,a) <- es, p a] - filterE :: (a -> Bool) -> Event f a -> Event f a - - -- | Allow all events that fulfill the time-varying predicate, discard the rest. - -- It's a slight generalization of 'filterE'. - filterApply :: Behavior f (a -> Bool) -> Event f a -> Event f a - - - -- Accumulation. - -- Note: all accumulation functions are strict in the accumulated value! - -- acc -> (x,acc) is the order used by unfoldr and State - - -- | Construct a time-varying function from an initial value and - -- a stream of new values. Think of it as - -- - -- > stepper x0 ex = \time -> last (x0 : [x | (timex,x) <- ex, timex < time]) - -- - -- Note that the smaller-than-sign in the comparision @timex < time@ means - -- that the value of the behavior changes \"slightly after\" - -- the event occurrences. This allows for recursive definitions. - -- - -- Also note that in the case of simultaneous occurrences, - -- only the last one is kept. - stepper :: a -> Event f a -> Behavior f a - - -- | The 'accumB' function is similar to a /strict/ left fold, 'foldl''. - -- It starts with an initial value and combines it with incoming events. - -- For example, think - -- - -- > accumB "x" [(time1,(++"y")),(time2,(++"z"))] - -- > = stepper "x" [(time1,"xy"),(time2,"xyz")] - -- - -- Note that the value of the behavior changes \"slightly after\" - -- the events occur. This allows for recursive definitions. - accumB :: a -> Event f (a -> a) -> Behavior f a - - -- | The 'accumE' function accumulates a stream of events. - -- Example: - -- - -- > accumE "x" [(time1,(++"y")),(time2,(++"z"))] - -- > = [(time1,"xy"),(time2,"xyz")] - -- - -- Note that the output events are simultaneous with the input events, - -- there is no \"delay\" like in the case of 'accumB'. - accumE :: a -> Event f (a -> a) -> Event f a - - - -- implementation filter - filterE p = filterApply (pure p) - filterApply bp = fmap snd . filterE fst . apply ((\p a-> (p a,a)) <$> bp) - - -- implementation accumulation - accumB acc = stepper acc . accumE acc - stepper acc = accumB acc . fmap const - -{-$classes - -/Further combinators that Haddock can't document properly./ - -> instance FRP f => Monoid (Event f a) - -The combinators 'never' and 'union' turn 'Event' into a monoid. - -> instance FPR f => Applicative (Behavior f) - -'Behavior' is an applicative functor. In particular, we have the following functions. - -> pure :: FRP f => a -> Behavior f a - -The constant time-varying value. Think of it as @pure x = \\time -> x@. - -> (<*>) :: FRP f => Behavior f (a -> b) -> Behavior f a -> Behavior f b - -Combine behaviors in applicative style. -Think of it as @bf \<*\> bx = \\time -> bf time $ bx time@. - --} - -instance FRP f => Monoid (Event f a) where - mempty = never - mappend = union - -{----------------------------------------------------------------------------- - Derived Combinators -------------------------------------------------------------------------------} --- | Variant of 'filterApply'. -whenE :: FRP f => Behavior f Bool -> Event f a -> Event f a -whenE bf = filterApply (const <$> bf) - --- | Variant of 'filterE'. Keep only the 'Just' values. -filterJust :: FRP f => Event f (Maybe a) -> Event f a -filterJust = fmap (maybe err id) . filterE isJust - where err = error "Reactive.Banana.Model.filterJust: Internal error. :(" - --- | Efficient combination of 'accumE' and 'accumB'. -mapAccum :: FRP f => acc -> Event f (acc -> (x,acc)) -> (Event f x, Behavior f acc) -mapAccum acc ef = (fst <$> e, stepper acc (snd <$> e)) - where e = accumE (undefined,acc) ((. snd) <$> ef) - - -infixl 4 <@>, <@ - --- | Class for overloading the 'apply' function. -class (Functor f, Functor g) => Apply f g where - -- | Infix operation for the 'apply' function, similar to '<*>' - (<@>) :: f (a -> b) -> g a -> g b - -- | Convenience function, similar to '<*' - (<@) :: f a -> g b -> g a - - f <@ g = (const <$> f) <@> g - -instance FRP f => Apply (Behavior f) (Event f) where - (<@>) = apply - -{----------------------------------------------------------------------------- - Semantic model -------------------------------------------------------------------------------} --- | The type index 'Model' represents the model implementation. --- You are encouraged to look at the source code! --- (If there is no link to the source code at every type signature, --- then you have to run @cabal@ with @--hyperlink-source@ flag.) -data Model - --- Stream of events. Simultaneous events are grouped into lists. -newtype instance Event Model a = E { unE :: [[a]] } --- Stream of values that the behavior takes. -newtype instance Behavior Model a = B { unB :: [a] } - - -instance Functor (Event Model) where - fmap f = E . map (map f) . unE - -instance Applicative (Behavior Model) where - pure x = B $ repeat x - bf <*> bx = B $ zipWith ($) (unB bf) (unB bx) - -instance Functor (Behavior Model) where - fmap = liftA - -instance FRP Model where - never = E $ repeat [] - union e1 e2 = E $ zipWith (++) (unE e1) (unE e2) - - filterApply bp = E . zipWith (\p xs-> Data.List.filter p xs) (unB bp) . unE - apply b = E . zipWith (\f xs -> map f xs) (unB b) . unE - - stepper x = B . scanl go x . unE - where go x e = last (x:e) - - accumE acc = E . accumE' acc . unE - where - accumE' acc [] = [] - accumE' acc (e:es) = e' : accumE' acc' es - where - vals = scanl' (flip ($)) acc e - e' = tail $ vals - acc' = last vals - --- strict version of scanl -scanl' :: (a -> b -> a) -> a -> [b] -> [a] -scanl' f x ys = x : case ys of - [] -> [] - y:ys -> let z = f x y in z `seq` scanl' f z ys - --- | Slightly simpler interpreter that does not mention 'Time'. --- Returns lists of event values that occur simultaneously. -interpret :: (Event Model a -> Event Model b) -> [a] -> [[b]] -interpret f = unE . f . E . map (:[]) - -type Time = Double --- | Interpreter that corresponds to your mental model. -interpretTime :: (Event Model a -> Event Model b) -> [(Time,a)] -> [(Time,b)] -interpretTime f xs = - concat . zipWith tag times . interpret f . map snd $ xs - where - times = map fst xs - tag t xs = map (\x -> (t,x)) xs - -{----------------------------------------------------------------------------- - Example: Counter that can be decreased -------------------------------------------------------------------------------} -example :: FRP f => Event f () -> Event f Int -example edec = apply ((\c _ -> c) <$> bcounter) ecandecrease - where - bcounter = accumB 10 $ (subtract 1) <$ ecandecrease - ecandecrease = whenE ((>0) <$> bcounter) edec - -testModel = interpret example $ replicate 15 () --- > testModel --- [[10],[9],[8],[7],[6],[5],[4],[3],[2],[1],[],[],[],[],[]] - -example2 :: FRP f => Event f () -> Event f Int -example2 e = apply (const <$> b) e - where - b = accumB 0 ((+1) <$ e) - diff --git a/src/Reactive/Banana/PushIO.hs b/src/Reactive/Banana/PushIO.hs deleted file mode 100644 --- a/src/Reactive/Banana/PushIO.hs +++ /dev/null @@ -1,430 +0,0 @@ -{----------------------------------------------------------------------------- - Reactive Banana - - A push-driven implementation -------------------------------------------------------------------------------} -{-# LANGUAGE TypeFamilies, FlexibleInstances, EmptyDataDecls, GADTs, - TupleSections, BangPatterns #-} -module Reactive.Banana.PushIO where - -import Reactive.Banana.Model hiding (Event, Behavior, interpret) -import qualified Reactive.Banana.Model as Model - -import Data.Vault (Vault) -import qualified Data.Vault as Vault - - -import Control.Applicative -import Control.Arrow (second) -import Control.Monad -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Identity -import Control.Monad.Trans.State -import Control.Monad.Trans.Writer -import Data.Maybe -import Data.Monoid -import System.IO.Unsafe - -import System.IO --- debug s = hPutStrLn stderr s - -{----------------------------------------------------------------------------- - Observable sharing - - References can be used in the Store monad. - This mimicks the case where unique IDs are used - to look up a value in the environment. - In this case, the environment is passed around by the Store monad. -------------------------------------------------------------------------------} --- store monad -type Store = StateT Vault IO --- references to observe sharing -type Ref a = Vault.Key a - -runStore :: Store a -> IO a -runStore m = evalStateT m Vault.empty - --- create a new reference. -newRef :: IO (Ref a) --- read a reference. Only possible in the Store monad. -readRef :: Ref a -> Store (Maybe a) -writeRef :: Ref a -> a -> Store () - -newRef = Vault.newKey -readRef ref = Vault.lookup ref <$> get -writeRef ref x = modify $ Vault.insert ref x - --- invalid reference that may not store values -invalidRef = error "Store: invalidRef. This is an internal bug." - -{----------------------------------------------------------------------------- - Cache, generalities -------------------------------------------------------------------------------} --- A cache stores values of different types --- and finalizers to change them. -data Cache = Cache { - vault :: Vault - , initializers :: [VaultChanger] - , finalizers :: [VaultChanger] } -type VaultChanger = Run () - -emptyCache :: Cache -emptyCache = Cache Vault.empty [] [] - --- monad to build the network in -type Compile = StateT Cache Store --- monad to run the network in -type Run = StateT Vault IO - -runCompile :: Compile a -> Store (a, Cache) -runCompile m = runStateT m $ Cache { vault = Vault.empty, initializers = [], finalizers = [] } - -registerInitializer, registerFinalizer :: VaultChanger -> Compile () -registerFinalizer m = modify $ - \cache -> cache { finalizers = finalizers cache ++ [m] } -registerInitializer m = modify $ - \cache -> cache { initializers = initializers cache ++ [m] } - -runRun :: Run a -> Cache -> IO (a, Cache) -runRun m cache = do - let vault1 = vault cache - -- run the initializers - vault2 <- runVaultChangers (initializers cache) vault1 - -- run the action - (x,vault3) <- runStateT m vault2 - -- run all the finalizers - vault4 <- runVaultChangers (finalizers cache) vault3 - -- return new cache - return (x,cache{ vault = vault4 }) - where - runVaultChangers = execStateT . sequence_ - --- helper functions for reading and writing keys into the vault cache -writeVaultKey ref x = do - vault <- get - let vault' = Vault.insert ref x vault - put $ vault' -readVaultKey ref = Vault.lookup ref <$> get - -{----------------------------------------------------------------------------- - Cache, particular reference types -------------------------------------------------------------------------------} --- CacheRef --- A simple value to be cached. Lasts one phase. Useful for sharing. -type CacheRef a = Vault.Key a - -newCacheRef :: Compile (CacheRef a) -readCacheRef :: CacheRef a -> Run (Maybe a) -writeCacheRef :: CacheRef a -> a -> Run () - -newCacheRef = do - key <- liftIO $ Vault.newKey - registerFinalizer $ put . Vault.delete key =<< get - return key -readCacheRef = readVaultKey -writeCacheRef = writeVaultKey - --- Accumulation values. --- Cache and accumulate a value over several phases. -type AccumRef a = Vault.Key a - -newAccumRef :: a -> Compile (AccumRef a) -readAccumRef :: AccumRef a -> Run a -updateAccumRef :: AccumRef a -> (a -> a) -> Run a -- strict! - -newAccumRef x = do - ref <- liftIO $ Vault.newKey - vault2 <- Vault.insert ref x . vault <$> get - modify $ \cache -> cache { vault = vault2 } - return ref -readAccumRef ref = - fromJustError "Reactive.Banana.PushIO.readAccumRef: internal error" - <$> readVaultKey ref -updateAccumRef ref f = do - Just x <- readVaultKey ref - let !y = f x - writeVaultKey ref y - return y - -fromJustError e = maybe (error e) id - --- BehaviorRef. --- Cache and accumulate a value over several phases, --- but updates are only visible at the beginning of a new phase. --- (accumulator, temporary reference for each phase) -type BehaviorRef a = (AccumRef a, CacheRef a) - -newBehaviorRefPoll :: IO a -> Compile (BehaviorRef a) -newBehaviorRefAccum :: a -> Compile (BehaviorRef a) -readBehaviorRef :: BehaviorRef a -> Run a -updateBehaviorRef :: BehaviorRef a -> (a -> a) -> Run () -- strict! - -newBehaviorRef m = do - temp <- newCacheRef - registerInitializer $ writeCacheRef temp =<< m - return (undefined, temp) -newBehaviorRefPoll = newBehaviorRef . liftIO -newBehaviorRefAccum x = do - acc <- newAccumRef x - (_,temp) <- newBehaviorRef $ readAccumRef acc - return (acc, temp) -readBehaviorRef (_, temp) = - fromJustError "Reactive.Banana.PushIO.readBehaviorRef: internal error" - <$> readCacheRef temp -updateBehaviorRef (acc, temp) = void . updateAccumRef acc - - -{----------------------------------------------------------------------------- - Abstract syntax tree -------------------------------------------------------------------------------} -data Accum -data Shared -data Linear - -type EventStore a = [(Channel, CacheRef a)] - -type family Event t a -type instance Event Accum a = (Ref (EventStore a), EventD Accum a) -type instance Event Shared a = (Ref (EventStore a), EventD Shared a) -type instance Event Linear a = EventD Linear a - -data EventD t :: * -> * where - Filter :: (a -> Bool) -> Event t a -> EventD t a - ApplyE :: Behavior t (a -> b) -> Event t a -> EventD t b - AccumE :: a -> Event t (a -> a) -> EventD t a - Union :: Event t a -> Event t a -> EventD t a - Never :: EventD t a - - -- internal combinators - Input :: Channel -> Key a -> EventD t a - Reactimate :: Event t (IO ()) -> EventD t () - - ReadCache :: Channel -> CacheRef a -> EventD t a - WriteCache :: CacheRef a -> Event t a -> EventD t a - - UpdateAccum :: AccumRef a -> Event t (a -> a) -> EventD t a - UpdateBehavior :: BehaviorRef a -> Event t (a -> a) -> EventD t () - - -type BehaviorStore a = BehaviorRef a - -type family Behavior t a -type instance Behavior Accum a = (Ref (BehaviorStore a), BehaviorD Accum a) -type instance Behavior Shared a = (Ref (BehaviorStore a), BehaviorD Linear a) -type instance Behavior Linear a = (Ref (BehaviorStore a), BehaviorD Linear a) - -data BehaviorD t a where - Pure :: a -> BehaviorD t a - ApplyB :: Behavior t (a -> b) -> Behavior t a -> BehaviorD t b - AccumB :: a -> Event t (a -> a) -> BehaviorD t a - Poll :: IO a -> BehaviorD t a - - -- internal combinators - ReadBehavior :: BehaviorRef a -> BehaviorD t a - -{----------------------------------------------------------------------------- - Storing heterogenous input values -------------------------------------------------------------------------------} -type Channel = Integer -- identifies an input -type Key = Vault.Key -type Universe = Vault.Vault - -newUniverseKey :: IO (Key a) -newUniverseKey = Vault.newKey - -fromUniverse :: Key a -> Universe -> Maybe a -fromUniverse = Vault.lookup - -toUniverse :: Key a -> a -> Universe -toUniverse k a = Vault.insert k a Vault.empty - -{----------------------------------------------------------------------------- - Compilation -------------------------------------------------------------------------------} --- allocated caches for acummulated and external behaviors, --- turn them into reads from the cache -type CompileReadBehavior = WriterT [Event Shared ()] Compile - -compileReadBehavior :: Event Accum () -> Compile (Event Shared ()) -compileReadBehavior e1 = do - (e,es) <- runWriterT (goE e1) - -- include updates to Behavior as additional events - let union e1 e2 = (invalidRef, Union e1 e2) - return $ foldr1 union (e:es) - where - -- boilerplate traversal for events - goE :: Event Accum a -> CompileReadBehavior (Event Shared a) - goE (ref, Filter p e ) = (ref,) <$> (Filter p <$> goE e) - goE (ref, Union e1 e2) = (ref,) <$> (Union <$> goE e1 <*> goE e2) - goE (ref, ApplyE b e ) = (ref,) <$> (ApplyE <$> goB b <*> goE e ) - goE (ref, AccumE x e ) = (ref,) <$> (AccumE x <$> goE e) - goE (ref, Reactimate e) = (ref,) <$> (Reactimate <$> goE e) - goE (ref, Never) = (ref,) <$> (pure Never) - goE (ref, Input c k) = (ref,) <$> (pure $ Input c k) - - -- almost boilerplate traversal for behaviors - goB :: Behavior Accum a -> CompileReadBehavior (Behavior Shared a) - goB (ref, Pure x ) = (ref,) <$> (Pure <$> return x) - goB (ref, ApplyB bf bx) = (ref,) <$> (ApplyB <$> goB bf <*> goB bx) - goB (ref, Poll io ) = (ref,) <$> (ReadBehavior <$> makeRef) - where - makeRef = do - m <- lift . lift $ readRef ref - case m of - Just r -> return r - Nothing -> do - r <- lift $ newBehaviorRefPoll io - lift . lift $ writeRef ref r - return r - goB (ref, AccumB x e ) = (ref,) <$> (ReadBehavior <$> makeRef) - where - makeRef = do - m <- lift . lift $ readRef ref - case m of - Just r -> return r - Nothing -> do - -- create new BehaviorRef and share it - r <- lift $ newBehaviorRefAccum x - lift . lift $ writeRef ref r - - -- remove accumB from the other events - e <- goE e - tell [(invalidRef, UpdateBehavior r e)] - return r - --- fan out unions into linear paths -type EventLinear a = (Channel, Event Linear a) - -compileUnion :: Event Shared a -> Compile [Event Linear a] -compileUnion e = map snd <$> goE e - where - goE :: Event Shared a -> Compile [EventLinear a] - goE (ref, Filter p e ) = cacheEvents ref (map2 (Filter p) <$> goE e) - goE (ref, ApplyE b e ) = cacheEvents ref (map2 (ApplyE b) <$> goE e) - goE (ref, AccumE x e ) = cacheEvents ref (compileAccumE x =<< goE e) - goE (_ , UpdateBehavior b e) = map2 (UpdateBehavior b) <$> goE e - goE (_ , Reactimate e) = map2 (Reactimate) <$> goE e - goE (_ , Union e1 e2) = (++) <$> goE e1 <*> goE e2 - goE (_ , Never ) = return [] - goE (_ , Input channel key) = return [(channel, Input channel key)] - - compileAccumE :: a -> [EventLinear (a -> a)] -> Compile [EventLinear a] - compileAccumE x es = do - ref <- newAccumRef x - return $ map2 (UpdateAccum ref) es - - cacheEvents :: Ref (EventStore a) - -> Compile [EventLinear a] -> Compile [EventLinear a] - cacheEvents ref mes = do - m <- lift $ readRef ref - case m of - Just cached -> do - return $ map (\(c,r) -> (c, ReadCache c r)) cached - Nothing -> do - -- compile input events - es <- mes - -- allocate corresponding cache references and share them - cached <- forM es $ \(c,_) -> do r <- newCacheRef; return (c,r) - lift $ writeRef ref cached - -- return events that also write to the cache - return $ zipWith (second . (WriteCache . snd)) cached es - -map2 = map . second - --- compile a behavior --- FIXME: take care of sharing, caching -compileBehaviorEvaluation :: Behavior Linear a -> Run a -compileBehaviorEvaluation = goB - where - goB :: Behavior Linear a -> Run a - goB (ref, Pure x) = return x - goB (ref, ApplyB bf bx) = goB bf <*> goB bx - goB (ref, ReadBehavior refb) = readBehaviorRef refb - - --- compile path into an IO action -type Path = (Channel, Universe -> Run (IO ())) --- (input_channel, \input_value -> --- do change event_graph_state; return (reactimates_to_be_run) ) - -compilePath :: Event Linear () -> Path -compilePath e = goE e (const $ return nop) - where - goE :: Event Linear a -> (a -> Run (IO ())) -> Path - goE (Filter p e) k = goE e $ \x -> if p x then k x else return nop - goE (ApplyE b e) k = goE e $ \x -> goB b >>= \f -> k (f x) - goE (UpdateAccum r e) k = goE e $ \f -> updateAccumRef r f >>= k - goE (UpdateBehavior r e) _ = goE e $ \x -> do updateBehaviorRef r x; return nop - -- note: no k here because writing behaviors is the end of a path - goE (Reactimate e) _ = goE e $ \x -> return x - goE (ReadCache c ref) k = - (c, \_ -> readCacheRef ref >>= maybe (return nop) k) - goE (WriteCache ref e) k = goE e $ \x -> writeCacheRef ref x >> k x - goE (Input channel key) k = - (channel, maybe (error "wrong channel") k . fromUniverse key) - - nop = return () :: IO () - - goB :: Behavior Linear a -> Run a - goB = compileBehaviorEvaluation - --- compilation function -compile :: Event Accum () -> IO ([Path], Cache) -compile e = runStore $ runCompile $ - return . map compilePath =<< compileUnion =<< compileReadBehavior e - --- debug :: MonadIO m => String -> m () --- debug = liftIO . putStrLn - -{----------------------------------------------------------------------------- - Class instances -------------------------------------------------------------------------------} --- | The type index 'PushIO' represents the efficient push-driven implementation --- described here. --- It implements the same 'FRP' interface as the model implementation --- represented by 'Model'. -data PushIO - --- type Behavior = Model.Behavior PushIO -newtype instance Model.Behavior PushIO a = Behavior (Behavior Accum a) - --- type Event = Model.Event PushIO -newtype instance Model.Event PushIO a = Event (Event Accum a) - -unEvent (Event e) = e - --- sharing -behavior :: BehaviorD Accum a -> Model.Behavior PushIO a -behavior b = Behavior pair - where - {-# NOINLINE pair #-} - -- mention argument to prevent let-floating - pair = unsafePerformIO (fmap (,b) newRef) - -event :: EventD Accum a -> Model.Event PushIO a -event e = Event pair - where - {-# NOINLINE pair #-} - -- mention argument to prevent let-floating - pair = unsafePerformIO (fmap (,e) newRef) - --- boilerplate class instances -instance Functor (Model.Event PushIO) where - fmap f e = apply (pure f) e - -instance Applicative (Model.Behavior PushIO) where - pure x = behavior $ Pure x - (Behavior bf) <*> (Behavior bx) = behavior $ ApplyB bf bx - -instance Functor (Model.Behavior PushIO) where - fmap = liftA - -instance FRP PushIO where - never = event $ Never - union (Event e1) (Event e2) = event $ Union e1 e2 - filterE p (Event e) = event $ Filter p e - apply (Behavior bf) (Event ex) = event $ ApplyE bf ex - accumB x (Event e) = behavior $ AccumB x e - accumE x (Event e) = event $ AccumE x e - diff --git a/src/Reactive/Banana/Tests.hs b/src/Reactive/Banana/Tests.hs --- a/src/Reactive/Banana/Tests.hs +++ b/src/Reactive/Banana/Tests.hs @@ -4,31 +4,34 @@ Test cases and examples ------------------------------------------------------------------------------} {-# LANGUAGE Rank2Types, NoMonomorphismRestriction #-} + module Reactive.Banana.Tests where import Control.Monad (when) -import Reactive.Banana.Model as Model -import Reactive.Banana.Implementation as Impl +import Reactive.Banana.Combinators -import Test.QuickCheck +-- import Test.QuickCheck +-- import Test.QuickCheck.Property {----------------------------------------------------------------------------- Testing ------------------------------------------------------------------------------} -matchesModel :: (Typeable a, Show b, Eq b) => - (forall f. FRP f => Event f a -> Event f b) -> [a] -> IO Bool -matchesModel f = \xs -> do - let bs1 = Model.interpret f xs - bs2 <- Impl.interpret f xs - when (bs1 /= bs2) $ print bs1 >> print bs2 - return $ bs1 == bs2 - +matchesModel :: (Show b, Eq b) + => (forall t. Event t a -> Event t b) -> [[a]] -> IO Bool +matchesModel f xs = do + bs1 <- interpretModel f xs + bs2 <- interpretPushGraph f xs + when (bs1 /= bs2) $ print bs1 >> print bs2 + return $ bs1 == bs2 testSuite = do -- trivial unit tests - test add1 - test filtering + test id + -- test never1 + test fmap1 + test filter1 + test filter2 test counter test double test sharing @@ -38,18 +41,24 @@ -- * algebraic laws -- * larger examples -- * quickcheck - where - test :: (Show b, Eq b) => (forall f. FRP f => Event f Int -> Event f b) - -> IO () - test f = print =<< matchesModel f [1..8::Int] +test :: (Show b, Eq b) => (forall t. Event t Int -> Event t b) -> IO () +test f = print =<< matchesModel f (singletons [1..8::Int]) + +singletons = map (\x -> [x]) + {----------------------------------------------------------------------------- Examples ------------------------------------------------------------------------------} -test f = Impl.interpret f [1..8::Int] +testModel, testPush :: (forall t. Event t Int -> Event t b) -> IO [[b]] +testModel f = interpretModel f $ singletons [1..8::Int] +testPush f = interpretPushGraph f $ singletons [1..8::Int] -add1 = fmap (+1) -filtering = filterE (>= 3) . fmap (subtract 1) +never1 :: Event t Int -> Event t Int +never1 = const never +fmap1 = fmap (+1) +filter1 = filterE (>= 3) +filter2 = filterE (>= 3) . fmap (subtract 1) counter e = apply (pure const <*> bcounter) e where bcounter = accumB 0 $ fmap (\_ -> (+1)) e double e = union e e @@ -59,14 +68,14 @@ type Dummy = Int -- counter that can be decreased as long as it's >= 0 -decrease :: FRP f => Event f Dummy -> Event f Int +decrease :: Event t Dummy -> Event t Int decrease edec = apply (const <$> bcounter) ecandecrease where bcounter = accumB 4 $ (subtract 1) <$ ecandecrease ecandecrease = whenE ((>0) <$> bcounter) edec --- test accumE vs accumE -accumBvsE :: FRP f => Event f Dummy -> Event f Int +-- test accumE vs accumB +accumBvsE :: Event t Dummy -> Event t Int accumBvsE input = e1 `union` e2 where e = input `union` input