module Reactive.Banana.Prim.Types where
import Control.Monad.Trans.Class
import Control.Monad.Trans.RWS.Lazy
import Control.Monad.Trans.State
import Data.Functor.Identity
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import Data.Hashable
import Data.Monoid
import Data.Unique.Really
import qualified Data.Vault.Lazy as Lazy
import System.IO.Unsafe (unsafePerformIO)
import Reactive.Banana.Prim.Cached
import qualified Reactive.Banana.Prim.Dated as Dated
import qualified Reactive.Banana.Prim.Dependencies as Deps
type Deps = Deps.Deps
data Graph = Graph
{ grDeps :: Deps SomeNode
, grCache :: Lazy.Vault
, grAlwaysP :: Pulse ()
, grOutputCount :: !Position
}
type Position = Integer
instance Show Graph where show = showDeps . grDeps
data Network = Network
{ nGraph :: Graph
, nLatchValues :: Dated.Vault
, nTime :: Dated.Time
}
instance Show Network where show = show . nGraph
type Inputs = (Lazy.Vault, [SomeNode])
type EvalNetwork a = Network -> IO (a, Network)
type Step = EvalNetwork (IO ())
updateGraph f = \s -> s { nGraph = f (nGraph s) }
updateLatchValues f = \s -> s { nLatchValues = f (nLatchValues s) }
updateDeps f = \s -> s { grDeps = f (grDeps s) }
updateCache f = \s -> s { grCache = f (grCache s) }
updateOutputCount f = \s -> s { grOutputCount = f (grOutputCount s) }
emptyGraph :: Graph
emptyGraph = unsafePerformIO $ do
uid <- newUnique
return $ Graph
{ grDeps = Deps.empty
, grCache = Lazy.empty
, grAlwaysP = Pulse
{ evaluateP = return Deps.Children
, getValueP = const $ Just ()
, uidP = uid
, nameP = "alwaysP"
}
, grOutputCount = 0
}
emptyNetwork :: Network
emptyNetwork = Network
{ nGraph = emptyGraph
, nLatchValues = Dated.empty
, nTime = Dated.beginning
}
type BuildT = RWST () BuildConf Network
type Build = BuildT Identity
type BuildIO = BuildT IO
type BuildConf = [IO ()]
data Pulse a = Pulse
{ evaluateP :: EvalP Deps.Continue
, getValueP :: Lazy.Vault -> Maybe a
, uidP :: Unique
, nameP :: String
}
data Latch a = Latch
{ getValueL :: Future (Dated.Box a)
}
data LatchWrite = LatchWrite
{ evaluateL :: EvalP EvalL
, uidL :: Unique
}
data Output = Output
{ evaluateO :: EvalP EvalO
, uidO :: Unique
, positionO :: Position
}
type EvalP = StateT Lazy.Vault BuildIO
type Future = Dated.Dated
type EvalL = Endo Dated.Vault
type EvalO = Future (IO ())
nop :: EvalO
nop = return $ return ()
data SomeNode
= forall a. P (Pulse a)
| L LatchWrite
| O Output
instance Show SomeNode where show = show . hash
instance Eq SomeNode where
(P x) == (P y) = uidP x == uidP y
(L x) == (L y) = uidL x == uidL y
(O x) == (O y) = uidO x == uidO y
_ == _ = False
uid :: SomeNode -> Unique
uid (P x) = uidP x
uid (L x) = uidL x
uid (O x) = uidO x
instance Hashable SomeNode where
hashWithSalt s = hashWithSalt s . uid
showDeps :: Deps SomeNode -> String
showDeps deps = unlines $
[ detail node ++
if null children then "" else " -> " ++ unwords (map short children)
| node <- nodes
, let children = Deps.children deps node
]
where
allChildren = Deps.allChildren deps
nodes = Set.toList . Set.fromList $
concat [x : xs | (x,xs) <- allChildren]
dictionary = Map.fromList $ zip nodes [1..]
short node = maybe "X" show $ Map.lookup node dictionary
detail (P x) = "P " ++ nameP x ++ " " ++ short (P x)
detail (L x) = "L " ++ short (L x)
detail (O x) = "O " ++ short (O x)