{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Control.Monad.Schedule.Trans where
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)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Free
import Data.TimeDomain
import Control.Monad.Schedule.Class
data Wait diff a = Wait
{ forall diff a. Wait diff a -> diff
getDiff :: diff
, forall diff a. Wait diff a -> a
awaited :: a
}
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
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
type ScheduleT diff = FreeT (Wait diff)
type Schedule diff = ScheduleT diff Identity
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 ()
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
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
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
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
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
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
:: 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
shiftListOnce
:: TimeDifference diff
=> NonEmpty (FreeF (Wait diff) a b)
-> Either
(NonEmpty a, [Wait diff b])
(Wait diff (b, [Wait diff b]))
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)
shiftList
:: (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 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
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))
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))