{-# LANGUAGE CPP        #-}
{-# LANGUAGE Rank2Types #-}
-- |
-- Module      : FRP.BearRiver.Task
-- Copyright   : (c) Ivan Perez, 2014-2024
--               (c) George Giorgidze, 2007-2012
--               (c) Henrik Nilsson, 2005-2006
--               (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004
-- License     : BSD3
--
-- Maintainer  : ivan.perez@keera.co.uk
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
--
-- Task abstraction on top of signal transformers.
module FRP.BearRiver.Task
    (
      -- * The Task type
      Task
    , mkTask
    , runTask
    , runTask_
    , taskToSF

      -- * Basic tasks
    , constT
    , sleepT
    , snapT

    -- * Basic tasks combinators
    , timeOut
    , abortWhen
    )
  where

-- External imports
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..))
#endif

-- Internal imports
import FRP.BearRiver.Basic        (constant)
import FRP.BearRiver.Event        (Event, lMerge)
import FRP.BearRiver.EventS       (after, edgeBy, never, snap)
import FRP.BearRiver.InternalCore (SF, Time, arr, first, (&&&), (>>>))
import FRP.BearRiver.Switches     (switch)

infixl 0 `timeOut`, `abortWhen`

-- * The Task type

-- | A task is a partially SF that may terminate with a result.
newtype Task m a b c =
  -- CPS-based representation allowing termination to be detected. Note the
  -- rank 2 polymorphic type! The representation can be changed if necessary,
  -- but the Monad laws follow trivially in this case.
  Task (forall d . (c -> SF m a (Either b d)) -> SF m a (Either b d))

unTask :: Monad m
       => Task m a b c -> ((c -> SF m a (Either b d)) -> SF m a (Either b d))
unTask :: forall (m :: * -> *) a b c d.
Monad m =>
Task m a b c -> (c -> SF m a (Either b d)) -> SF m a (Either b d)
unTask (Task forall d. (c -> SF m a (Either b d)) -> SF m a (Either b d)
f) = (c -> SF m a (Either b d)) -> SF m a (Either b d)
forall d. (c -> SF m a (Either b d)) -> SF m a (Either b d)
f

-- | Creates a 'Task' from an SF that returns, as a second output, an 'Event'
-- when the SF terminates. See 'switch'.
mkTask :: Monad m => SF m a (b, Event c) -> Task m a b c
mkTask :: forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> Task m a b c
mkTask SF m a (b, Event c)
st = (forall d. (c -> SF m a (Either b d)) -> SF m a (Either b d))
-> Task m a b c
forall (m :: * -> *) a b c.
(forall d. (c -> SF m a (Either b d)) -> SF m a (Either b d))
-> Task m a b c
Task (SF m a (Either b d, Event c)
-> (c -> SF m a (Either b d)) -> SF m a (Either b d)
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)
st SF m a (b, Event c)
-> MSF (ClockInfo m) (b, Event c) (Either b d, Event c)
-> SF m a (Either b d, Event c)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> MSF (ClockInfo m) b (Either b d)
-> MSF (ClockInfo m) (b, Event c) (Either b d, Event c)
forall b c d.
MSF (ClockInfo m) b c -> MSF (ClockInfo m) (b, d) (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((b -> Either b d) -> MSF (ClockInfo m) b (Either b d)
forall b c. (b -> c) -> MSF (ClockInfo m) b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr b -> Either b d
forall a b. a -> Either a b
Left)))

-- | Runs a task.
--
-- The output from the resulting signal transformer is tagged with Left while
-- the underlying task is running. Once the task has terminated, the output
-- goes constant with the value Right x, where x is the value of the
-- terminating event.

-- Check name.
runTask :: Monad m => Task m a b c -> SF m a (Either b c)
runTask :: forall (m :: * -> *) a b c.
Monad m =>
Task m a b c -> SF m a (Either b c)
runTask Task m a b c
tk = (Task m a b c -> (c -> SF m a (Either b c)) -> SF m a (Either b c)
forall (m :: * -> *) a b c d.
Monad m =>
Task m a b c -> (c -> SF m a (Either b d)) -> SF m a (Either b d)
unTask Task m a b c
tk) (Either b c -> SF m a (Either b c)
forall (m :: * -> *) b a. Monad m => b -> SF m a b
constant (Either b c -> SF m a (Either b c))
-> (c -> Either b c) -> c -> SF m a (Either b c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> Either b c
forall a b. b -> Either a b
Right)

-- | Runs a task that never terminates.
--
-- The output becomes undefined once the underlying task has terminated.
--
-- Convenience function for tasks which are known not to terminate.
runTask_ :: Monad m => Task m a b c -> SF m a b
runTask_ :: forall (m :: * -> *) a b c. Monad m => Task m a b c -> SF m a b
runTask_ Task m a b c
tk =
  Task m a b c -> SF m a (Either b c)
forall (m :: * -> *) a b c.
Monad m =>
Task m a b c -> SF m a (Either b c)
runTask Task m a b c
tk
  SF m a (Either b c)
-> MSF (ClockInfo m) (Either b c) b -> MSF (ClockInfo m) a b
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Either b c -> b) -> MSF (ClockInfo m) (Either b c) b
forall b c. (b -> c) -> MSF (ClockInfo m) b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((b -> b) -> (c -> b) -> Either b c -> b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> b
forall a. a -> a
id ([Char] -> c -> b
forall a. HasCallStack => [Char] -> a
error [Char]
"BearRiverTask: runTask_: Task terminated!"))

-- | Creates an SF that represents an SF and produces an event when the task
-- terminates, and otherwise produces just an output.
taskToSF :: Monad m => Task m a b c -> SF m a (b, Event c)
taskToSF :: forall (m :: * -> *) a b c.
Monad m =>
Task m a b c -> SF m a (b, Event c)
taskToSF Task m a b c
tk =
    Task m a b c -> SF m a (Either b c)
forall (m :: * -> *) a b c.
Monad m =>
Task m a b c -> SF m a (Either b c)
runTask Task m a b c
tk
    SF m a (Either b c)
-> MSF (ClockInfo m) (Either b c) (b, Event c)
-> MSF (ClockInfo m) a (b, Event c)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Either b c -> b) -> MSF (ClockInfo m) (Either b c) b
forall b c. (b -> c) -> MSF (ClockInfo m) b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((b -> b) -> (c -> b) -> Either b c -> b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> b
forall a. a -> a
id ([Char] -> c -> b
forall a. HasCallStack => [Char] -> a
error [Char]
"BearRiverTask: runTask_: Task terminated!"))
         MSF (ClockInfo m) (Either b c) b
-> MSF (ClockInfo m) (Either b c) (Event c)
-> MSF (ClockInfo m) (Either b c) (b, Event c)
forall b c c'.
MSF (ClockInfo m) b c
-> MSF (ClockInfo m) b c' -> MSF (ClockInfo m) b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Either b c -> Either b c -> Maybe c)
-> Either b c -> MSF (ClockInfo m) (Either b c) (Event c)
forall (m :: * -> *) a b.
Monad m =>
(a -> a -> Maybe b) -> a -> SF m a (Event b)
edgeBy Either b c -> Either b c -> Maybe c
forall {a} {b} {a} {a}. Either a b -> Either a a -> Maybe a
isEdge (b -> Either b c
forall a b. a -> Either a b
Left b
forall a. HasCallStack => a
undefined))
  where
    isEdge :: Either a b -> Either a a -> Maybe a
isEdge (Left a
_) (Right a
c) = a -> Maybe a
forall a. a -> Maybe a
Just a
c
    isEdge Either a b
_        Either a a
_         = Maybe a
forall a. Maybe a
Nothing

-- * Functor, Applicative and Monad instance

instance Monad m => Functor (Task m a b) where
  fmap :: forall a b. (a -> b) -> Task m a b a -> Task m a b b
fmap a -> b
f Task m a b a
tk = (forall d. (b -> SF m a (Either b d)) -> SF m a (Either b d))
-> Task m a b b
forall (m :: * -> *) a b c.
(forall d. (c -> SF m a (Either b d)) -> SF m a (Either b d))
-> Task m a b c
Task (\b -> SF m a (Either b d)
k -> Task m a b a -> (a -> SF m a (Either b d)) -> SF m a (Either b d)
forall (m :: * -> *) a b c d.
Monad m =>
Task m a b c -> (c -> SF m a (Either b d)) -> SF m a (Either b d)
unTask Task m a b a
tk (b -> SF m a (Either b d)
k (b -> SF m a (Either b d)) -> (a -> b) -> a -> SF m a (Either b d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))

instance Monad m => Applicative (Task m a b) where
  pure :: forall a. a -> Task m a b a
pure a
x  = (forall d. (a -> SF m a (Either b d)) -> SF m a (Either b d))
-> Task m a b a
forall (m :: * -> *) a b c.
(forall d. (c -> SF m a (Either b d)) -> SF m a (Either b d))
-> Task m a b c
Task (\a -> SF m a (Either b d)
k -> a -> SF m a (Either b d)
k a
x)
  Task m a b (a -> b)
f <*> :: forall a b. Task m a b (a -> b) -> Task m a b a -> Task m a b b
<*> Task m a b a
v = (forall d. (b -> SF m a (Either b d)) -> SF m a (Either b d))
-> Task m a b b
forall (m :: * -> *) a b c.
(forall d. (c -> SF m a (Either b d)) -> SF m a (Either b d))
-> Task m a b c
Task (\b -> SF m a (Either b d)
k -> (Task m a b (a -> b)
-> ((a -> b) -> SF m a (Either b d)) -> SF m a (Either b d)
forall (m :: * -> *) a b c d.
Monad m =>
Task m a b c -> (c -> SF m a (Either b d)) -> SF m a (Either b d)
unTask Task m a b (a -> b)
f) (\a -> b
c -> Task m a b a -> (a -> SF m a (Either b d)) -> SF m a (Either b d)
forall (m :: * -> *) a b c d.
Monad m =>
Task m a b c -> (c -> SF m a (Either b d)) -> SF m a (Either b d)
unTask Task m a b a
v (b -> SF m a (Either b d)
k (b -> SF m a (Either b d)) -> (a -> b) -> a -> SF m a (Either b d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
c)))

instance Monad m => Monad (Task m a b) where
  Task m a b a
tk >>= :: forall a b. Task m a b a -> (a -> Task m a b b) -> Task m a b b
>>= a -> Task m a b b
f = (forall d. (b -> SF m a (Either b d)) -> SF m a (Either b d))
-> Task m a b b
forall (m :: * -> *) a b c.
(forall d. (c -> SF m a (Either b d)) -> SF m a (Either b d))
-> Task m a b c
Task (\b -> SF m a (Either b d)
k -> Task m a b a -> (a -> SF m a (Either b d)) -> SF m a (Either b d)
forall (m :: * -> *) a b c d.
Monad m =>
Task m a b c -> (c -> SF m a (Either b d)) -> SF m a (Either b d)
unTask Task m a b a
tk (\a
c -> Task m a b b -> (b -> SF m a (Either b d)) -> SF m a (Either b d)
forall (m :: * -> *) a b c d.
Monad m =>
Task m a b c -> (c -> SF m a (Either b d)) -> SF m a (Either b d)
unTask (a -> Task m a b b
f a
c) b -> SF m a (Either b d)
k))
  return :: forall a. a -> Task m a b a
return   = a -> Task m a b a
forall a. a -> Task m a b a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- Let's check the monad laws:
--
--   t >>= return
--   = \k -> t (\c -> return c k)
--   = \k -> t (\c -> (\x -> \k -> k x) c k)
--   = \k -> t (\c -> (\x -> \k' -> k' x) c k)
--   = \k -> t (\c -> k c)
--   = \k -> t k
--   = t
--   QED
--
--   return x >>= f
--   = \k -> (return x) (\c -> f c k)
--   = \k -> (\k -> k x) (\c -> f c k)
--   = \k -> (\k' -> k' x) (\c -> f c k)
--   = \k -> (\c -> f c k) x
--   = \k -> f x k
--   = f x
--   QED
--
--   (t >>= f) >>= g
--   = \k -> (t >>= f) (\c -> g c k)
--   = \k -> (\k' -> t (\c' -> f c' k')) (\c -> g c k)
--   = \k -> t (\c' -> f c' (\c -> g c k))
--   = \k -> t (\c' -> (\x -> \k' -> f x (\c -> g c k')) c' k)
--   = \k -> t (\c' -> (\x -> f x >>= g) c' k)
--   = t >>= (\x -> f x >>= g)
--   QED
--
-- No surprises (obviously, since this is essentially just the CPS monad).

-- * Basic tasks

-- | Non-terminating task with constant output b.
constT :: Monad m => b -> Task m a b c
constT :: forall (m :: * -> *) b a c. Monad m => b -> Task m a b c
constT b
b = SF m a (b, Event c) -> Task m a b c
forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> Task m a b c
mkTask (b -> SF m a b
forall (m :: * -> *) b a. Monad m => b -> SF m a b
constant b
b SF m a b -> MSF (ClockInfo m) a (Event c) -> SF m a (b, Event c)
forall b c c'.
MSF (ClockInfo m) b c
-> MSF (ClockInfo m) b c' -> MSF (ClockInfo m) b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& MSF (ClockInfo m) a (Event c)
forall (m :: * -> *) a b. Monad m => SF m a (Event b)
never)

-- | "Sleeps" for t seconds with constant output b.
sleepT :: Monad m => Time -> b -> Task m a b ()
sleepT :: forall (m :: * -> *) b a. Monad m => Time -> b -> Task m a b ()
sleepT Time
t b
b = SF m a (b, Event ()) -> Task m a b ()
forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> Task m a b c
mkTask (b -> SF m a b
forall (m :: * -> *) b a. Monad m => b -> SF m a b
constant b
b SF m a b -> MSF (ClockInfo m) a (Event ()) -> SF m a (b, Event ())
forall b c c'.
MSF (ClockInfo m) b c
-> MSF (ClockInfo m) b c' -> MSF (ClockInfo m) b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Time -> () -> MSF (ClockInfo m) a (Event ())
forall (m :: * -> *) b a. Monad m => Time -> b -> SF m a (Event b)
after Time
t ())

-- | Takes a "snapshot" of the input and terminates immediately with the input
-- value as the result.
--
-- No time passes; therefore, the following must hold:
--
-- @snapT >> snapT = snapT@
snapT :: Monad m => Task m a b a
snapT :: forall (m :: * -> *) a b. Monad m => Task m a b a
snapT = SF m a (b, Event a) -> Task m a b a
forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> Task m a b c
mkTask (b -> SF m a b
forall (m :: * -> *) b a. Monad m => b -> SF m a b
constant ([Char] -> b
forall a. HasCallStack => [Char] -> a
error [Char]
"BearRiverTask: snapT: Bad switch?") SF m a b -> MSF (ClockInfo m) a (Event a) -> SF m a (b, Event a)
forall b c c'.
MSF (ClockInfo m) b c
-> MSF (ClockInfo m) b c' -> MSF (ClockInfo m) b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& MSF (ClockInfo m) a (Event a)
forall (m :: * -> *) a. Monad m => SF m a (Event a)
snap)

-- * Basic tasks combinators

-- | Impose a time out on a task.
timeOut :: Monad m => Task m a b c -> Time -> Task m a b (Maybe c)
Task m a b c
tk timeOut :: forall (m :: * -> *) a b c.
Monad m =>
Task m a b c -> Time -> Task m a b (Maybe c)
`timeOut` Time
t = SF m a (b, Event (Maybe c)) -> Task m a b (Maybe c)
forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> Task m a b c
mkTask ((Task m a b c -> SF m a (b, Event c)
forall (m :: * -> *) a b c.
Monad m =>
Task m a b c -> SF m a (b, Event c)
taskToSF Task m a b c
tk SF m a (b, Event c)
-> MSF (ClockInfo m) a (Event ())
-> MSF (ClockInfo m) a ((b, Event c), Event ())
forall b c c'.
MSF (ClockInfo m) b c
-> MSF (ClockInfo m) b c' -> MSF (ClockInfo m) b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Time -> () -> MSF (ClockInfo m) a (Event ())
forall (m :: * -> *) b a. Monad m => Time -> b -> SF m a (Event b)
after Time
t ()) MSF (ClockInfo m) a ((b, Event c), Event ())
-> MSF (ClockInfo m) ((b, Event c), Event ()) (b, Event (Maybe c))
-> SF m a (b, Event (Maybe c))
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (((b, Event c), Event ()) -> (b, Event (Maybe c)))
-> MSF (ClockInfo m) ((b, Event c), Event ()) (b, Event (Maybe c))
forall b c. (b -> c) -> MSF (ClockInfo m) b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((b, Event c), Event ()) -> (b, Event (Maybe c))
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, Event (Maybe a) -> Event (Maybe a) -> Event (Maybe a)
forall a. Event a -> Event a -> Event a
lMerge ((a -> Maybe a) -> Event a -> Event (Maybe a)
forall a b. (a -> b) -> Event a -> Event b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just Event a
ec) ((a -> Maybe a) -> Event a -> Event (Maybe a)
forall a b. (a -> b) -> Event a -> Event b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe a -> a -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) Event a
et))

-- | Run a "guarding" event source (SF m a (Event b)) in parallel with a
-- (possibly non-terminating) task.
--
-- The task will be aborted at the first occurrence of the event source (if it
-- has not terminated itself before that).
--
-- Useful for separating sequencing and termination concerns.  E.g. we can do
-- something "useful", but in parallel watch for a (exceptional) condition
-- which should terminate that activity, without having to check for that
-- condition explicitly during each and every phase of the activity.
--
-- Example: @tsk `abortWhen` lbp@
abortWhen :: Monad m
          => Task m a b c -> SF m a (Event d) -> Task m a b (Either c d)
Task m a b c
tk abortWhen :: forall (m :: * -> *) a b c d.
Monad m =>
Task m a b c -> SF m a (Event d) -> Task m a b (Either c d)
`abortWhen` SF m a (Event d)
est = SF m a (b, Event (Either c d)) -> Task m a b (Either c d)
forall (m :: * -> *) a b c.
Monad m =>
SF m a (b, Event c) -> Task m a b c
mkTask ((Task m a b c -> SF m a (b, Event c)
forall (m :: * -> *) a b c.
Monad m =>
Task m a b c -> SF m a (b, Event c)
taskToSF Task m a b c
tk SF m a (b, Event c)
-> SF m a (Event d) -> MSF (ClockInfo m) a ((b, Event c), Event d)
forall b c c'.
MSF (ClockInfo m) b c
-> MSF (ClockInfo m) b c' -> MSF (ClockInfo m) b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& SF m a (Event d)
est) MSF (ClockInfo m) a ((b, Event c), Event d)
-> MSF
     (ClockInfo m) ((b, Event c), Event d) (b, Event (Either c d))
-> SF m a (b, Event (Either c d))
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (((b, Event c), Event d) -> (b, Event (Either c d)))
-> MSF
     (ClockInfo m) ((b, Event c), Event d) (b, Event (Either c d))
forall b c. (b -> c) -> MSF (ClockInfo m) b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((b, Event c), Event d) -> (b, Event (Either c d))
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, Event (Either a b) -> Event (Either a b) -> Event (Either a b)
forall a. Event a -> Event a -> Event a
lMerge ((a -> Either a b) -> Event a -> Event (Either a b)
forall a b. (a -> b) -> Event a -> Event b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either a b
forall a b. a -> Either a b
Left Event a
ec) ((b -> Either a b) -> Event b -> Event (Either a b)
forall a b. (a -> b) -> Event a -> Event b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either a b
forall a b. b -> Either a b
Right Event b
ed))