module Reactive.Banana.Internal.PulseLatch0 where
import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Trans.RWS
import Control.Monad.IO.Class
import Data.IORef
import Data.Monoid (Endo(..))
import Control.Concurrent.MVar
import Reactive.Banana.Internal.Cached
import Reactive.Banana.Internal.InputOutput
import qualified Reactive.Banana.Internal.DependencyGraph as Deps
import Reactive.Banana.Frameworks.AddHandler
import Data.Hashable
import Data.Unique.Really
import qualified Data.Vault as Vault
import Data.Functor.Identity
import System.IO.Unsafe
import Debug.Trace
type Deps = Deps.Deps
debug s m = m
debugIO s m = liftIO (putStrLn s) >> m
data Graph = Graph
{ grPulse :: Values
, grLatch :: Values
, grCache :: Values
, grDeps :: Deps SomeNode
, grInputs :: [Input]
}
type Values = Vault.Vault
type Key = Vault.Key
type Input =
( SomeNode
, InputValue -> Values -> Values
)
emptyGraph :: Graph
emptyGraph = Graph
{ grPulse = Vault.empty
, grLatch = Vault.empty
, grCache = Vault.empty
, grDeps = Deps.empty
, grInputs = [(P alwaysP, const id)]
}
evaluateGraph :: [InputValue] -> Graph -> Setup Graph
evaluateGraph inputs = fmap snd
. uncurry (runNetworkAtomicT . performEvaluation)
. buildEvaluationOrder
. writeInputValues inputs
runReactimates (graph,reactimates) =
sequence_ [action | pulse <- reactimates
, Just action <- [readPulseValue pulse graph]]
readPulseValue p = getValueP p . grPulse
writeInputValues inputs graph = graph { grPulse =
concatenate [f x | (_,f) <- grInputs graph, x <- inputs] Vault.empty }
concatenate :: [a -> a] -> (a -> a)
concatenate = foldr (.) id
performEvaluation :: [SomeNode] -> NetworkSetup ()
performEvaluation = mapM_ evaluate
where
evaluate (P p) = evaluateP p
evaluate (L l) = liftNetwork $ evaluateL l
buildEvaluationOrder :: Graph -> ([SomeNode], Graph)
buildEvaluationOrder graph = (Deps.topologicalSort $ grDeps graph, graph)
type NetworkT = RWST Graph (Endo Graph) Graph
type Network = NetworkT Identity
type NetworkSetup = NetworkT Setup
liftNetwork :: Monad m => Network a -> NetworkT m a
liftNetwork m = RWST $ \r s -> return . runIdentity $ runRWST m r s
instance (MonadFix m, Functor m) => HasVault (NetworkT m) where
retrieve key = Vault.lookup key . grCache <$> get
write key a = modify $ \g -> g { grCache = Vault.insert key a (grCache g) }
runNetworkAtomicT :: MonadFix m => NetworkT m a -> Graph -> m (a, Graph)
runNetworkAtomicT m g1 = mdo
(x, g2, w2) <- runRWST m g3 g1
let g3 = appEndo w2 g2
return (x, g3)
writePulse :: Key (Maybe a) -> Maybe a -> Network ()
writePulse key x =
modify $ \g -> g { grPulse = Vault.insert key x $ grPulse g }
readPulse :: Key (Maybe a) -> Network (Maybe a)
readPulse key = (getPulse key . grPulse) <$> get
getPulse key = join . Vault.lookup key
writeLatch :: Key a -> a -> Network ()
writeLatch key x =
modify $ \g -> g { grLatch = Vault.insert key x $ grLatch g }
readLatch :: Key a -> Network a
readLatch key = (maybe err id . Vault.lookup key . grLatch) <$> get
where err = error "readLatch: latch not initialized!"
writeLatchFuture :: Key a -> a -> Network ()
writeLatchFuture key x =
tell $ Endo $ \g -> g { grLatch = Vault.insert key x $ grLatch g }
readLatchFuture :: Key a -> Network a
readLatchFuture key = (maybe err id . Vault.lookup key . grLatch) <$> ask
where err = error "readLatchFuture: latch not found!"
dependOn :: SomeNode -> SomeNode -> Network ()
dependOn x y = modify $ \g -> g { grDeps = Deps.dependOn x y $ grDeps g }
dependOns :: SomeNode -> [SomeNode] -> Network ()
dependOns x = mapM_ $ dependOn x
addInput :: Key (Maybe a) -> Pulse a -> InputChannel a -> Network ()
addInput key pulse channel =
modify $ \g -> g { grInputs = (P pulse, input) : grInputs g }
where
input value
| getChannel value == getChannel channel =
Vault.insert key (fromValue channel value)
| otherwise = id
type Reactimate = Pulse (IO ())
type SetupConf =
( [Reactimate]
, [AddHandler [InputValue]]
, [IO ()]
)
type Setup = RWST () SetupConf () IO
addReactimate :: Reactimate -> Setup ()
addReactimate x = tell ([x],[],[])
liftIOLater :: IO () -> Setup ()
liftIOLater x = tell ([],[],[x])
discardSetup :: Setup a -> IO a
discardSetup m = do
(a,_,_) <- runRWST m () ()
return a
registerHandler :: AddHandler [InputValue] -> Setup ()
registerHandler x = tell ([],[x],[])
runSetup :: Callback -> Setup a -> IO (a, [Reactimate])
runSetup callback m = do
(a,_,(reactimates,addHandlers,liftIOLaters)) <- runRWST m () ()
mapM_ ($ callback) addHandlers
sequence_ liftIOLaters
return (a,reactimates)
type Callback = [InputValue] -> IO ()
data EventNetwork = EventNetwork
{ actuate :: IO ()
, pause :: IO ()
}
compile :: NetworkSetup () -> IO EventNetwork
compile setup = do
actuated <- newIORef False
rstate <- newEmptyMVar
let
whenFlag flag action = readIORef flag >>= \b -> when b action
callback inputs = whenFlag actuated $ do
state0 <- takeMVar rstate
(reactimates, state1)
<- step inputs state0
putMVar rstate state1
reactimates
step inputs (g0,r0) = do
(g2,r1) <- runSetup callback $ evaluateGraph inputs g0
let
r2 = r0 ++ r1
runner = runReactimates (g2,r2)
return (runner, (g2,r2))
((_,graph), reactimates)
<- runSetup callback $ runNetworkAtomicT setup emptyGraph
putMVar rstate (graph,reactimates)
return $ EventNetwork
{ actuate = writeIORef actuated True
, pause = writeIORef actuated False
}
interpret :: (Pulse a -> NetworkSetup (Pulse b)) -> [Maybe a] -> IO [Maybe b]
interpret f xs = do
i <- newInputChannel
(result,graph) <- discardSetup $
runNetworkAtomicT (f =<< liftNetwork (inputP i)) emptyGraph
let
step Nothing g0 = return (Nothing,g0)
step (Just a) g0 = do
g1 <- discardSetup $ evaluateGraph [toValue i a] g0
return (readPulseValue result g1, g1)
mapAccumM step graph xs
mapAccumM :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m [b]
mapAccumM _ _ [] = return []
mapAccumM f s0 (x:xs) = do
(b,s1) <- f x s0
bs <- mapAccumM f s1 xs
return (b:bs)
data Pulse a = Pulse
{ evaluateP :: NetworkSetup ()
, getValueP :: Values -> Maybe a
, uidP :: Unique
}
data Latch a = Latch
{ evaluateL :: Network ()
, valueL :: Network a
, futureL :: Network a
, uidL :: Unique
}
valueP :: Pulse a -> Network (Maybe a)
valueP p = getValueP p . grPulse <$> get
pulse' :: NetworkSetup (Maybe a) -> Network (Pulse a)
pulse' eval = unsafePerformIO $ do
key <- Vault.newKey
uid <- newUnique
return $ return $ Pulse
{ evaluateP = liftNetwork . writePulse key =<< eval
, getValueP = getPulse key
, uidP = uid
}
pulse :: Network (Maybe a) -> Network (Pulse a)
pulse = pulse' . liftNetwork
neverP :: Network (Pulse a)
neverP = debug "neverP" $ unsafePerformIO $ do
uid <- newUnique
return $ return $ Pulse
{ evaluateP = return ()
, getValueP = const Nothing
, uidP = uid
}
inputP :: InputChannel a -> Network (Pulse a)
inputP channel = debug "inputP" $ unsafePerformIO $ do
key <- Vault.newKey
uid <- newUnique
return $ do
let
p = Pulse
{ evaluateP = return ()
, getValueP = getPulse key
, uidP = uid
}
addInput key p channel
return p
alwaysP :: Pulse ()
alwaysP = debug "alwaysP" $ unsafePerformIO $ do
uid <- newUnique
return $ Pulse
{ evaluateP = return ()
, getValueP = return $ Just ()
, uidP = uid
}
latch :: a -> a -> Network (Maybe a) -> Network (Latch a)
latch now future eval = unsafePerformIO $ do
key <- Vault.newKey
uid <- newUnique
return $ do
writeLatch key now
writeLatchFuture key future
return $ Latch
{ evaluateL = maybe (return ()) (writeLatchFuture key) =<< eval
, valueL = readLatch key
, futureL = readLatchFuture key
, uidL = uid
}
pureL :: a -> Network (Latch a)
pureL a = debug "pureL" $ unsafePerformIO $ do
uid <- liftIO newUnique
return $ return $ Latch
{ evaluateL = return ()
, valueL = return a
, futureL = return a
, uidL = uid
}
data SomeNode = forall a. P (Pulse a) | forall a. L (Latch a)
instance Eq SomeNode where
(L x) == (L y) = uidL x == uidL y
(P x) == (P y) = uidP x == uidP y
_ == _ = False
instance Hashable SomeNode where
hashWithSalt s (P p) = hashWithSalt s . hashUnique $ uidP p
hashWithSalt s (L l) = hashWithSalt s . hashUnique $ uidL l
stepperL :: a -> Pulse a -> Network (Latch a)
stepperL a p = debug "stepperL" $ do
x <- latch a a (valueP p)
L x `dependOn` P p
return x
accumP :: a -> Pulse (a -> a) -> Network (Pulse a)
accumP a p = debug "accumP" $ mdo
x <- stepperL a result
result <- pulse $ eval <$> valueL x <*> valueP p
P result `dependOn` P p
return result
where
eval _ Nothing = Nothing
eval x (Just f) = let y = f x in y `seq` Just y
applyP :: Latch (a -> b) -> Pulse a -> Network (Pulse b)
applyP f x = debug "applyP" $ do
result <- pulse $ fmap <$> valueL f <*> valueP x
P result `dependOn` P x
return result
tagFuture :: Latch a -> Pulse b -> Network (Pulse a)
tagFuture f x = debug "tagFuture" $ do
result <- pulse $ fmap . const <$> futureL f <*> valueP x
P result `dependOn` P x
return result
mapP :: (a -> b) -> Pulse a -> Network (Pulse b)
mapP f p = debug "mapP" $ do
result <- pulse $ fmap f <$> valueP p
P result `dependOn` P p
return result
filterJustP :: Pulse (Maybe a) -> Network (Pulse a)
filterJustP p = debug "filterJustP" $ do
result <- pulse $ join <$> valueP p
P result `dependOn` P p
return result
unionWith :: (a -> a -> a) -> Pulse a -> Pulse a -> Network (Pulse a)
unionWith f px py = debug "unionWith" $ do
result <- pulse $ eval <$> valueP px <*> valueP py
P result `dependOns` [P px, P py]
return result
where
eval (Just x) (Just y) = Just (f x y)
eval (Just x) Nothing = Just x
eval Nothing (Just y) = Just y
eval Nothing Nothing = Nothing
applyL :: Latch (a -> b) -> Latch a -> Network (Latch b)
applyL lf lx = debug "applyL" $ do
let eval = ($) <$> futureL lf <*> futureL lx
future <- eval
now <- ($) <$> valueL lf <*> valueL lx
result <- latch now future $ fmap Just eval
L result `dependOns` [L lf, L lx]
return result
executeP :: Pulse (NetworkSetup a) -> Network (Pulse a)
executeP pn = do
result <- pulse' $ do
mp <- liftNetwork $ valueP pn
case mp of
Just p -> Just <$> p
Nothing -> return Nothing
P result `dependOn` P pn
return result
switchP :: Pulse (Pulse a) -> Network (Pulse a)
switchP pp = mdo
never <- neverP
lp <- stepperL never pp
let
eval = do
newPulse <- valueP pp
case newPulse of
Nothing -> return ()
Just p -> P result `dependOn` P p
valueP =<< valueL lp
result <- pulse eval
P result `dependOns` [L lp, P pp]
return result
switchL :: Latch a -> Pulse (Latch a) -> Network (Latch a)
switchL l p = mdo
ll <- stepperL l p
let
switchTo l = do
L result `dependOn` L l
futureL l
eval = do
mp <- valueP p
case mp of
Nothing -> futureL =<< valueL ll
Just l -> switchTo l
now <- valueL l
future <- futureL l
result <- latch now future $ Just <$> eval
L result `dependOns` [L l, P p]
return result