module FRP.Timeless.Signal
(
Signal(..)
, stepSignal
, lstrict
)
where
import Prelude hiding ((.),id)
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.Fix
import Data.Monoid
import Control.Category
data Signal s m a b where
SId :: Signal s m a a
SConst :: Maybe b -> Signal s m a b
SArr :: (Maybe a -> Maybe b) -> Signal s m a b
SPure :: (s -> Maybe a -> (Maybe b, Signal s m a b)) -> Signal s m a b
SGen :: (Monad m) =>
(s -> Maybe a -> m (Maybe b, Signal s m a b)) -> Signal s m a b
instance (Monad m) => Category (Signal s m) where
id = SId
s2 . s1 = SGen $ \ds mx0 -> do
(mx1, s1') <- stepSignal s1 ds mx0
(mx2, s2') <- stepSignal s2 ds mx1
mx2 `seq` return (mx2, s2'. s1')
instance (Monad m) => Arrow (Signal s m) where
arr f = SArr (fmap f)
first s = SGen f
where
f ds mxy =
let mx = fst <$> mxy
my = snd <$> mxy
mmxs' = stepSignal s ds mx in
liftM (g my) mmxs'
g my (mx', s') =
let mx'y = (,) <$> mx' <*> my in
lstrict (mx'y, first s')
instance (Monad m) => ArrowChoice (Signal s m) where
left s =
SGen $ \ds mmx ->
liftM (fmap Left ***! left) . stepSignal s ds $
case mmx of
Just (Left x) -> Just x
Just (Right x) -> Nothing
Nothing -> Nothing
right s =
SGen $ \ds mmx ->
liftM (fmap Right ***! right) . stepSignal s ds $
case mmx of
Just (Left x) -> Nothing
Just (Right x) -> Just x
Nothing -> Nothing
sl +++ sr =
SGen $ \ds mmx ->
case mmx of
Just (Left x) -> do
liftM2 (\ (mx,sl')(_,sr') -> lstrict (fmap Left mx, sl' +++ sr'))
(stepSignal sl ds (Just x)) (stepSignal sr ds Nothing)
Just (Right x) -> do
liftM2 (\ (_,sl')(mx,sr') -> lstrict (fmap Right mx, sl' +++ sr'))
(stepSignal sl ds Nothing) (stepSignal sr ds (Just x))
Nothing ->
liftM2 (\ (_,sl')(_,sr') -> lstrict (Nothing, sl' +++ sr'))
(stepSignal sl ds Nothing) (stepSignal sr ds Nothing)
sl ||| sr =
SGen $ \ds mmx ->
case mmx of
Just (Left x) -> do
liftM2 (\(mx,sl')(_,sr') -> lstrict (mx, sl' ||| sr'))
(stepSignal sl ds (Just x)) (stepSignal sr ds Nothing)
Just (Right x) -> do
liftM2 (\(_,sl')(mx,sr') -> lstrict (mx, sl' ||| sr'))
(stepSignal sl ds Nothing) (stepSignal sr ds (Just x))
Nothing -> do
liftM2 (\(_,sl')(_,sr') -> lstrict (Nothing, sl' ||| sr'))
(stepSignal sl ds Nothing) (stepSignal sr ds Nothing)
instance (MonadFix m) => ArrowLoop (Signal s m) where
loop s =
SGen $ \ds mx ->
liftM (fmap fst ***! loop) .
mfix $ \ ~(mx',_) ->
let d | Just (_,d) <- mx' = d
| otherwise = error "Feedback broken by inhibition"
in stepSignal s ds (fmap (,d) mx)
instance (Monad m) => Functor (Signal s m a) where
fmap f SId = SArr $ fmap f
fmap f (SConst mx) = SConst $ fmap f mx
fmap f (SArr g) = SArr $ fmap f . g
fmap f (SPure g) = SPure $ \ds -> (fmap f ***! fmap f) . g ds
instance (Monad m) => Applicative (Signal s m a) where
pure = SConst . Just
sf <*> sx =
SGen $ \ds mx ->
liftM2 (\(mf, sf) (mx, sx) -> lstrict (mf <*> mx, sf <*> sx))
(stepSignal sf ds mx)
(stepSignal sx ds mx)
stepSignal :: (Monad m) =>
Signal s m a b
-> s
-> Maybe a
-> m (Maybe b, Signal s m a b)
stepSignal s@(SId) _ mx = return (mx, s)
stepSignal s@(SConst mx) _ _ = return (mx, s)
stepSignal s@(SArr f) _ mx = return (f mx, s)
stepSignal s@(SPure f) ds mx = return (f ds mx)
stepSignal s@(SGen f) ds mx = f ds mx
(&&&!) :: (a -> b) -> (a -> c) -> (a -> (b, c))
(&&&!) f g x' =
let (x, y) = (f x', g x')
in x `seq` (x, y)
(***!) :: (a -> c) -> (b -> d) -> ((a, b) -> (c, d))
(***!) f g (x', y') =
let (x, y) = (f x', g y')
in x `seq` (x, y)
lstrict :: (a,b) -> (a,b)
lstrict (x,y) = x `seq` (x,y)