{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
module FRP.Yampa.Task
( Task
, mkTask
, runTask
, runTask_
, taskToSF
, constT
, sleepT
, snapT
, timeOut
, abortWhen
)
where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..))
#endif
import FRP.Yampa.Basic (constant)
import FRP.Yampa.Diagnostics (intErr, usrErr)
import FRP.Yampa.Event (Event, lMerge)
import FRP.Yampa.EventS (after, edgeBy, never, snap)
import FRP.Yampa.InternalCore (SF, Time, arr, first, (&&&), (>>>))
import FRP.Yampa.Switches (switch)
infixl 0 `timeOut`, `abortWhen`
newtype Task a b c =
Task (forall d . (c -> SF a (Either b d)) -> SF a (Either b d))
unTask :: Task a b c -> ((c -> SF a (Either b d)) -> SF a (Either b d))
unTask :: forall a b c d.
Task a b c -> (c -> SF a (Either b d)) -> SF a (Either b d)
unTask (Task forall d. (c -> SF a (Either b d)) -> SF a (Either b d)
f) = forall d. (c -> SF a (Either b d)) -> SF a (Either b d)
f
mkTask :: SF a (b, Event c) -> Task a b c
mkTask :: forall a b c. SF a (b, Event c) -> Task a b c
mkTask SF a (b, Event c)
st = forall a b c.
(forall d. (c -> SF a (Either b d)) -> SF a (Either b d))
-> Task a b c
Task (forall a b c. SF a (b, Event c) -> (c -> SF a b) -> SF a b
switch (SF a (b, Event c)
st forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. a -> Either a b
Left)))
runTask :: Task a b c -> SF a (Either b c)
runTask :: forall a b c. Task a b c -> SF a (Either b c)
runTask Task a b c
tk = (forall a b c d.
Task a b c -> (c -> SF a (Either b d)) -> SF a (Either b d)
unTask Task a b c
tk) (forall b a. b -> SF a b
constant forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right)
runTask_ :: Task a b c -> SF a b
runTask_ :: forall a b c. Task a b c -> SF a b
runTask_ Task a b c
tk = forall a b c. Task a b c -> SF a (Either b c)
runTask Task a b c
tk
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (forall a. String -> String -> String -> a
usrErr String
"YampaTask" String
"runTask_"
String
"Task terminated!"))
taskToSF :: Task a b c -> SF a (b, Event c)
taskToSF :: forall a b c. Task a b c -> SF a (b, Event c)
taskToSF Task a b c
tk = forall a b c. Task a b c -> SF a (Either b c)
runTask Task a b c
tk
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (forall a. String -> String -> String -> a
usrErr String
"YampaTask" String
"runTask_"
String
"Task terminated!"))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a b. (a -> a -> Maybe b) -> a -> SF a (Event b)
edgeBy forall {a} {b} {a} {a}. Either a b -> Either a a -> Maybe a
isEdge (forall a b. a -> Either a b
Left forall a. HasCallStack => a
undefined))
where
isEdge :: Either a b -> Either a a -> Maybe a
isEdge (Left a
_) (Left a
_) = forall a. Maybe a
Nothing
isEdge (Left a
_) (Right a
c) = forall a. a -> Maybe a
Just a
c
isEdge (Right b
_) (Right a
_) = forall a. Maybe a
Nothing
isEdge (Right b
_) (Left a
_) = forall a. Maybe a
Nothing
instance Functor (Task a b) where
fmap :: forall a b. (a -> b) -> Task a b a -> Task a b b
fmap a -> b
f Task a b a
tk = forall a b c.
(forall d. (c -> SF a (Either b d)) -> SF a (Either b d))
-> Task a b c
Task (\b -> SF a (Either b d)
k -> forall a b c d.
Task a b c -> (c -> SF a (Either b d)) -> SF a (Either b d)
unTask Task a b a
tk (b -> SF a (Either b d)
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
instance Applicative (Task a b) where
pure :: forall a. a -> Task a b a
pure a
x = forall a b c.
(forall d. (c -> SF a (Either b d)) -> SF a (Either b d))
-> Task a b c
Task (\a -> SF a (Either b d)
k -> a -> SF a (Either b d)
k a
x)
Task a b (a -> b)
f <*> :: forall a b. Task a b (a -> b) -> Task a b a -> Task a b b
<*> Task a b a
v = forall a b c.
(forall d. (c -> SF a (Either b d)) -> SF a (Either b d))
-> Task a b c
Task (\b -> SF a (Either b d)
k -> (forall a b c d.
Task a b c -> (c -> SF a (Either b d)) -> SF a (Either b d)
unTask Task a b (a -> b)
f) (\a -> b
c -> forall a b c d.
Task a b c -> (c -> SF a (Either b d)) -> SF a (Either b d)
unTask Task a b a
v (b -> SF a (Either b d)
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
c)))
instance Monad (Task a b) where
Task a b a
tk >>= :: forall a b. Task a b a -> (a -> Task a b b) -> Task a b b
>>= a -> Task a b b
f = forall a b c.
(forall d. (c -> SF a (Either b d)) -> SF a (Either b d))
-> Task a b c
Task (\b -> SF a (Either b d)
k -> forall a b c d.
Task a b c -> (c -> SF a (Either b d)) -> SF a (Either b d)
unTask Task a b a
tk (\a
c -> forall a b c d.
Task a b c -> (c -> SF a (Either b d)) -> SF a (Either b d)
unTask (a -> Task a b b
f a
c) b -> SF a (Either b d)
k))
return :: forall a. a -> Task a b a
return a
x = forall a b c.
(forall d. (c -> SF a (Either b d)) -> SF a (Either b d))
-> Task a b c
Task (\a -> SF a (Either b d)
k -> a -> SF a (Either b d)
k a
x)
constT :: b -> Task a b c
constT :: forall b a c. b -> Task a b c
constT b
b = forall a b c. SF a (b, Event c) -> Task a b c
mkTask (forall b a. b -> SF a b
constant b
b forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a b. SF a (Event b)
never)
sleepT :: Time -> b -> Task a b ()
sleepT :: forall b a. Time -> b -> Task a b ()
sleepT Time
t b
b = forall a b c. SF a (b, Event c) -> Task a b c
mkTask (forall b a. b -> SF a b
constant b
b forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall b a. Time -> b -> SF a (Event b)
after Time
t ())
snapT :: Task a b a
snapT :: forall a b. Task a b a
snapT = forall a b c. SF a (b, Event c) -> Task a b c
mkTask (forall b a. b -> SF a b
constant (forall a. String -> String -> String -> a
intErr String
"YampaTask" String
"snapT" String
"Bad switch?") forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. SF a (Event a)
snap)
timeOut :: Task a b c -> Time -> Task a b (Maybe c)
Task a b c
tk timeOut :: forall a b c. Task a b c -> Time -> Task a b (Maybe c)
`timeOut` Time
t = forall a b c. SF a (b, Event c) -> Task a b c
mkTask ((forall a b c. Task a b c -> SF a (b, Event c)
taskToSF Task a b c
tk forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall b a. Time -> b -> SF a (Event b)
after Time
t ()) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall {a} {a} {a}. ((a, Event a), Event a) -> (a, Event (Maybe a))
aux)
where
aux :: ((a, Event a), Event a) -> (a, Event (Maybe a))
aux ((a
b, Event a
ec), Event a
et) = (a
b, (forall a. Event a -> Event a -> Event a
lMerge (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just Event a
ec) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) Event a
et)))
abortWhen :: Task a b c -> SF a (Event d) -> Task a b (Either c d)
Task a b c
tk abortWhen :: forall a b c d.
Task a b c -> SF a (Event d) -> Task a b (Either c d)
`abortWhen` SF a (Event d)
est = forall a b c. SF a (b, Event c) -> Task a b c
mkTask ((forall a b c. Task a b c -> SF a (b, Event c)
taskToSF Task a b c
tk forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& SF a (Event d)
est) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall {a} {a} {b}.
((a, Event a), Event b) -> (a, Event (Either a b))
aux)
where
aux :: ((a, Event a), Event b) -> (a, Event (Either a b))
aux ((a
b, Event a
ec), Event b
ed) = (a
b, (forall a. Event a -> Event a -> Event a
lMerge (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left Event a
ec) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right Event b
ed)))