{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ < 800
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
#else
{-# OPTIONS_GHC -Wno-deprecations #-}
#endif
module FRP.BearRiver.Switches
(
switch, dSwitch
, parB
, dpSwitchB
, parC
)
where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative (..), (<$>))
#endif
import Data.Traversable as T
import Control.Monad.Trans.MSF (local)
import Control.Monad.Trans.MSF.List (sequenceS, widthFirst)
import Data.MonadicStreamFunction.InternalCore (MSF (MSF, unMSF))
import FRP.BearRiver.Event (Event (..))
import FRP.BearRiver.InternalCore (SF)
switch :: Monad m => SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
switch :: forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
switch SF m a (b, Event c)
sf c -> SF m a b
sfC = forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF forall a b. (a -> b) -> a -> b
$ \a
a -> do
((b, Event c)
o, SF m a (b, Event c)
ct) <- forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF m a (b, Event c)
sf a
a
case (b, Event c)
o of
(b
_, Event c
c) -> forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (forall a b. a -> b -> a
const DTime
0) (forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF (c -> SF m a b
sfC c
c) a
a)
(b
b, Event c
NoEvent) -> forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
switch SF m a (b, Event c)
ct c -> SF m a b
sfC)
dSwitch :: Monad m => SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
dSwitch :: forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
dSwitch SF m a (b, Event c)
sf c -> SF m a b
sfC = forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF forall a b. (a -> b) -> a -> b
$ \a
a -> do
((b, Event c)
o, SF m a (b, Event c)
ct) <- forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF m a (b, Event c)
sf a
a
case (b, Event c)
o of
(b
b, Event c
c) -> do (b
_, SF m a b
ct') <- forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (forall a b. a -> b -> a
const DTime
0) (forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF (c -> SF m a b
sfC c
c) a
a)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, SF m a b
ct')
(b
b, Event c
NoEvent) -> forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> (c -> SF m a b) -> SF m a b
dSwitch SF m a (b, Event c)
ct c -> SF m a b
sfC)
#if MIN_VERSION_base(4,8,0)
parB :: Monad m => [SF m a b] -> SF m a [b]
#else
parB :: (Functor m, Monad m) => [SF m a b] -> SF m a [b]
#endif
parB :: forall (m :: * -> *) a b. Monad m => [SF m a b] -> SF m a [b]
parB = forall (m :: * -> *) a b.
(Functor m, Monad m) =>
MSF (ListT m) a b -> MSF m a [b]
widthFirst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b.
Monad m =>
[MSF m a b] -> MSF (ListT m) a b
sequenceS
dpSwitchB :: (Functor m, Monad m, Traversable col)
=> col (SF m a b)
-> SF m (a, col b) (Event c)
-> (col (SF m a b) -> c -> SF m a (col b))
-> SF m a (col b)
dpSwitchB :: forall (m :: * -> *) (col :: * -> *) a b c.
(Functor m, Monad m, Traversable col) =>
col (SF m a b)
-> SF m (a, col b) (Event c)
-> (col (SF m a b) -> c -> SF m a (col b))
-> SF m a (col b)
dpSwitchB col (SF m a b)
sfs SF m (a, col b) (Event c)
sfF col (SF m a b) -> c -> SF m a (col b)
sfCs = forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF forall a b. (a -> b) -> a -> b
$ \a
a -> do
col (b, SF m a b)
res <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
`unMSF` a
a) col (SF m a b)
sfs
let bs :: col b
bs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst col (b, SF m a b)
res
sfs' :: col (SF m a b)
sfs' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd col (b, SF m a b)
res
(Event c
e, SF m (a, col b) (Event c)
sfF') <- forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF m (a, col b) (Event c)
sfF (a
a, col b
bs)
SF m a (col b)
ct <- case Event c
e of
Event c
c -> forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF (col (SF m a b) -> c -> SF m a (col b)
sfCs col (SF m a b)
sfs c
c) a
a
Event c
NoEvent -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) (col :: * -> *) a b c.
(Functor m, Monad m, Traversable col) =>
col (SF m a b)
-> SF m (a, col b) (Event c)
-> (col (SF m a b) -> c -> SF m a (col b))
-> SF m a (col b)
dpSwitchB col (SF m a b)
sfs' SF m (a, col b) (Event c)
sfF' col (SF m a b) -> c -> SF m a (col b)
sfCs)
forall (m :: * -> *) a. Monad m => a -> m a
return (col b
bs, SF m a (col b)
ct)
parC :: Monad m => SF m a b -> SF m [a] [b]
parC :: forall (m :: * -> *) a b. Monad m => SF m a b -> SF m [a] [b]
parC = forall (m :: * -> *) a b. Monad m => SF m a b -> SF m [a] [b]
parC0
where
parC0 :: Monad m => SF m a b -> SF m [a] [b]
parC0 :: forall (m :: * -> *) a b. Monad m => SF m a b -> SF m [a] [b]
parC0 SF m a b
sf0 = forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF forall a b. (a -> b) -> a -> b
$ \[a]
as -> do
[(b, SF m a b)]
os <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (\(a
a, SF m a b
sf) -> forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF m a b
sf a
a) forall a b. (a -> b) -> a -> b
$
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
as (forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as) SF m a b
sf0)
let bs :: [b]
bs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(b, SF m a b)]
os
cts :: [SF m a b]
cts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd [(b, SF m a b)]
os
forall (m :: * -> *) a. Monad m => a -> m a
return ([b]
bs, forall (m :: * -> *) a b. Monad m => [SF m a b] -> SF m [a] [b]
parC' [SF m a b]
cts)
parC' :: Monad m => [SF m a b] -> SF m [a] [b]
parC' :: forall (m :: * -> *) a b. Monad m => [SF m a b] -> SF m [a] [b]
parC' [SF m a b]
sfs = forall (m :: * -> *) a b. (a -> m (b, MSF m a b)) -> MSF m a b
MSF forall a b. (a -> b) -> a -> b
$ \[a]
as -> do
[(b, SF m a b)]
os <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (\(a
a, SF m a b
sf) -> forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF SF m a b
sf a
a) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [a]
as [SF m a b]
sfs
let bs :: [b]
bs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(b, SF m a b)]
os
cts :: [SF m a b]
cts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd [(b, SF m a b)]
os
forall (m :: * -> *) a. Monad m => a -> m a
return ([b]
bs, forall (m :: * -> *) a b. Monad m => [SF m a b] -> SF m [a] [b]
parC' [SF m a b]
cts)