module Control.FRPNow.Core(
Event,Behavior, never, switch, whenJust, futuristic,
Now, async, asyncOS, callback, sampleNow, planNow, sync,
runNowMaster,
initNow) where
import Control.Concurrent.Chan
import Control.Applicative hiding (empty,Const)
import Control.Monad hiding (mapM_)
import Control.Monad.IO.Class
import Control.Monad.Reader hiding (mapM_)
import Control.Monad.Writer hiding (mapM_)
import Data.IORef
import Control.FRPNow.Private.Ref
import Control.FRPNow.Private.PrimEv
import System.IO.Unsafe
import Debug.Trace
import Prelude
data Event a
= Never
| Occ a
| E (M (Event a))
runE :: Event a -> M (Event a)
runE Never = return Never
runE (Occ x) = return (Occ x)
runE (E m) = m
instance Monad Event where
return = Occ
e >>= f = memoE (e `bindE` f)
never :: Event a
never = Never
bindE :: Event a -> (a -> Event b) -> Event b
Never `bindE` _ = Never
(Occ x) `bindE` f = f x
(E m) `bindE` f = E $ bindEM m f
bindEM :: M (Event a) -> (a -> Event b) -> M (Event b)
m `bindEM` f =
m >>= \r -> case r of
Never -> return Never
Occ x -> runE (f x)
E m' -> return (E $ m' `bindEM` f)
memoEIO :: Event a -> IO (Event a)
memoEIO einit =
do r <- newIORef einit
return (usePrevE r)
usePrevE :: IORef (Event a) -> Event a
usePrevE r = E $
do e <- liftIO (readIORef r)
res <- runE e
liftIO (writeIORef r res)
return res
memoE :: Event a -> Event a
memoE Never = Never
memoE (Occ x) = Occ x
memoE e = unsafePerformIO $ memoEIO e
data Behavior a = B (M (a, Event (Behavior a)))
| Const a
runB :: Behavior a -> M (a, Event (Behavior a))
runB (B m) = m
runB (Const a) = return (a, never)
switch' :: Behavior a -> Event (Behavior a) -> Behavior a
switch' b Never = b
switch' _ (Occ b) = b
switch' (Const x) (E em) = B $
em >>= \r -> case r of
Never -> return (x,never)
Occ b' -> runB b'
E em' -> return (x, E em')
switch' (B bm) (E em) = B $
em >>= \r ->
case r of
Never -> bm
Occ b' -> runB b'
E em' ->
do (h,t) <- bm
return $ case t of
Occ _ -> error "switch already occured!"
Never -> (h, E em')
E tm -> (h, switchEM tm em')
switchEM :: M (Event (Behavior a)) -> M (Event (Behavior a)) -> Event (Behavior a)
switchEM lm rm = E $
rm >>= \case
Never -> lm
Occ b -> return (Occ b)
E rm' -> lm >>= return . \case
Never -> E rm'
Occ b -> Occ (b `switch'` E rm')
E lm' -> switchEM lm' rm'
bindB :: Behavior a -> (a -> Behavior b) -> Behavior b
bindB (Const x) f = f x
bindB (B m) f = B $
do (h,t) <- m
case f h of
Const x -> return (x, (`bindB` f) <$> t)
B n -> do (hn,tn) <- n
tn <- runE tn
return $ case (t,tn) of
(_, Occ _) -> error "switch already occured!"
(Occ _ , _) -> error "switch already occured!"
(Never , e) -> (hn, e)
(e, Never ) -> (hn, (`bindB` f) <$> t)
(e, E tm) -> (hn, switchEM tm (runE ((`bindB` f) <$> e)) )
whenJust' :: Behavior (Maybe a) -> Behavior (Event a)
whenJust' (Const Nothing) = pure never
whenJust' (Const (Just x)) = pure (pure x)
whenJust' (B m) = B $
do (h, t) <- m
case h of
Just x -> return (return x, whenJust' <$> t)
Nothing ->
do en <- planM (runB . whenJust' <$> t)
return (en >>= fst, en >>= snd)
whenJustSample' :: Behavior (Maybe (Behavior a)) -> Behavior (Event a)
whenJustSample' (Const Nothing) = pure never
whenJustSample' (Const (Just x)) = B $ do v <- fst <$> runB x; return (pure v, never)
whenJustSample' (B bm) = B $
do (h, t) <- bm
case h of
Just x -> do v <- fst <$> runB x; return (pure v, whenJustSample' <$> t)
Nothing -> do en <- planM (runB . whenJustSample' <$> t)
return (en >>= fst, never)
instance Monad Behavior where
return x = B $ return (x, never)
m >>= f = memoB (m `bindB` f)
instance MonadFix Behavior where
mfix f = B $ mfix $ \(~(h,_)) ->
do (h',t) <- runB (f h)
return (h', mfix f <$ t )
switch :: Behavior a -> Event (Behavior a) -> Behavior a
switch b e = memoB (switch' b e)
whenJust :: Behavior (Maybe a) -> Behavior (Event a)
whenJust b = (whenJust' b)
whenJustSample :: Behavior (Maybe (Behavior a)) -> Behavior (Event a)
whenJustSample b = memoB (whenJustSample' b)
futuristic :: Behavior (Event a) -> Behavior (Event a)
futuristic b = B $ do e <- makeLazy (joinEm <$> runB b)
return (fst <$> e,snd <$> e)
where joinEm (e,es) = (,) <$> e <*> es
unrunB :: (a,Event (Behavior a)) -> Behavior a
unrunB (h, Never) = Const h
unrunB (h,t) = B $
runE t >>= \x -> case x of
Occ b -> runB b
t' -> return (h,t')
memoBIO :: Behavior a -> IO (Behavior a)
memoBIO einit =
do r <- newIORef einit
return (usePrevB r)
usePrevB :: IORef (Behavior a) -> Behavior a
usePrevB r = B $
do b <- liftIO (readIORef r)
res <- runB b
liftIO (writeIORef r (unrunB res))
return res
memoB :: Behavior a -> Behavior a
memoB b@(Const _) = b
memoB b = unsafePerformIO $ memoBIO b
data Env = Env {
plansRef :: IORef Plans,
laziesRef :: IORef Lazies,
clock :: Clock }
type M = ReaderT Env IO
newtype Now a = Now { getNow :: M a } deriving (Functor,Applicative,Monad, MonadFix)
sampleNow :: Behavior a -> Now a
sampleNow (B m) = Now $ fst <$> m
callback :: Now (Event a, a -> IO ())
callback = Now $ do c <- clock <$> ask
(pe, cb) <- liftIO $ callbackp c
return (toE pe,cb)
sync :: IO a -> Now a
sync m = Now $ liftIO m
async :: IO a -> Now (Event a)
async m = Now $ do c <- clock <$> ask
toE <$> liftIO (spawn c m)
asyncOS :: IO a -> Now (Event a)
asyncOS m = Now $ do c <- clock <$> ask
toE <$> liftIO (spawnOS c m)
toE :: PrimEv a -> Event a
toE p = E toEM where
toEM = (toEither . (p `observeAt`) <$> getRound)
toEither Nothing = E toEM
toEither (Just x) = Occ x
getRound :: M Round
getRound = ReaderT $ \env -> curRound (clock env)
type Plan a = IORef (Either (Event (M a)) a)
planToEv :: Plan a -> Event a
planToEv ref = self where
self = E $
liftIO (readIORef ref) >>= \pstate ->
case pstate of
Right x -> return (Occ x)
Left ev -> runE ev >>= \estate ->
case estate of
Occ m -> do x <- m
liftIO $ writeIORef ref (Right x)
return $ Occ x
ev' -> do liftIO $ writeIORef ref (Left ev')
return self
data SomePlan = forall a. SomePlan (Ref (Plan a))
type Plans = [SomePlan]
type Lazies = [Lazy]
data Lazy = forall a. Lazy (M (Event a)) (IORef (Event a))
makeLazy :: M (Event a) -> M (Event a)
makeLazy m = ReaderT $ \env ->
do n <- curRound (clock env)
r <- newIORef undefined
modifyIORef (laziesRef env) (Lazy m r :)
return (readLazyState n r)
readLazyState :: Round -> IORef (Event a) -> Event a
readLazyState n r =
let x = E $
do m <- getRound
case compare n m of
LT -> liftIO (readIORef r) >>= runE
EQ -> return x
GT -> error "Round seems to decrease.."
in x
planM :: Event (M a) -> M (Event a)
planM e = plan makeWeakIORef e
planNow :: Event (Now a) -> Now (Event a)
planNow e = Now $ plan makeStrongRef (getNow <$> e)
plan :: (forall v. IORef v -> IO (Ref (IORef v))) -> Event (M a) -> M (Event a)
plan makeRef e =
do p <- liftIO (newIORef $ Left e)
let ev = planToEv p
pr <- liftIO (makeRef p)
addPlan pr
return ev
addPlan :: Ref (Plan a) -> M ()
addPlan p = ReaderT $ \env -> modifyIORef (plansRef env) (SomePlan p :)
initNow ::
(IO (Maybe a) -> IO ())
-> Now (Event a)
-> IO ()
initNow schedule (Now m) =
mdo c <- newClock (schedule it)
pr <- newIORef []
lr <- newIORef []
let env = Env pr lr c
let it = runReaderT (iteration e) env
e <- runReaderT m env
schedule (runReaderT (iterationMeat e) env)
return ()
iteration :: Event a -> M (Maybe a)
iteration ev =
newRoundM >>= \new ->
if new
then iterationMeat ev
else return Nothing
iterationMeat ev =
do er <- runE ev
case er of
Occ x -> return (Just x)
_ -> tryPlans >> runLazies >> return Nothing
newRoundM :: M Bool
newRoundM = ReaderT $ \env -> newRound (clock env)
tryPlans :: M ()
tryPlans = ReaderT $ tryEm where
tryEm env =
do pl <- readIORef (plansRef env)
writeIORef (plansRef env) []
runReaderT (mapM_ tryPlan (reverse pl)) env
tryPlan (SomePlan pr) =
do
ps <- liftIO (deRef pr)
case ps of
Just p -> do eres <- runE (planToEv p)
case eres of
Occ x -> return ()
_ -> addPlan pr
Nothing -> return ()
runLazies :: M ()
runLazies = ReaderT $ runEm where
runEm env =
readIORef (laziesRef env) >>= \pl ->
if null pl
then return ()
else do writeIORef (laziesRef env) []
runReaderT (mapM_ runLazy (reverse pl)) env
runEm env where
runLazy (Lazy m r) = do e <- m
x <- runE e
case x of
Occ _ -> error "Forced lazy was not lazy!"
e' -> liftIO $ writeIORef r e'
runNowMaster :: Now (Event a) -> IO a
runNowMaster m =
do chan <- newChan
let enqueue m = writeChan chan m
initNow enqueue m
loop chan where
loop chan =
do m <- readChan chan
mr <- m
case mr of
Just x -> return x
Nothing -> loop chan
instance Functor Behavior where
fmap = liftM
instance Applicative Behavior where
pure = return
(<*>) = ap
instance Functor Event where
fmap = liftM
instance Applicative Event where
pure = return
(<*>) = ap