git.iko.soy/reflex-vty
on bcdd207 help sign in
reflex-vty/src/Control/Monad/TimeMachine.hs
85 lines 3.5 kB history raw
1{-|
2Module: Control.Monad.TimeMachine
3Description: A bi-directional state monad transformer
4-}
5{-# LANGUAGE DeriveFunctor #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE RecursiveDo #-}
9{-# LANGUAGE TupleSections #-}
10{-# LANGUAGE UndecidableInstances #-}
11module Control.Monad.TimeMachine where
13import Control.Monad.Fix
14import Control.Monad.Reader
15import Reflex
16import Reflex.NotReady.Class
18-- | A bi-directional state monad transformer. State changes may be propagated backward ("to the past")
19-- or forward ("to the future"). Backward and forward correspond to the order in which monadic actions
20-- are run.
21-- The 3-tuple that is returned by 'runTimeMachineT' is made up of:
22-- * "back": The value sent by the *first* 'sendToPast'
23-- * "fwd": The value sent by the *last* 'sendToFuture'
24-- * "a": The result
25newtype TimeMachineT back fwd m a = TimeMachineT { runTimeMachineT :: back -> fwd -> m (back, fwd, a) }
26 deriving (Functor)
28instance MonadFix m => Applicative (TimeMachineT back fwd m) where
29 (<*>) = ap
30 pure = return
32instance MonadFix m => Monad (TimeMachineT back fwd m) where
33 x >>= f = TimeMachineT $ \back fwd -> do
34 rec (back'', fwd', a) <- runTimeMachineT x back' fwd
35 (back', fwd'', b) <- runTimeMachineT (f a) back fwd'
36 return (back'', fwd'', b)
37 return v = TimeMachineT $ \back fwd -> return (back, fwd, v)
39instance MonadFix m => MonadFix (TimeMachineT back fwd m) where
40 mfix f = TimeMachineT $ \back fwd -> do
41 rec (back', fwd', a) <- runTimeMachineT (f a) back fwd
42 return (back', fwd', a)
44instance MonadTrans (TimeMachineT back fwd) where
45 lift x = TimeMachineT $ \back fwd -> (back, fwd,) <$> x
47instance (MonadFix m, MonadReader r m) => MonadReader r (TimeMachineT back fwd m) where
48 ask = lift ask
49 local f x = TimeMachineT $ \back fwd -> local f $ runTimeMachineT x back fwd
51instance (MonadFix m, MonadSample t m) => MonadSample t (TimeMachineT back fwd m) where
52 sample = lift . sample
54instance (MonadFix m, MonadHold t m) => MonadHold t (TimeMachineT back fwd m) where
55 buildDynamic a b = lift $ buildDynamic a b
56 headE = lift . headE
58instance (MonadFix m, NotReady t m) => NotReady t (TimeMachineT back fwd m)
60instance (MonadFix m, EventWriter t w m) => EventWriter t w (TimeMachineT back fwd m) where
61 tellEvent = lift . tellEvent
63instance (MonadFix m, MonadBehaviorWriter t w m) => MonadBehaviorWriter t w (TimeMachineT back fwd m) where
64 tellBehavior = lift . tellBehavior
66instance (MonadFix m, MonadDynamicWriter t w m) => MonadDynamicWriter t w (TimeMachineT back fwd m) where
67 tellDyn = lift . tellDyn
69-- | Send a message to the preceding 'recvFromFuture'.
70sendToPast :: Monad m => back -> TimeMachineT back fwd m ()
71sendToPast x = TimeMachineT $ \_ fwd -> return (x, fwd, ())
73-- | Receive a message from the next 'sendToPast'. If it does not exist,
74-- the value received will be the one passed to 'runTimeMachineT'.
75recvFromFuture :: Monad m => TimeMachineT back fwd m back
76recvFromFuture = TimeMachineT $ \back fwd -> return (back, fwd, back)
78-- | Send a message to the next 'recvFromPast'.
79sendToFuture :: Monad m => fwd -> TimeMachineT back fwd m ()
80sendToFuture x = TimeMachineT $ \back _ -> return (back, x, ())
82-- | Receive a message from the preceding 'sendToFuture'. If it does not exist,
83-- the value received will be the one passed to 'runTimeMachineT'.
84recvFromPast :: Monad m => TimeMachineT back fwd m fwd
85recvFromPast = TimeMachineT $ \back fwd -> return (back, fwd, fwd)