module Control.Varying.Spline (
Spline,
SplineT(..),
runSplineT,
runSplineE,
scanSpline,
outputStream,
resultStream,
step,
effect,
fromEvent,
untilEvent,
untilEvent_,
_untilEvent,
_untilEvent_,
race,
raceMany,
merge,
capture,
mapOutput,
adjustInput,
) where
import Control.Varying.Core
import Control.Varying.Event
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Control.Applicative
import Data.Functor.Identity
import Data.Monoid
data SplineT a b m c = Pass c
| SplineT (VarT m a (b, Event c))
runSplineT :: (Applicative m, Monad m) => SplineT a b m c -> b -> VarT m a (b, Event c)
runSplineT (Pass c) b = pure (b, Event c)
runSplineT (SplineT v) _ = VarT $ \a -> do
(o@(b,ec), v1) <- runVarT v a
let !s = case ec of
NoEvent -> SplineT v1
Event c -> Pass c
return (o, runSplineT s b)
runSplineE :: Monad m => SplineT a b m c -> a -> m (Either b c, SplineT a b m c)
runSplineE (Pass c) _ = return (Right c, Pass c)
runSplineE (SplineT v) a = do
((b, ev), v1) <- runVarT v a
return $ case ev of
NoEvent -> (Left b, SplineT v1)
Event c -> (Right c, Pass c)
instance (Applicative m, Monad m) => Functor (SplineT a b m) where
fmap f (Pass c) = Pass $ f c
fmap f (SplineT v) = SplineT (((f <$>) <$>) <$> v)
instance (Applicative m, Monad m) => Applicative (SplineT a b m) where
pure = Pass
(Pass f) <*> (Pass x) = Pass $ f x
(Pass f) <*> (SplineT v) = f <$> SplineT v
(SplineT vf) <*> (Pass x) = ($ x) <$> SplineT vf
sf <*> sx = do
f <- sf
x <- sx
return $ f x
instance (Applicative m, Monad m) => Monad (SplineT a b m) where
return = Pass
(Pass x) >>= f = f x
(SplineT v) >>= f = SplineT $ VarT $ \a -> do
((b, ec), v1) <- runVarT v a
case ec of
NoEvent -> return ((b, NoEvent), runSplineT (SplineT v1 >>= f) b)
Event c -> runVarT (runSplineT (f c) b) a
#if MIN_VERSION_base(4,8,0)
instance Monoid b => MonadTrans (SplineT a b) where
lift = effect mempty
instance (Monoid b, Applicative m, Monad m, MonadIO m) => MonadIO (SplineT a b m) where
liftIO = lift . liftIO
#endif
scanSpline :: (Applicative m, Monad m)
=> SplineT a b m c -> b -> [a] -> m [b]
scanSpline s b = fmap fst <$> scanVar (outputStream s b)
type Spline a b c = SplineT a b Identity c
outputStream :: (Applicative m, Monad m)
=> SplineT a b m c -> b -> VarT m a b
outputStream s b = fst <$> runSplineT s b
resultStream :: (Applicative m, Monad m)
=> SplineT a b m c -> b -> VarT m a (Event c)
resultStream s b = snd <$> runSplineT s b
fromEvent :: (Applicative m, Monad m) => VarT m a (Event b) -> SplineT a (Event b) m b
fromEvent ve = SplineT $ f <$> ve
where f e = (e,e)
untilEvent :: (Applicative m, Monad m)
=> VarT m a b -> VarT m a (Event c)
-> SplineT a b m (b,c)
untilEvent v ve = SplineT $ f <$> v <*> ve
where f b ec = (b, (b,) <$> ec)
untilEvent_ :: (Applicative m, Monad m)
=> VarT m a b -> VarT m a (Event c)
-> SplineT a b m b
untilEvent_ v ve = SplineT $ f <$> v <*> ve
where f b ec = (b, b <$ ec)
_untilEvent :: (Applicative m, Monad m)
=> VarT m a b -> VarT m a (Event c)
-> SplineT a b m c
_untilEvent v ve = snd <$> untilEvent v ve
_untilEvent_ :: (Applicative m, Monad m)
=> VarT m a b -> VarT m a (Event c)
-> SplineT a b m ()
_untilEvent_ v ve = void $ _untilEvent v ve
race :: (Applicative m, Monad m)
=> (a -> b -> c) -> SplineT i a m d -> SplineT i b m e
-> SplineT i c m (Either d e)
race _ (Pass x) _ = Pass $ Left x
race _ _ (Pass x) = Pass $ Right x
race f (SplineT va) (SplineT vb) = SplineT $ VarT $ \i -> do
((a, ed), va1) <- runVarT va i
((b, ee), vb1) <- runVarT vb i
let c = f a b
case (ed,ee) of
(Event d,_) -> return ( (c, Event $ Left d), pure (c, Event $ Left d))
(_,Event e) -> return ( (c, Event $ Right e), pure (c, Event $ Right e))
(_,_) -> return ( (c, NoEvent)
, runSplineT (race f (SplineT va1) (SplineT vb1)) c
)
raceMany :: (Applicative m, Monad m, Monoid b)
=> [SplineT a b m c] -> SplineT a b m c
raceMany [] = pure mempty `_untilEvent` never
raceMany ss = SplineT $ VarT $ \a -> do
let f (b, ec, ss1) s = do
((b1, ec1), v1) <- runVarT (runSplineT s b) a
return (b <> b1, msum [ec, ec1], ss1 ++ [SplineT v1])
(b,ec,ss1) <- foldM f (mempty, NoEvent, []) ss
return ((b,ec), runSplineT (raceMany ss1) b)
merge :: (Applicative m, Monad m)
=> (b -> b -> b) -> (c -> d -> e)
-> SplineT a b m c -> SplineT a b m d -> SplineT a b m e
merge _ g (Pass c) (Pass d) = Pass $ g c d
merge _ g (Pass c) s = g c <$> s
merge _ g s (Pass d) = flip g d <$> s
merge f g (SplineT v1) (SplineT v2) = SplineT $ VarT $ \a -> do
((b1,e1), v3) <- runVarT v1 a
((b2,e2), v4) <- runVarT v2 a
let b = f b1 b2
case (e1,e2) of
(Event c, Event d) -> let e = (b, Event $ g c d) in return (e, pure e)
(Event _, _) -> do let s = SplineT $ pure (b1,e1)
sv4 = SplineT v4
return ((b, NoEvent), runSplineT (merge f g s sv4) b)
(_, Event _) -> do let s = SplineT $ pure (b2,e2)
sv3 = SplineT v3
return ((b, NoEvent), runSplineT (merge f g sv3 s) b)
_ -> do let sv3 = SplineT v3
sv4 = SplineT v4
return ((b, NoEvent), runSplineT (merge f g sv3 sv4) b)
effect :: (Applicative m, Monad m) => b -> m x -> SplineT a b m x
effect b f = SplineT $ VarT $ const $ do
x <- f
return ((b, Event x), pure (b, Event x))
capture :: (Applicative m, Monad m)
=> SplineT a b m c -> SplineT a b m (Maybe b, c)
capture (Pass x) = Pass (Nothing, x)
capture (SplineT v) = capture' v
where capture' v' = SplineT $ VarT $ \a -> do
((b, ec), v'') <- runVarT v' a
let mb' = Just b
return ((b, (mb',) <$> ec), runSplineT (capture' v'') b)
step :: (Applicative m, Monad m) => b -> SplineT a b m ()
step b = SplineT $ VarT $ \_ -> return ((b, NoEvent), pure (b,Event ()))
mapOutput :: (Applicative m, Monad m)
=> VarT m a (b -> t) -> SplineT a b m c -> SplineT a t m c
mapOutput vf (SplineT vx) = SplineT $ vg <*> vx
where vg = (\f (b,ec) -> (f b, ec)) <$> vf
mapOutput _ (Pass c) = Pass c
adjustInput :: (Applicative m, Monad m)
=> VarT m a (a -> r) -> SplineT r b m c -> SplineT a b m c
adjustInput vf (SplineT vx) = SplineT $ VarT $ \a -> do
(f, vf1) <- runVarT vf a
(b, vx1) <- runVarT vx $ f a
return (b, runSplineT (adjustInput vf1 $ SplineT vx1) $ fst b)
adjustInput _ (Pass c) = Pass c