module Reactive.Banana.Internal.InterpretModel (
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
import Reactive.Banana.Model as Model hiding (interpretModel)
type Eval = State Vault.Vault
interpretModel
:: (AST.Event AST.Expr a -> AST.Event AST.Expr b)
-> Model.Event a -> IO (Model.Event b)
interpretModel f input = do
i0 <- newInputChannel
let
evalE :: AST.EventD AST.Expr a -> Eval (Model.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 (Model.Behavior a)
evalB (AST.Stepper x e) = stepperB x <$> goE e
evalB _ =
error "Reactive.Banana.PushIO.interpretModel: internal error: B"
goE :: AST.Event AST.Expr a -> Eval (Model.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 (Model.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