{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ApplicativeDo #-}
module Control.Plan.Core (module Control.Plan.Core) where
import Prelude hiding ((.),id)
import qualified Data.Bifunctor as Bifunctor
import Data.Semigroup
import Data.Foldable
import Data.Bifoldable
import Data.Bitraversable
import Data.Bifunctor(Bifunctor,bimap)
import Data.Bifunctor.Clown
import Data.Functor.Identity
import Data.Functor.Compose
import Data.Tree
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
import Data.Profunctor (Profunctor(..),Star(..))
import Control.Category
import Control.Arrow
import Control.Monad
import Control.Comonad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Streaming (hoist)
import qualified Streaming.Prelude
import Streaming.Prelude (Stream,Of(..),yield,next,effects)
data Plan s w m i o = Plan (Steps s w) (Star (Stream (Of Tick') m) i o) deriving Functor
instance (Semigroup w,Monoid w,Monad m) => Applicative (Plan s w m i) where
pure x = Plan mempty (pure x)
Plan forest1 f <*> Plan forest2 x = Plan (forest1 `mappend` forest2) (f <*> x)
instance (Semigroup w,Monoid w,Monad m) => Category (Plan s w m) where
id = Plan mempty (Star (runKleisli id))
(Plan forest1 (Star f1)) . (Plan forest2 (Star f2)) =
Plan (forest2 `mappend` forest1) (Star (f2 >=> f1))
instance (Semigroup w,Monoid w,Monad m) => Arrow (Plan s w m) where
arr f = Plan mempty (Star (runKleisli (arr f)))
first (Plan forest (Star f)) = Plan forest (Star (runKleisli (first (Kleisli f))))
instance (Semigroup w,Monoid w,Monad m) => Profunctor (Plan s w m) where
lmap f p = f ^>> p
rmap f p = p >>^ f
data Steps s w = Steps !(Seq (w,s,Mandatoriness,Steps s w)) w
deriving (Functor,Foldable,Traversable,Eq,Show)
data Mandatoriness = Skippable
| Mandatory
deriving (Show,Eq,Ord)
instance Bifunctor Steps where
first f (Steps steps w) =
let go (w',e,mandatoriness',substeps) = (w',f e,mandatoriness',Bifunctor.first f substeps)
in Steps (fmap go steps) w
second = fmap
instance Bifoldable Steps where
bifoldMap g f (Steps steps w) =
foldMap (\(w',s,_,substeps) -> f w'
`mappend`
g s
`mappend`
bifoldMap g f substeps) steps
`mappend`
f w
instance Bitraversable Steps where
bitraverse g f (Steps steps w) =
Steps <$> traverse innertraverse steps <*> f w
where
innertraverse (w',e,mandatoriness',substeps) =
(,,,) <$> f w' <*> g e <*> pure mandatoriness' <*> bitraverse g f substeps
instance Semigroup w => Semigroup (Steps s w) where
Steps s1 w1 <> Steps s2 w2 =
case Seq.viewl s2 of
Seq.EmptyL -> Steps s1 (w1 <> w2)
(w',s,mandatoriness',substeps) Seq.:< s2' ->
Steps (s1 <> ((w1 <> w',s,mandatoriness',substeps) Seq.<| s2')) w2
instance (Semigroup w,Monoid w) => Monoid (Steps s w) where
mempty = Steps mempty mempty
mappend = (<>)
foldSteps :: ([(w,s,Mandatoriness,r)] -> w -> r)
-> Steps s w
-> r
foldSteps f = foldSteps' (\steps -> f (toList steps))
foldSteps' :: (Seq (w,s,Mandatoriness,r) -> w -> r) -> Steps s w -> r
foldSteps' f = go
where
go (Steps steps w) =
f (fmap (\(w',e',mandatoriness',substeps) -> (w',e',mandatoriness',go substeps)) steps) w
bimapSteps :: (s -> s') -> (w -> w') -> Plan s w m i o -> Plan s' w' m i o
bimapSteps f g (Plan steps star) = Plan (Bifunctor.bimap f g steps) star
zoomSteps :: Monoid w' => ((w -> Identity w) -> w' -> Identity w') -> Plan s w m i o -> Plan s w' m i o
zoomSteps setter = bimapSteps id (\w -> set' w mempty)
where
set' w = runIdentity . setter (Identity . const w)
hoistPlan :: Monad m => (forall x. m x -> n x) -> Plan s w m i o -> Plan s w n i o
hoistPlan trans (Plan steps (Star f)) = Plan steps (Star (hoist trans . f))
data Tick' = Skipped' | Started' | Finished' deriving (Eq,Ord,Enum,Show)
getSteps :: Plan s w m i o -> Steps s w
getSteps (Plan steps _) = steps
mandatoriness :: Steps s w -> Steps (Mandatoriness,s) w
mandatoriness (Steps steps w) = Steps (fmap go steps) w
where
go (w',s,mandatory,substeps) = (w',(mandatory,s),mandatory,mandatoriness substeps)
step :: (Monoid w,Monad m) => s -> Plan s w m i o -> Plan s w m i o
step s (Plan forest (Star f)) =
Plan (Steps (Seq.singleton (mempty,s,Mandatory,forest)) mempty)
(Star (\x -> yield Started' *> f x <* yield Finished'))
skippable :: (Monoid w,Monad m) => s -> Plan s w m i o -> Plan s w m (Maybe i) ()
skippable s (Plan forest (Star f)) =
Plan (Steps (Seq.singleton (mempty,s,Skippable,forest)) mempty)
(Star (\m -> case m of
Just x -> yield Started' *> f x *> yield Finished'
Nothing -> yield Skipped'))
foretell :: (Monad m) => w -> Plan s w m i ()
foretell w = Plan (Steps mempty w) (pure ())
plan :: (Semigroup w,Monoid w,Monad m) => m o -> Plan s w m i o
plan x = Plan mempty (Star (const (lift x)))
plan' :: (Semigroup w,Monoid w,Monad m) => (i -> m o) -> Plan s w m i o
plan' f = Plan mempty (Star (lift . f))
{-# DEPRECATED kplan "Use plan' instead." #-}
kplan :: (Semigroup w,Monoid w,Monad m) => (i -> m o) -> Plan s w m i o
kplan = plan'
planIO :: (Semigroup w,Monoid w,MonadIO m) => IO o -> Plan s w m i o
planIO x = Plan mempty (Star (const (liftIO x)))
planIO' :: (Semigroup w,Monoid w,MonadIO m) => (i -> IO o) -> Plan s w m i o
planIO' f = Plan mempty (Star (liftIO . f))
{-# DEPRECATED kplanIO "Use planIO' instead." #-}
kplanIO :: (Semigroup w,Monoid w,MonadIO m) => (i -> IO o) -> Plan s w m i o
kplanIO = planIO'
zipStepsi :: Forest a -> Steps r w -> Maybe (Steps (a,r) w)
zipStepsi forest (Steps substeps w)
| length forest == length substeps =
let paired = Seq.zipWith (\(Node a subforest) (w',s,mandatory,substeps') ->
(w',(a,s),mandatory,zipStepsi subforest substeps'))
(Seq.fromList forest)
substeps
go (w',s,mandatory,ms) = fmap (\x -> (w',s,mandatory,x)) ms
in flip Steps w <$> traverse go paired
| otherwise = Nothing
zipSteps :: Forest s' -> Plan s w m i o -> Maybe (Plan (s',s) w m i o)
zipSteps forest (Plan steps star) = Plan <$> zipStepsi forest steps <*> pure star
completedness :: Tick s t -> Tick (Maybe (Either t (t,Maybe t)),s) t
completedness (Tick (Context {completed,current,pending}:|contexts) progress) =
let startingTime = extract completed
(progress',time') = progressCompletedness startingTime progress
in Tick (Context (adapt (instants completed))
(time',current)
(fmap (fmap (\s -> (Nothing,s))) pending)
:| map (contextCompletedness (\t -> Right (t,Nothing))) contexts)
progress'
contextCompletedness :: (t -> (Either t (t,Maybe t)))
-> Context s t
-> Context (Maybe (Either t (t,Maybe t)),s) t
contextCompletedness tf (Context {completed,current,pending}) =
Context (adapt (instants completed))
(Just (tf (extract completed)),current)
(fmap (fmap (\s -> (Nothing,s))) pending)
adapt :: Timeline (Either t (t,t),s) t -> Timeline (Maybe (Either t (t,Maybe t)),s) t
adapt timeline =
let go = Bifunctor.first (Just . bimap id (fmap Just))
in Bifunctor.first go timeline
progressCompletedness :: t -> Progress s t -> (Progress (Maybe (Either t (t,Maybe t)),s) t, Maybe (Either t (t,Maybe t)))
progressCompletedness startingTime = \case
Skipped forest -> (Skipped $ fmap (fmap (\s -> (Just (Left startingTime),s))) forest
,Just (Left startingTime))
Started forest -> (Started $ fmap (fmap (\s -> (Nothing,s))) forest
,Just (Right (startingTime,Nothing)))
Finished timeline -> (Finished $ adapt (instants timeline)
,Just (Right (startingTime,Just (extract timeline))))
unliftPlan :: Monad m => Plan s w m () o -> m o
unliftPlan p = extract <$> effects (runKPlan (pure ()) p ())
unliftPlan' :: Monad m => Plan s w m i o -> i -> m o
unliftPlan' p i = extract <$> effects (runKPlan (pure ()) p i)
{-# DEPRECATED unliftKPlan "Use unliftPlan' instead." #-}
unliftKPlan :: Monad m => Plan s w m i o -> i -> m o
unliftKPlan = unliftPlan'
data Timeline s t = Timeline !(Seq (t,s,Either (Forest s) (Timeline s t))) t
deriving (Functor,Foldable,Traversable,Eq,Show)
instance Bifunctor Timeline where
first f (Timeline steps w) =
let go (w',e,substeps) = (w',f e,bimap (fmap (fmap f)) (Bifunctor.first f) substeps)
in Timeline (fmap go steps) w
second = fmap
instance Bifoldable Timeline where
bifoldMap g f (Timeline steps w) =
foldMap (\(w',e,substeps) -> f w'
`mappend`
g e
`mappend`
bifoldMap (mconcat . map (foldMap g)) (bifoldMap g f) substeps) steps
`mappend`
f w
instance Bitraversable Timeline where
bitraverse g f (Timeline steps w) =
Timeline <$> traverse innertraverse steps <*> f w
where
innertraverse (w',e,substeps) = (,,)
<$> f w'
<*> g e
<*> bitraverse (traverse (traverse g)) (bitraverse g f) substeps
instance Comonad (Timeline s) where
extract (Timeline _ t) = t
duplicate tip@(Timeline steps _) =
let go steps' = case Seq.viewr steps' of
Seq.EmptyR -> error "should never happen"
lefto Seq.:> (t',c',timeline') -> ((Timeline lefto t'),c',fmap duplicate timeline')
in Timeline (fmap go (Seq.inits steps)) tip
instants :: Timeline s t -> Timeline (Either t (t,t),s) t
instants (Timeline past limit) = Timeline (fmap go past) limit
where
go (t',c',Left forest) = (t',(Left t',c') ,Left (fmap (fmap (\x -> (Left t',x))) forest))
go (t',c',Right timeline') = (t',(Right (t',extract timeline'),c'),Right (instants timeline'))
foldTimeline :: ([(t,s,Either (Forest s) r)] -> t -> r)
-> Timeline s t
-> r
foldTimeline f = foldTimeline' (\steps -> f (toList steps))
foldTimeline' :: (Seq (t,c,Either (Forest c) r) -> t -> r) -> Timeline c t -> r
foldTimeline' f = go
where
go (Timeline steps t) = f (fmap (\(t',c',foreste) -> (t',c',fmap go foreste)) steps) t
data Context s t = Context
{
completed :: Timeline s t
, current :: s
, pending :: Forest s
} deriving (Functor,Foldable,Traversable,Eq,Show)
instance Bifunctor Context where
first f (Context {completed,current,pending}) =
Context (Bifunctor.first f completed)
(f current)
(fmap (fmap f) pending)
second = fmap
data Tick s t = Tick (NonEmpty (Context s t)) (Progress s t)
deriving (Functor,Foldable,Traversable,Eq,Show)
instance Bifunctor Tick where
first f (Tick contexts progress) =
Tick (fmap (Bifunctor.first f) contexts) (Bifunctor.first f progress)
second = fmap
instance Bifoldable Tick where
bifoldMap g f (Tick contexts progress) =
foldMap (\(Context {completed,current}) -> bifoldMap g f completed `mappend` g current)
(Data.List.NonEmpty.reverse contexts)
`mappend`
bifoldMap g f progress
`mappend`
foldMap (\(Context {pending}) -> foldMap (foldMap g) pending)
contexts
instance Bitraversable Tick where
bitraverse g f (Tick contexts progress) = do
phase1r <- traverse (\(Context {completed,current}) -> (,)
<$> bitraverse g f completed
<*> g current)
(Data.List.NonEmpty.reverse contexts)
progress' <- bitraverse g f progress
phase2 <- traverse (\(Context {pending}) -> traverse (traverse g) pending)
contexts
pure (Tick (fmap (\((completed',current'),pending') -> Context completed' current' pending')
(Data.List.NonEmpty.zip (Data.List.NonEmpty.reverse phase1r) phase2))
progress')
instance Sylvan Tick where
toForest (Tick contexts progress) = foldl ctx2forest (toForest progress) contexts
where
ctx2forest below (Context {completed,current,pending}) =
toForest completed ++ [Node current below] ++ pending
data Progress s t = Skipped (Forest s)
| Started (Forest s)
| Finished (Timeline s t)
deriving (Functor,Foldable,Traversable,Eq,Show)
instance Sylvan Progress where
toForest progress =
case progress of
Skipped forest -> forest
Started forest -> forest
Finished timeline -> toForest timeline
instance Bifunctor Progress where
first f (Skipped forest) = Skipped (fmap (fmap f) forest)
first f (Started forest) = Skipped (fmap (fmap f) forest)
first f (Finished timeline) = Finished (bimap f id timeline)
second = fmap
instance Bifoldable Progress where
bifoldMap g _ (Skipped forest) = foldMap (foldMap g) forest
bifoldMap g _ (Started forest) = foldMap (foldMap g) forest
bifoldMap g f (Finished timeline) = bifoldMap g f timeline
instance Bitraversable Progress where
bitraverse g _ (Skipped forest) = Skipped <$> traverse (traverse g) forest
bitraverse g _ (Started forest) = Started <$> traverse (traverse g) forest
bitraverse g f (Finished timeline) = Finished <$> (bitraverse g f) timeline
onTick :: Monad m => (tick -> m ()) -> Stream (Of tick) m r -> m r
onTick = Streaming.Prelude.mapM_
runPlan :: Monad m
=> m t
-> Plan s w m () o
-> Stream (Of (Tick s t)) m (Timeline s t,o)
runPlan measurement p = runPlan' measurement p ()
runPlan' :: Monad m
=> m t
-> Plan s w m i o
-> i
-> Stream (Of (Tick s t)) m (Timeline s t,o)
runPlan' makeMeasure (Plan steps (Star f)) initial =
let go state stream =
do n <- lift (next stream)
measure <- lift makeMeasure
case (n,state) of
(Left b,
RunState completed [] []) -> do
return (Timeline completed measure,b)
(Right (Skipped',stream'),
RunState previous (Node root subforest:forest) upwards) -> do
yield (Tick (Context (Timeline previous measure) root forest :| upwards)
(Skipped subforest))
go (RunState (previous Seq.|> (measure,root,Left subforest)) forest upwards)
stream'
(Right (Started',stream'),
RunState previous (Node root subforest:forest) upwards) -> do
yield (Tick (Context (Timeline previous measure) root forest :| upwards)
(Started subforest))
go (RunState mempty subforest (Context (Timeline previous measure) root forest : upwards))
stream'
(Right (Finished',stream'),
RunState previous' [] (ctx@(Context {completed,current,pending}) : upwards)) -> do
let subtimeline = Timeline previous' measure
Timeline previous'' instant = completed
yield (Tick (ctx :| upwards)
(Finished subtimeline))
go (RunState (previous'' Seq.|> (instant,current,Right subtimeline)) pending upwards)
stream'
_ -> error "should never happen"
in go (RunState mempty (toForest steps) []) (f initial)
{-# DEPRECATED runKPlan "Use runPlan' instead." #-}
runKPlan :: Monad m
=> m t
-> Plan s w m i o
-> i
-> Stream (Of (Tick s t)) m (Timeline s t,o)
runKPlan = runPlan'
data RunState s t = RunState !(Seq (t,s,Either (Forest s) (Timeline s t)))
!(Forest s)
![Context s t]
class (Bitraversable l) => Sylvan l where
toForest :: l n a -> Forest n
instance Sylvan Steps where
toForest (Steps steps _) =
map (\(_,e,_,steps') -> Node e (toForest steps')) (toList steps)
instance Sylvan Timeline where
toForest (Timeline past _) = fmap (\(_,c,timeline') -> Node c (either id toForest timeline')) (toList past)
instance Sylvan (Clown (Compose [] Tree)) where
toForest (Clown (Compose forest)) = forest