-----------------------------------------------------------------------------
-- |
-- Module      :  AFRPTask
  Copyright    :   ( c ) Yale University , 2003 
-- License     :  BSD-style (see the file LICENSE)
-- 
  Maintainer   :    
-- Stability   :  provisional
  Portability :   non - portable ( uses GHC extensions ) 
--
  Task abstraction on top of signal transformers . 
--
module AFRPTask (
    Task,
    mkTask,	-- :: SF a (b, Event c) -> Task a b c
    runTask,	-- :: Task a b c -> SF a (Either b c)	-- Might change.
    runTask_,	-- :: Task a b c -> SF a b
    taskToSF,	-- :: Task a b c -> SF a (b, Event c)	-- Might change.
    constT,	-- :: b -> Task a b c
    sleepT, 	-- :: Time -> b -> Task a b ()
    snapT, 	-- :: Task a b a
    timeOut, 	-- :: Task a b c -> Time -> Task a b (Maybe c)
    abortWhen, 	-- :: Task a b c -> SF a (Event d) -> Task a b (Either c d)
  : :   = > m a - > ( a - > Bool ) - > m a 
  : :   = > a - > ( a - > a ) - > ( a - > Bool ) - > m b - > m ( ) 
  : :   = > [ a ] - > ( a - > m b ) - > m ( ) 
  : :   = > m a - > m b 
) where

import AFRP
import AFRPUtilities (snap)
import AFRPDiagnostics

infixl 0 `timeOut`, `abortWhen`, `repeatUntil`


------------------------------------------------------------------------------
  The Task type 
------------------------------------------------------------------------------

  CPS - based representation allowing a 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.
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 (Task f) = f


mkTask :: SF a (b, Event c) -> Task a b c
mkTask st = Task (switch (st >>> first (arr Left)))


-- "Runs" a task (unusually bad name?). 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.
runTask :: Task a b c -> SF a (Either b c)
runTask tk = (unTask tk) (\c -> constant (Right c))


-- Runs a task. The output becomes undefined once the underlying task has
-- terminated. Convenient e.g. for tasks which are known not to terminate.
runTask_ :: Task a b c -> SF a b
runTask_ tk = runTask tk
              >>> arr (either id (usrErr "AFRPTask" "runTask_"
                                         "Task terminated!"))


-- Seems as if the following is convenient after all. Suitable name???
-- Maybe that implies a representation change for Tasks?
-- Law: mkTask (taskToSF task) = task (but not (quite) vice versa.)
taskToSF :: Task a b c -> SF a (b, Event c)
taskToSF tk = runTask tk
	      >>> (arr (either id ((usrErr "AFRPTask" "runTask_"
                                           "Task terminated!")))
		   &&& edgeBy isEdge (Left undefined))
    where
        isEdge (Left _)  (Left _)  = Nothing
	isEdge (Left _)  (Right c) = Just c
	isEdge (Right _) (Right _) = Nothing
	isEdge (Right _) (Left _)  = Nothing


------------------------------------------------------------------------------
  Monad instance 
------------------------------------------------------------------------------

instance Monad (Task a b) where
    tk >>= f = Task (\k -> (unTask tk) (\c -> unTask (f c) k))
    return x = Task (\k -> k x)


 Let 's check the monad laws : 

     t > > = return 
     = \k - > t (  - > return c k ) 
     = \k - > t (  - > ( \x - > \k - > k x ) c k ) 
     = \k - > t (  - > ( \x - > \k ' - > k ' x ) c k ) 
     = \k - > t (  - > 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 - > (  - > f c k ) x 
     = \k - > f x k 
     = f x 
     QED 

     ( t > > = f ) > > = g 
     = \k - > ( t > > = f ) ( \c - > g c k ) 
     = \k - > ( \k ' - > t (  ' - > f c ' k ' ) ) ( \c - > g c k ) 
     = \k - > t (  ' - > f c ' ( \c - > g c k ) ) 
     = \k - > t (  ' - > ( \x - > \k ' - > f x ( \c - > g c k ' ) ) c ' k ) 
     = \k - > t (  ' - > ( \x - > f x > > = g ) c ' k ) 
     = t > > = ( \x - > f x > > = g ) 
     QED 

 No surprises ( obviously , since this is essentially just the CPS monad ) . 

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 :: b -> Task a b c
constT b = mkTask (constant b &&& never)


  " Sleeps " for t seconds with constant output b. 
sleepT :: Time -> b -> Task a b ()
sleepT t b = mkTask (constant b &&& after t ())


-- Takes a "snapshot" of the input and terminates immediately with the input
-- value as the result. No time passes; law:
--
--    snapT >> snapT = snapT
--
snapT :: Task a b a
snapT = mkTask (constant (intErr "AFRPTask" "snapT" "Bad switch?") &&& snap)


------------------------------------------------------------------------------
-- Basic tasks combinators
------------------------------------------------------------------------------

-- Impose a time out on a task.
timeOut :: Task a b c -> Time -> Task a b (Maybe c)
tk `timeOut` t = mkTask ((taskToSF tk &&& after t ()) >>> arr aux)
    where
        aux ((b, ec), et) = (b, (lMerge (fmap Just ec)
					(fmap (const Nothing) et)))


-- Run a "guarding" event source (SF 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 ,  having to check 
-- for that condition explicitly during each and every phase of the activity.
-- Example: tsk `abortWhen` lbp
abortWhen :: Task a b c -> SF a (Event d) -> Task a b (Either c d)
tk `abortWhen` est = mkTask ((taskToSF tk &&& est) >>> arr aux)
    where
        aux ((b, ec), ed) = (b, (lMerge (fmap Left ec) (fmap Right ed)))


------------------------------------------------------------------------------
-- Loops
------------------------------------------------------------------------------

-- These are general monadic combinators. Maybe they don't really belong here.

-- Repeat m until result satisfies the predicate p
repeatUntil :: Monad m => m a -> (a -> Bool) -> m a
m `repeatUntil` p = m >>= \x -> if not (p x) then repeatUntil m p else return x


-- C-style for-loop.
  Example : for 0 ( +1 ) ( > = 10 ) ... 
for :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()
for i f p m = if p i then m >> for (f i) f p m else return ()


-- Perform the monadic operation for each element in the list.
forAll :: Monad m => [a] -> (a -> m b) -> m ()
forAll = flip mapM_


-- Repeat m for ever.
forEver :: Monad m => m a -> m b
forEver m = m >> forEver m


-- Alternatives/other potentially useful signatures:
-- until :: a -> (a -> M a) -> (a -> Bool) -> M a
-- for: a -> b -> (a -> b -> a) -> (a -> b -> Bool) -> (a -> b -> M b) -> M b
-- while??? It could be:
-- while :: a -> (a -> Bool) -> (a -> M a) -> M a


------------------------------------------------------------------------------
  Monad transformers ? 
------------------------------------------------------------------------------

-- What about monad transformers if we want to compose this monad with
-- other capabilities???

---------------------------------------------------------------------------
 |
 Module      :  AFRPTask
 License     :  BSD-style (see the file LICENSE)
 
 Stability   :  provisional


 :: SF a (b, Event c) -> Task a b c
 :: Task a b c -> SF a (Either b c)	-- Might change.
 :: Task a b c -> SF a b
 :: Task a b c -> SF a (b, Event c)	-- Might change.
 :: b -> Task a b c
 :: Time -> b -> Task a b ()
 :: Task a b a
 :: Task a b c -> Time -> Task a b (Maybe c)
 :: Task a b c -> SF a (Event d) -> Task a b (Either c d)
----------------------------------------------------------------------------
----------------------------------------------------------------------------
 follow trivially in this case.
 "Runs" a task (unusually bad name?). 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.
 Runs a task. The output becomes undefined once the underlying task has
 terminated. Convenient e.g. for tasks which are known not to terminate.
 Seems as if the following is convenient after all. Suitable name???
 Maybe that implies a representation change for Tasks?
 Law: mkTask (taskToSF task) = task (but not (quite) vice versa.)
----------------------------------------------------------------------------
----------------------------------------------------------------------------
----------------------------------------------------------------------------
 Basic tasks
----------------------------------------------------------------------------
 Non-terminating task with constant output b.
 Takes a "snapshot" of the input and terminates immediately with the input
 value as the result. No time passes; law:

    snapT >> snapT = snapT

----------------------------------------------------------------------------
 Basic tasks combinators
----------------------------------------------------------------------------
 Impose a time out on a task.
 Run a "guarding" event source (SF 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)
 for that condition explicitly during each and every phase of the activity.
 Example: tsk `abortWhen` lbp
----------------------------------------------------------------------------
 Loops
----------------------------------------------------------------------------
 These are general monadic combinators. Maybe they don't really belong here.
 Repeat m until result satisfies the predicate p
 C-style for-loop.
 Perform the monadic operation for each element in the list.
 Repeat m for ever.
 Alternatives/other potentially useful signatures:
 until :: a -> (a -> M a) -> (a -> Bool) -> M a
 for: a -> b -> (a -> b -> a) -> (a -> b -> Bool) -> (a -> b -> M b) -> M b
 while??? It could be:
 while :: a -> (a -> Bool) -> (a -> M a) -> M a
----------------------------------------------------------------------------
----------------------------------------------------------------------------
 What about monad transformers if we want to compose this monad with
 other capabilities???

  Copyright    :   ( c ) Yale University , 2003 
  Maintainer   :    
  Portability :   non - portable ( uses GHC extensions ) 
  Task abstraction on top of signal transformers . 
module AFRPTask (
    Task,
  : :   = > m a - > ( a - > Bool ) - > m a 
  : :   = > a - > ( a - > a ) - > ( a - > Bool ) - > m b - > m ( ) 
  : :   = > [ a ] - > ( a - > m b ) - > m ( ) 
  : :   = > m a - > m b 
) where

import AFRP
import AFRPUtilities (snap)
import AFRPDiagnostics

infixl 0 `timeOut`, `abortWhen`, `repeatUntil`


  The Task type 

  CPS - based representation allowing a termination to be detected . 
  ( Note the rank 2 polymorphic type ! ) 
  The representation can be changed if necessary , but the Monad laws 
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 (Task f) = f


mkTask :: SF a (b, Event c) -> Task a b c
mkTask st = Task (switch (st >>> first (arr Left)))


runTask :: Task a b c -> SF a (Either b c)
runTask tk = (unTask tk) (\c -> constant (Right c))


runTask_ :: Task a b c -> SF a b
runTask_ tk = runTask tk
              >>> arr (either id (usrErr "AFRPTask" "runTask_"
                                         "Task terminated!"))


taskToSF :: Task a b c -> SF a (b, Event c)
taskToSF tk = runTask tk
	      >>> (arr (either id ((usrErr "AFRPTask" "runTask_"
                                           "Task terminated!")))
		   &&& edgeBy isEdge (Left undefined))
    where
        isEdge (Left _)  (Left _)  = Nothing
	isEdge (Left _)  (Right c) = Just c
	isEdge (Right _) (Right _) = Nothing
	isEdge (Right _) (Left _)  = Nothing


  Monad instance 

instance Monad (Task a b) where
    tk >>= f = Task (\k -> (unTask tk) (\c -> unTask (f c) k))
    return x = Task (\k -> k x)


 Let 's check the monad laws : 

     t > > = return 
     = \k - > t (  - > return c k ) 
     = \k - > t (  - > ( \x - > \k - > k x ) c k ) 
     = \k - > t (  - > ( \x - > \k ' - > k ' x ) c k ) 
     = \k - > t (  - > 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 - > (  - > f c k ) x 
     = \k - > f x k 
     = f x 
     QED 

     ( t > > = f ) > > = g 
     = \k - > ( t > > = f ) ( \c - > g c k ) 
     = \k - > ( \k ' - > t (  ' - > f c ' k ' ) ) ( \c - > g c k ) 
     = \k - > t (  ' - > f c ' ( \c - > g c k ) ) 
     = \k - > t (  ' - > ( \x - > \k ' - > f x ( \c - > g c k ' ) ) c ' k ) 
     = \k - > t (  ' - > ( \x - > f x > > = g ) c ' k ) 
     = t > > = ( \x - > f x > > = g ) 
     QED 

 No surprises ( obviously , since this is essentially just the CPS monad ) . 

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).
-}



constT :: b -> Task a b c
constT b = mkTask (constant b &&& never)


  " Sleeps " for t seconds with constant output b. 
sleepT :: Time -> b -> Task a b ()
sleepT t b = mkTask (constant b &&& after t ())


snapT :: Task a b a
snapT = mkTask (constant (intErr "AFRPTask" "snapT" "Bad switch?") &&& snap)



timeOut :: Task a b c -> Time -> Task a b (Maybe c)
tk `timeOut` t = mkTask ((taskToSF tk &&& after t ()) >>> arr aux)
    where
        aux ((b, ec), et) = (b, (lMerge (fmap Just ec)
					(fmap (const Nothing) et)))


  condition which should terminate that activity ,  having to check 
abortWhen :: Task a b c -> SF a (Event d) -> Task a b (Either c d)
tk `abortWhen` est = mkTask ((taskToSF tk &&& est) >>> arr aux)
    where
        aux ((b, ec), ed) = (b, (lMerge (fmap Left ec) (fmap Right ed)))




repeatUntil :: Monad m => m a -> (a -> Bool) -> m a
m `repeatUntil` p = m >>= \x -> if not (p x) then repeatUntil m p else return x


  Example : for 0 ( +1 ) ( > = 10 ) ... 
for :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()
for i f p m = if p i then m >> for (f i) f p m else return ()


forAll :: Monad m => [a] -> (a -> m b) -> m ()
forAll = flip mapM_


forEver :: Monad m => m a -> m b
forEver m = m >> forEver m




  Monad transformers ? 

