{- |
This module supplies a general purpose monad transformer
that adds a syntactical "delay", or "waiting" side effect.
-}

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Control.Monad.Schedule.Trans where

-- base
import Data.Ord (comparing)
import Control.Arrow (Arrow(second))
import Control.Concurrent
import qualified Control.Concurrent as C
import Control.Category ((>>>))
import Control.Monad (join)
import Data.Functor.Classes
import Data.Functor.Identity
import Data.List.NonEmpty as N hiding (partition)
import Data.List (partition)

-- transformers
import Control.Monad.IO.Class
import Control.Monad.Trans.Class

-- free
import Control.Monad.Trans.Free

-- time-domain
import Data.TimeDomain

-- monad-schedule
import Control.Monad.Schedule.Class

-- TODO Implement Time via StateT

-- * Waiting action

-- | A functor implementing a syntactical "waiting" action.
data Wait diff a = Wait
  { forall diff a. Wait diff a -> diff
getDiff :: diff
      -- ^ The duration to wait.
  , forall diff a. Wait diff a -> a
awaited :: a
      -- ^ The encapsulated value.
  }
  deriving (forall a b. a -> Wait diff b -> Wait diff a
forall a b. (a -> b) -> Wait diff a -> Wait diff b
forall diff a b. a -> Wait diff b -> Wait diff a
forall diff a b. (a -> b) -> Wait diff a -> Wait diff b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Wait diff b -> Wait diff a
$c<$ :: forall diff a b. a -> Wait diff b -> Wait diff a
fmap :: forall a b. (a -> b) -> Wait diff a -> Wait diff b
$cfmap :: forall diff a b. (a -> b) -> Wait diff a -> Wait diff b
Functor, Wait diff a -> Wait diff a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall diff a.
(Eq diff, Eq a) =>
Wait diff a -> Wait diff a -> Bool
/= :: Wait diff a -> Wait diff a -> Bool
$c/= :: forall diff a.
(Eq diff, Eq a) =>
Wait diff a -> Wait diff a -> Bool
== :: Wait diff a -> Wait diff a -> Bool
$c== :: forall diff a.
(Eq diff, Eq a) =>
Wait diff a -> Wait diff a -> Bool
Eq, Int -> Wait diff a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall diff a. (Show diff, Show a) => Int -> Wait diff a -> ShowS
forall diff a. (Show diff, Show a) => [Wait diff a] -> ShowS
forall diff a. (Show diff, Show a) => Wait diff a -> String
showList :: [Wait diff a] -> ShowS
$cshowList :: forall diff a. (Show diff, Show a) => [Wait diff a] -> ShowS
show :: Wait diff a -> String
$cshow :: forall diff a. (Show diff, Show a) => Wait diff a -> String
showsPrec :: Int -> Wait diff a -> ShowS
$cshowsPrec :: forall diff a. (Show diff, Show a) => Int -> Wait diff a -> ShowS
Show)

instance Eq diff => Eq1 (Wait diff) where
  liftEq :: forall a b. (a -> b -> Bool) -> Wait diff a -> Wait diff b -> Bool
liftEq a -> b -> Bool
eq (Wait diff
diff1 a
a) (Wait diff
diff2 b
b) = diff
diff1 forall a. Eq a => a -> a -> Bool
== diff
diff2 Bool -> Bool -> Bool
&& a -> b -> Bool
eq a
a b
b

-- | Compare by the time difference, regardless of the value.
--
--   Note that this would not give a lawful 'Ord' instance since we do not compare the @a@.
compareWait :: Ord diff => Wait diff a -> Wait diff a -> Ordering
compareWait :: forall diff a. Ord diff => Wait diff a -> Wait diff a -> Ordering
compareWait = forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall diff a. Wait diff a -> diff
getDiff

-- * 'ScheduleT'

{- |
Values in @ScheduleT diff m@ are delayed computations with side effects in 'm'.
Delays can occur between any two side effects, with lengths specified by a 'diff' value.
These delays don't have any semantics, it can be given to them with 'runScheduleT'.
-}
type ScheduleT diff = FreeT (Wait diff)

type Schedule diff = ScheduleT diff Identity

-- | The side effect that waits for a specified amount.
wait :: Monad m => diff -> ScheduleT diff m ()
wait :: forall (m :: * -> *) diff. Monad m => diff -> ScheduleT diff m ()
wait diff
diff = forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. f b -> FreeF f a b
Free forall a b. (a -> b) -> a -> b
$ forall diff a. diff -> a -> Wait diff a
Wait diff
diff forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Supply a semantic meaning to 'Wait'.
--   For every occurrence of @Wait diff@ in the @ScheduleT diff m a@ value,
--   a waiting action is executed, depending on 'diff'.
runScheduleT :: Monad m => (diff -> m ()) -> ScheduleT diff m a -> m a
runScheduleT :: forall (m :: * -> *) diff a.
Monad m =>
(diff -> m ()) -> ScheduleT diff m a -> m a
runScheduleT diff -> m ()
waitAction = forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Monad m) =>
(f (m a) -> m a) -> FreeT f m a -> m a
iterT forall a b. (a -> b) -> a -> b
$ \(Wait diff
n m a
ma) -> diff -> m ()
waitAction diff
n forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
ma

-- | Run a 'ScheduleT' value in a 'MonadIO',
--   interpreting the times as milliseconds.
runScheduleIO
  :: (MonadIO m, Integral n)
  => ScheduleT n m a -> m a
runScheduleIO :: forall (m :: * -> *) n a.
(MonadIO m, Integral n) =>
ScheduleT n m a -> m a
runScheduleIO = forall (m :: * -> *) diff a.
Monad m =>
(diff -> m ()) -> ScheduleT diff m a -> m a
runScheduleT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
threadDelay forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* Int
1000) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Formally execute all waiting actions,
--   returning the final value and all moments when the schedule would have waited.
execScheduleT :: Monad m => ScheduleT diff m a -> m (a, [diff])
execScheduleT :: forall (m :: * -> *) diff a.
Monad m =>
ScheduleT diff m a -> m (a, [diff])
execScheduleT ScheduleT diff m a
action = do
  FreeF (Wait diff) a (ScheduleT diff m a)
free <- forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT ScheduleT diff m a
action
  case FreeF (Wait diff) a (ScheduleT diff m a)
free of
    Pure a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, [])
    Free (Wait diff
diff ScheduleT diff m a
cont) -> do
      (a
a, [diff]
diffs) <- forall (m :: * -> *) diff a.
Monad m =>
ScheduleT diff m a -> m (a, [diff])
execScheduleT ScheduleT diff m a
cont
      forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, diff
diff forall a. a -> [a] -> [a]
: [diff]
diffs)

instance Ord diff => MonadSchedule (Wait diff) where
  schedule :: forall a.
NonEmpty (Wait diff a) -> Wait diff (NonEmpty a, [Wait diff a])
schedule NonEmpty (Wait diff a)
waits = let (Wait diff a
smallestWait :| [Wait diff a]
waits') = forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
N.sortBy forall diff a. Ord diff => Wait diff a -> Wait diff a -> Ordering
compareWait NonEmpty (Wait diff a)
waits in ((, [Wait diff a]
waits') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Wait diff a
smallestWait

isZero :: (Eq diff, TimeDifference diff) => diff -> Bool
isZero :: forall diff. (Eq diff, TimeDifference diff) => diff -> Bool
isZero diff
diff = diff
diff forall d. TimeDifference d => d -> d -> d
`difference` diff
diff forall a. Eq a => a -> a -> Bool
== diff
diff

-- | Run each action one step until it is discovered which action(s) are pure, or yield next.
--   If there is a pure action, it is returned,
--   otherwise all actions are shifted to the time when the earliest action yields.
instance (Ord diff, TimeDifference diff, Monad m, MonadSchedule m) => MonadSchedule (ScheduleT diff m) where
  schedule :: forall a.
NonEmpty (ScheduleT diff m a)
-> ScheduleT diff m (NonEmpty a, [ScheduleT diff m a])
schedule NonEmpty (ScheduleT diff m a)
actions = do
    (NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a))
frees, [m (FreeF (Wait diff) a (ScheduleT diff m a))]
delayed) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (ScheduleT diff m a)
actions
    forall diff (m :: * -> *) a.
(TimeDifference diff, Ord diff, Monad m, MonadSchedule m) =>
NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a))
-> [ScheduleT diff m a]
-> ScheduleT diff m (NonEmpty a, [ScheduleT diff m a])
shiftList (forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
sortBy forall diff a b.
Ord diff =>
FreeF (Wait diff) a b -> FreeF (Wait diff) a b -> Ordering
compareFreeFWait NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a))
frees) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [m (FreeF (Wait diff) a (ScheduleT diff m a))]
delayed
    where
      -- We disregard the inner values @a@ and @b@,
      -- thus this is not an 'Ord' instance.
      compareFreeFWait
        :: Ord diff
        => FreeF (Wait diff) a b
        -> FreeF (Wait diff) a b
        -> Ordering
      compareFreeFWait :: forall diff a b.
Ord diff =>
FreeF (Wait diff) a b -> FreeF (Wait diff) a b -> Ordering
compareFreeFWait (Pure a
_) (Pure a
_) = Ordering
EQ
      compareFreeFWait (Pure a
_) (Free Wait diff b
_) = Ordering
LT
      compareFreeFWait (Free Wait diff b
_) (Pure a
_) = Ordering
GT
      compareFreeFWait (Free Wait diff b
wait1) (Free Wait diff b
wait2) = forall diff a. Ord diff => Wait diff a -> Wait diff a -> Ordering
compareWait Wait diff b
wait1 Wait diff b
wait2

      -- Separate pure from free values
      partitionFreeF
        :: [FreeF f a b]
        -> ([a], [f b])
      partitionFreeF :: forall (f :: * -> *) a b. [FreeF f a b] -> ([a], [f b])
partitionFreeF [] = ([], [])
      partitionFreeF (Pure a
a  : [FreeF f a b]
xs) = let ([a]
as, [f b]
fbs) = forall (f :: * -> *) a b. [FreeF f a b] -> ([a], [f b])
partitionFreeF [FreeF f a b]
xs in (a
a forall a. a -> [a] -> [a]
: [a]
as, [f b]
fbs)
      partitionFreeF (Free f b
fb : [FreeF f a b]
xs) = let ([a]
as, [f b]
fbs) = forall (f :: * -> *) a b. [FreeF f a b] -> ([a], [f b])
partitionFreeF [FreeF f a b]
xs in ([a]
as, f b
fb forall a. a -> [a] -> [a]
: [f b]
fbs)

      -- Shift a waiting action by some duration
      shift
        :: TimeDifference diff
        => diff
        -> Wait diff a
        -> Wait diff a
      shift :: forall diff a.
TimeDifference diff =>
diff -> Wait diff a -> Wait diff a
shift diff
diff1 (Wait diff
diff2 a
a) = forall diff a. diff -> a -> Wait diff a
Wait (diff
diff2 forall d. TimeDifference d => d -> d -> d
`difference` diff
diff1) a
a

      -- Shift a list of free actions by the duration of the head
      -- (assuming the list is sorted).
      -- If the head is pure, return it with the remaining actions,
      -- otherwise wait the minimum duration, give the continuation of the head,
      -- and shift the remaining actions by that minimum duration.
      shiftListOnce
        :: TimeDifference diff
        => NonEmpty (FreeF (Wait diff) a b)
        -> Either
             (NonEmpty a, [Wait diff b]) -- Pure value has completed
             (Wait diff (b, [Wait diff b])) -- All values wait
      shiftListOnce :: forall diff a b.
TimeDifference diff =>
NonEmpty (FreeF (Wait diff) a b)
-> Either
     (NonEmpty a, [Wait diff b]) (Wait diff (b, [Wait diff b]))
shiftListOnce NonEmpty (FreeF (Wait diff) a b)
actions = case forall (f :: * -> *) a b. [FreeF f a b] -> ([a], [f b])
partitionFreeF forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
toList NonEmpty (FreeF (Wait diff) a b)
actions of
        (a
a : [a]
as, [Wait diff b]
waits) -> forall a b. a -> Either a b
Left (a
a forall a. a -> [a] -> NonEmpty a
:| [a]
as, [Wait diff b]
waits)
        ([], Wait diff
diff b
cont : [Wait diff b]
waits) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall diff a. diff -> a -> Wait diff a
Wait diff
diff (b
cont, forall diff a.
TimeDifference diff =>
diff -> Wait diff a -> Wait diff a
shift diff
diff forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Wait diff b]
waits)

      -- Repeatedly shift the list by the smallest available waiting duration
      -- until one action returns as pure.
      -- Return its result, together with the remaining free actions.
      shiftList
        :: (TimeDifference diff, Ord diff, Monad m, MonadSchedule m)
        => NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a))
        -- ^ Actionable
        -> [ScheduleT diff m a]
        -- ^ Delayed
        -> ScheduleT diff m (NonEmpty a, [ScheduleT diff m a])
      -- FIXME Don't I need to shift delayed as well?
      shiftList :: forall diff (m :: * -> *) a.
(TimeDifference diff, Ord diff, Monad m, MonadSchedule m) =>
NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a))
-> [ScheduleT diff m a]
-> ScheduleT diff m (NonEmpty a, [ScheduleT diff m a])
shiftList NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a))
actions [ScheduleT diff m a]
delayed = case forall diff a b.
TimeDifference diff =>
NonEmpty (FreeF (Wait diff) a b)
-> Either
     (NonEmpty a, [Wait diff b]) (Wait diff (b, [Wait diff b]))
shiftListOnce NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a))
actions of
        -- Some actions returned. Wrap up the remaining ones.
        Left (NonEmpty a
as, [Wait diff (ScheduleT diff m a)]
waits) -> forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty a
as, [ScheduleT diff m a]
delayed forall a. [a] -> [a] -> [a]
++ ((forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. f b -> FreeF f a b
Free) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Wait diff (ScheduleT diff m a)]
waits))
        -- No action has returned.
        -- Wait the remaining time and start scheduling again.
        Right (Wait diff
diff (ScheduleT diff m a
cont, [Wait diff (ScheduleT diff m a)]
waits)) -> do
          forall (m :: * -> *) diff. Monad m => diff -> ScheduleT diff m ()
wait diff
diff
          let ([Wait diff (ScheduleT diff m a)]
zeroWaits, [Wait diff (ScheduleT diff m a)]
nonZeroWaits) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall diff. (Eq diff, TimeDifference diff) => diff -> Bool
isZero forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall diff a. Wait diff a -> diff
getDiff) [Wait diff (ScheduleT diff m a)]
waits
              zeroWaitsUnwrapped :: [ScheduleT diff m a]
zeroWaitsUnwrapped = forall diff a. Wait diff a -> a
awaited forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Wait diff (ScheduleT diff m a)]
zeroWaits
          forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule (ScheduleT diff m a
cont forall a. a -> [a] -> NonEmpty a
:| [ScheduleT diff m a]
delayed forall a. [a] -> [a] -> [a]
++ [ScheduleT diff m a]
zeroWaitsUnwrapped forall a. [a] -> [a] -> [a]
++ (forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. f b -> FreeF f a b
Free forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Wait diff (ScheduleT diff m a)]
nonZeroWaits))