module Reactive.Banana.PushIO where
import Reactive.Banana.Model hiding (Event, Behavior, interpret)
import qualified Reactive.Banana.Model as Model
import Reactive.Banana.Vault (Vault)
import qualified Reactive.Banana.Vault as Vault
import Control.Applicative
import Control.Monad.Trans.Identity
import Control.Monad.State
import Control.Monad.Writer
import Data.Dynamic
import Data.IORef
import Data.Maybe
import Data.Monoid
import System.IO.Unsafe
type Store = IO
type Ref a = IORef (Maybe a)
runStore :: Store a -> IO a
runStore = id
newRef :: Store (Ref a)
readRef :: Ref a -> Store (Maybe a)
writeRef :: Ref a -> a -> Store ()
newRef = newIORef Nothing
readRef = readIORef
writeRef ref = writeIORef ref . Just
invalidRef = error "Store: invalidRef. This is an internal bug."
data Cache = Cache {
vault :: Vault
, initializers :: [VaultChanger]
, finalizers :: [VaultChanger] }
type VaultChanger = Run ()
emptyCache :: Cache
emptyCache = Cache Vault.empty [] []
type Compile = StateT Cache Store
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
vault2 <- runVaultChangers (initializers cache) vault1
(x,vault3) <- runStateT m vault2
vault4 <- runVaultChangers (finalizers cache) vault3
return (x,cache{ vault = vault4 })
where
runVaultChangers = execStateT . sequence_
writeVaultKey ref x = do
vault <- get
vault' <- liftIO $ Vault.insert ref x vault
put $ vault'
readVaultKey ref = liftIO . Vault.lookup ref =<< get
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 =<< liftIO . Vault.delete key =<< get
return key
readCacheRef = readVaultKey
writeCacheRef = writeVaultKey
type AccumRef a = Vault.Key a
newAccumRef :: a -> Compile (AccumRef a)
readAccumRef :: AccumRef a -> Run a
updateAccumRef :: AccumRef a -> (a -> a) -> Run a
newAccumRef x = do
ref <- liftIO $ Vault.newKey
vault2 <- liftIO . Vault.insert ref x . vault =<< get
modify $ \cache -> cache { vault = vault2 }
return ref
readAccumRef ref = fromJust <$> readVaultKey ref
updateAccumRef ref f = do
Just x <- readVaultKey ref
let !y = f x
writeVaultKey ref y
return y
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 ()
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) = fromJust <$> readCacheRef temp
updateBehaviorRef (acc, temp) = void . updateAccumRef acc
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
Input :: Typeable a => Channel -> 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
ReadBehavior :: BehaviorRef a -> BehaviorD t a
type Channel = Integer
type Universe = (Channel, Dynamic)
fromUniverse :: Typeable a => Channel -> Universe -> Maybe a
fromUniverse i (j,x) = if i == j then fromDynamic x else Nothing
toUniverse :: Typeable a => Channel -> a -> Universe
toUniverse i x = (i, toDyn x)
type CompileReadBehavior = WriterT [Event Shared ()] Compile
compileReadBehavior :: Event Accum () -> Compile (Event Shared ())
compileReadBehavior e1 = do
(e,es) <- runWriterT (goE e1)
let union e1 e2 = (invalidRef, Union e1 e2)
return $ foldr1 union (e:es)
where
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) = (ref,) <$> (pure $ Input c)
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
r <- lift $ newBehaviorRefAccum x
lift . lift $ writeRef ref r
e <- goE e
tell [(invalidRef, UpdateBehavior r e)]
return r
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) = return [(channel, Input channel)]
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
es <- mes
cached <- forM es $ \(c,_) -> do r <- newCacheRef; return (c,r)
lift $ writeRef ref cached
return $ zipWith (second . (WriteCache . snd)) cached es
second f (a,b) = (a, f b)
map2 = map . second
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
type Path = (Channel, Universe -> Run ())
compilePath :: Event Linear () -> Path
compilePath e = goE e return
where
goE :: Event Linear a -> (a -> Run ()) -> (Channel, Universe -> Run ())
goE (Filter p e) k = goE e $ \x -> when (p x) (k x)
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 -> updateBehaviorRef r x
goE (Reactimate e) _ = goE e $ \x -> liftIO x
goE (ReadCache c ref) k =
(c, \_ -> readCacheRef ref >>= maybe (return ()) k)
goE (WriteCache ref e) k = goE e $ \x -> writeCacheRef ref x >> k x
goE (Input channel) k =
(channel, maybe (error "wrong channel") k . fromUniverse channel)
goB :: Behavior Linear a -> Run a
goB = compileBehaviorEvaluation
compile :: Event Accum () -> IO ([Path], Cache)
compile e = runStore $ runCompile $
return . map compilePath =<< compileUnion =<< compileReadBehavior e
data PushIO
newtype instance Model.Behavior PushIO a = Behavior (Behavior Accum a)
newtype instance Model.Event PushIO a = Event (Event Accum a)
unEvent (Event e) = e
behavior :: BehaviorD Accum a -> Model.Behavior PushIO a
behavior b = Behavior pair
where
pair = unsafePerformIO (fmap (,b) newRef)
event :: EventD Accum a -> Model.Event PushIO a
event e = Event pair
where
pair = unsafePerformIO (fmap (,e) newRef)
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