module Reactive.Banana.Internal.AST where
import Control.Applicative
import qualified Data.Vault as Vault
import System.IO.Unsafe
import Data.Unique.Really
import Data.Hashable
import qualified Reactive.Banana.Model as Model
import Reactive.Banana.Internal.InputOutput
type family Event t :: * -> *
type family Behavior t :: * -> *
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
InputPure :: InputChannel (Model.Event a)
-> EventD t a
data BehaviorD t :: * -> * where
Stepper :: a -> Event t a -> BehaviorD t a
InputB :: InputChannel a -> BehaviorD t a
data Pair f g a = Pair !(f a) (g a)
fstPair :: Pair f g a -> f a
fstPair (Pair x y) = x
data Expr
type instance Event Expr = Pair Node (EventD Expr)
type instance Behavior Expr = Pair Node (BehaviorD Expr)
shareE :: EventD Expr a -> Event Expr a
shareE e = pair
where
pair = unsafePerformIO (fmap (flip Pair e) newNode)
shareB :: BehaviorD Expr a -> Behavior Expr a
shareB b = pair
where
pair = unsafePerformIO (fmap (flip Pair b) newNode)
unE = id; unB = id
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."
mapB f = applyB (pureB f)
data Node a
= Node
{
keyValue :: !(Vault.Key a)
, keyFormula :: !(Vault.Key (FormulaD Nodes a))
, keyOrder :: !Unique
, keyModelE :: !(Vault.Key (Model.Event a))
, keyModelB :: !(Vault.Key (Model.Behavior a))
}
newNode :: IO (Node a)
newNode = Node
<$> Vault.newKey <*> Vault.newKey <*> newUnique
<*> Vault.newKey <*> Vault.newKey
data Nodes
type instance Event Nodes = Node
type instance Behavior Nodes = Node
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
class ToFormula t where
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
data SomeFormula t where
Exists :: Formula t a -> SomeFormula t
type SomeNode = SomeFormula Nodes
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)