diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -0,0 +1,12 @@ +2.0.0.0 +======= + +BREAKING CHANGES + +- *Lasagne* is now *Sylvan*. +- runPlanK -> runKPlan +- unliftPlanK -> uliftKPlan +- planK -> kplan +- planKIO -> kplanIO +- Removed non-essential *paths* function. + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,7 +11,7 @@ - The script fails at minute 45 because of a syntax error. - The script fails at minute 45 because it requests a missing resource whose - avaliability could have been checked at script start. + availability could have been checked when the script started. - It is difficult to ascertain how far along the execution we are at minute 45. The first problem is solved by using a statically typed language or, for diff --git a/lib/Control/Plan.hs b/lib/Control/Plan.hs --- a/lib/Control/Plan.hs +++ b/lib/Control/Plan.hs @@ -3,18 +3,17 @@ >>> :{ let example :: Plan String [Int] IO () () example = - step "(a)" (step "(a.a)" (foretell [1] *> - plan (threadDelay 1e6)) *> - step "(a.a)" (foretell [2] *> - plan (threadDelay 1e6))) *> - step "(b)" (step "(b.a)" (foretell [3] *> - plan (threadDelay 1e6)) *> - step "(b.b)" (foretell [4] *> - plan (threadDelay 1e6))) + step "a" (step "b" (foretell [1] *> plan (threadDelay 1e6)) + *> + step "c" (foretell [2] *> plan (threadDelay 1e6))) + *> + step "d" (step "e" (foretell [3] *> plan (threadDelay 1e6)) + *> + step "f" (foretell [4] *> plan (threadDelay 1e6))) in bifoldMap id (foldMap Prelude.show) (getSteps example) :} -"(a)(a.a)1(a.a)2(b)(b.a)3(b.b)4" +"ab1c2de3f4" Some possible use cases: @@ -28,14 +27,13 @@ - Get progress updates for your script by declaring (possibly nested) steps with 'step', running the 'Plan' with 'runPlan', and providing a notification - callback with 'onTick', probably using 'tickToForest' and + callback with 'onTick', probably using 'completedness','toForest' and 'Data.Tree.drawForest' to render the updates. - Run a 'Plan' with 'runPlan', use 'instants' an 'toForest' on the resulting - 'Timeline' to get the durations of each step, then use 'zipSteps' on the same - 'Plan' and - run it again. Now whenever a step finishes we can know if it took more or - less than in the previous execution. + 'Timeline' to get the durations of each step, then use 'zipSteps' on the same + 'Plan' and run it again. Now whenever a step finishes we can know if it took + more or less than in the previous execution. -} module Control.Plan ( @@ -43,8 +41,8 @@ Plan ,plan ,planIO - ,planK - ,planKIO + ,kplan + ,kplanIO -- ** Declaring steps and annotations ,step ,skippable @@ -65,18 +63,18 @@ ,unliftPlan ,runPlan ,onTick - ,tickToForest ,Tick(..) + ,completedness ,Context(..) ,Progress(..) ,Timeline ,instants ,foldTimeline -- ** Running arrow plans - ,unliftPlanK - ,runPlanK - -- * The Lasagna typeclass - ,Lasagna(..) + ,unliftKPlan + ,runKPlan + -- * The Sylvan typeclass + ,Sylvan(..) -- * Re-exports ,Data.Bifunctor.bimap ,Data.Bifoldable.bifoldMap @@ -100,6 +98,7 @@ {- $setup >>> :set -XNumDecimals +>>> :set -XArrows >>> import Control.Applicative >>> import Control.Plan >>> import Control.Concurrent(threadDelay) diff --git a/lib/Control/Plan/Core.hs b/lib/Control/Plan/Core.hs --- a/lib/Control/Plan/Core.hs +++ b/lib/Control/Plan/Core.hs @@ -8,6 +8,8 @@ {-# language RankNTypes #-} {-# language ViewPatterns #-} {-# language NamedFieldPuns #-} +{-# language LambdaCase #-} +{-# language ApplicativeDo #-} module Control.Plan.Core (module Control.Plan.Core) where import Prelude hiding ((.),id) @@ -21,6 +23,7 @@ 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(..)) @@ -44,7 +47,7 @@ -- Computations can have monoidal resource annotations of type @w@. -- -- The structure of steps and the monoidal annotations can be inspected before --- executing the computations. +-- executing the 'Plan'. data Plan s w m i o = Plan (Steps s w) (Star (Stream (Of Tick') m) i o) deriving Functor instance (Monoid w,Monad m) => Applicative (Plan s w m i) where @@ -108,7 +111,7 @@ (w',s,mandatoriness',substeps) Seq.:< s2' -> Steps (s1 `mappend` ((w1 `mappend` w',s,mandatoriness',substeps) Seq.<| s2')) w2 --- | A catamorphism on 'Steps', that "destroys" the 'Step' value from the +-- | A catamorphism on 'Steps', that "destroys" the 'Steps' value from the -- leaves upwards. -- -- Unlike 'foldMap' or 'bifoldMap', it allows a more structured analysis of the @@ -188,12 +191,12 @@ planIO x = Plan mempty (Star (const (liftIO x))) -- | Lift a Kleisli arrow to a 'Plan'. -planK :: (Monoid w,Monad m) => (i -> m o) -> Plan s w m i o -planK f = Plan mempty (Star (lift . f)) +kplan :: (Monoid w,Monad m) => (i -> m o) -> Plan s w m i o +kplan f = Plan mempty (Star (lift . f)) -- | Lift a Kleisli arrow working in 'IO' to a 'Plan'. -planKIO :: (Monoid w,MonadIO m) => (i -> IO o) -> Plan s w m i o -planKIO f = Plan mempty (Star (liftIO . f)) +kplanIO :: (Monoid w,MonadIO m) => (i -> IO o) -> Plan s w m i o +kplanIO f = Plan mempty (Star (liftIO . f)) zipSteps' :: Forest a -> Steps r w -> Maybe (Steps (a,r) w) zipSteps' forest (Steps substeps w) @@ -217,62 +220,51 @@ zipSteps :: Forest s' -> Plan s w m i o -> Maybe (Plan (s',s) w m i o) zipSteps forest (Plan steps star) = Plan <$> zipSteps' forest steps <*> pure star --- | Transform a 'Tick' into a form more suitable for rendering with functions --- like 'Data.Tree.drawForest'. +-- | A given step might not have been reached yet. It it has been reached, +-- either it has been skipped at a certain time, or started at a certain time. +-- If if has been started, maybe it has already finished, too. -- --- A given step might not have been reached yet. It it has been reached, either --- it has been skipped at a certain time, or started at a certain time. If if --- has been started, maybe it has already finised, too. -tickToForest :: Tick s t -> Forest (Maybe (Either t (t,Maybe t)),s) -tickToForest (Tick upwards@(Context {completed,current,pending}:|contexts) progress) = - case progress of - Skipped forest -> foldl contextToForest - ( completedToForest completed - ++ - [Node (Just (Left (extract completed)) - ,current) - (skippedToForest forest (extract completed))] - ++ - pendingToForest pending ) - contexts - Started forest -> foldl contextToForest - (pendingToForest forest) - upwards - Finished timeline -> foldl contextToForest - ( completedToForest completed - ++ - [Node (Just (Right (extract completed,Just (extract timeline))) - ,current) - (completedToForest timeline)] - ++ pendingToForest pending ) - contexts - -contextToForest :: Forest (Maybe (Either t (t,Maybe t)),s) - -> Context s t - -> Forest (Maybe (Either t (t,Maybe t)),s) -contextToForest below (Context {completed,current,pending}) = - completedToForest completed - ++ [Node (Just (Right (extract completed,Nothing)),current) below] - ++ pendingToForest pending +-- This function can be used in combination with 'toForest' and +-- 'Data.Tree.drawForest' to render the state of each step for a 'Tick'. +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' -completedToForest :: Timeline c t -> Forest (Maybe (Either t (t,Maybe t)),c) -completedToForest (toForest . instants -> forest) = fmap (fmap go) forest - where - go = Bifunctor.first (Just . bimap id (fmap Just)) +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) -pendingToForest :: Forest c -> Forest (Maybe (Either t (t,Maybe t)),c) -pendingToForest forest = map (fmap (\c -> (Nothing,c))) forest +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 -skippedToForest :: Forest c -> t -> Forest (Maybe (Either t (t,Maybe t)),c) -skippedToForest forest t = map (fmap (\c -> (Just (Left t),c))) forest +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)))) -- | Forget that there is a plan, get the underlying monadic action. unliftPlan :: Monad m => Plan s w m () o -> m o -unliftPlan p = extract <$> effects (runPlanK (pure ()) p ()) +unliftPlan p = extract <$> effects (runKPlan (pure ()) p ()) -- | Forget that there is a plan, get the underlying Kleisli arrow. -unliftPlanK :: Monad m => Plan s w m i o -> i -> m o -unliftPlanK p i = extract <$> effects (runPlanK (pure ()) p i) +unliftKPlan :: Monad m => Plan s w m i o -> i -> m o +unliftKPlan p i = extract <$> effects (runKPlan (pure ()) p i) -- | A 'Data.Tree.Forest' of steps tags of type @s@ interspersed with -- measurements of type @t@. @@ -367,6 +359,35 @@ 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 + -- | The execution of a 'Plan' can make progress by skipping a step, starting a -- step, or finishing a step. data Progress s t = Skipped (Forest s) -- ^ Provides the substeps that were skipped. @@ -374,12 +395,30 @@ | Finished (Timeline s t) -- ^ Provides a 'Timeline' of measurements for the completed substeps. 'extract' for the 'Timeline' gives the finishing measurement for the current step. 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 + + -- | Specify a monadic callback for processing each 'Tick' update. onTick :: Monad m => (tick -> m ()) -> Stream (Of tick) m r -> m r onTick = Streaming.Prelude.mapM_ @@ -400,15 +439,15 @@ => m t -- ^ Monadic measurement to be taken on each tick. -> Plan s w m () o -- ^ Plan without input. -> Stream (Of (Tick s t)) m (Timeline s t,o) -runPlan measurement p = runPlanK measurement p () +runPlan measurement p = runKPlan measurement p () -- | Like 'runPlan', but for 'Arrow'-like 'Plan's that take inputs. -runPlanK :: Monad m +runKPlan :: Monad m => m t -- ^ Monadic measurement to be taken on each tick. -> Plan s w m i o -- ^ Plan that takes input. -> i -> Stream (Of (Tick s t)) m (Timeline s t,o) -runPlanK makeMeasure (Plan steps (Star f)) initial = +runKPlan makeMeasure (Plan steps (Star f)) initial = let go state stream = do n <- lift (next stream) measure <- lift makeMeasure @@ -443,49 +482,29 @@ !(Forest s) ![Context s t] --- | Instances of 'Lasagna' are like 'Data.Tree.Forest's where each list of --- sibling nodes of type @n@ is surrounded and interspersed with annotations of --- type @a@. Some instances might add extra information to each node, or --- allow alternative branches. -class (Bitraversable l) => Lasagna l where - -- | Substitute each node with the ascending path towards its topmost - -- parent. - paths :: l n a -> l (NonEmpty n) a +-- | Instances of 'Sylvan' are 'Data.Tree.Forest's with nodes of type @n@, +-- interspersed with annotations of type @a@, and perhaps some other extra +-- information. +-- +-- They must satisfy +-- +-- > bifoldMap f (\_ -> mempty) s == foldMap (foldMap f) (toForest s) +class (Bitraversable l) => Sylvan l where -- | Forget about the annotations and return the underlying 'Data.Tree.Forest'. toForest :: l n a -> Forest n -- | 'toForest' forgets about the annotations and returns a 'Forest' of step -- tags. -instance Lasagna Steps where - paths steps = - let algebra ws r acc = Steps (fmap (downwards acc) ws) r - downwards acc (w',s',mandatoriness',func) = (w',s':|acc,mandatoriness',func (s':acc)) - in foldSteps' algebra steps [] +instance Sylvan Steps where toForest (Steps steps _) = map (\(_,e,_,steps') -> Node e (toForest steps')) (toList steps) -- | 'toForest' forgets about the measurements and returns a 'Forest' of step -- tags. -instance Lasagna Timeline where - paths steps = - let algebra ws r acc = Timeline (fmap (downwards acc) ws) r - downwards acc (w',s',funce) = (w',s':|acc,bimap (fmap (inheritTree (s':acc))) (\f -> f (s':acc)) funce) - in foldTimeline' algebra steps [] +instance Sylvan Timeline where toForest (Timeline past _) = fmap (\(_,c,timeline') -> Node c (either id toForest timeline')) (toList past) --- | A 'Data.Tree.Forest' is a 'Lasagna' for which no annotations exist. -instance Lasagna (Clown (Compose [] Tree)) where - paths (Clown (Compose forest)) = (Clown (Compose (fmap (inheritTree []) forest))) +-- | A 'Data.Tree.Forest' is a 'Sylvan' for which no annotations exist. +instance Sylvan (Clown (Compose [] Tree)) where toForest (Clown (Compose forest)) = forest - -inheritTree :: [a] -> Tree a -> Tree (NonEmpty a) -inheritTree acc tree = foldTree' algebra tree acc where - algebra :: a -> [[a] -> Tree (NonEmpty a)] -> [a] -> Tree (NonEmpty a) - algebra a fs as = Node (a:|as) (fs <*> [a:as]) - --- | A tree catamorphism. This function already exists in the latest version of --- "containers" -foldTree' :: (a -> [b] -> b) -> Tree a -> b -foldTree' f = go where - go (Node x ts) = f x (map go ts) diff --git a/plan-applicative.cabal b/plan-applicative.cabal --- a/plan-applicative.cabal +++ b/plan-applicative.cabal @@ -1,5 +1,5 @@ name: plan-applicative -version: 1.0.0.0 +version: 2.0.0.0 synopsis: Applicative/Arrow for resource estimation and progress tracking. description: This module contains a writer-like Applicative for giving monoidal annotations to underlying computations. The diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -11,6 +11,7 @@ import Data.Monoid import Data.Foldable import Data.Tree +import Data.Functor.Const import Control.Category import Control.Arrow @@ -23,7 +24,7 @@ import Control.Plan.Core import Test.Tasty -import Test.Tasty.HUnit +import Test.Tasty.HUnit (testCase,assertEqual,assertBool) import Streaming import qualified Streaming.Prelude @@ -75,8 +76,8 @@ (bifoldMap (pure . Left) (map Right) . getSteps $ multi) testPathsMulti :: IO () -testPathsMulti = assertEqual "" [["a"],["a1","a"],["a2","a"],["b"],["b1","b"],["b2","b"]] - (map toList . bifoldMap pure (const []) . paths . getSteps $ multi) +testPathsMulti = assertEqual "" ["a","a1","a2","b","b1","b2"] + (map toList . bifoldMap pure (const []) . getSteps $ multi) progressToTick' :: Progress s t -> Tick' progressToTick' (Skipped {}) = Skipped' @@ -118,7 +119,15 @@ ,("h" ,["b"],Finished') ] simpleTicks - let forestTicks = take 3 . map tickToForest $ ticks + assertBool "" $ all (\tick -> bifoldMap id (const mempty) tick + == + foldMap (foldMap id) (toForest tick)) + ticks + assertBool "" $ all (\tick -> (getConst (bitraverse (\s -> Const s) (\t -> Const mempty) tick)) + == + foldMap (foldMap id) (toForest tick)) + ticks + let forestTicks = take 3 . map (toForest . completedness) $ ticks assertEqual "tickForests" [[Node (Just (Right ('b',Nothing)),"a") [Node (Nothing,"a1") [] ,Node (Nothing,"a2") []] ,Node (Nothing,"b") [Node (Nothing,"b1") [] @@ -181,7 +190,7 @@ ,("f",["b"],Finished') ,("h",["sb"],Skipped')] simpleTicks - let forestTicks = take 1 . map tickToForest $ ticks + let forestTicks = take 1 . map (toForest . completedness) $ ticks assertEqual "tickForests" [[Node (Just (Right ('b',Nothing)),"a") [] ,Node (Nothing,"sa") [] ,Node (Nothing,"b") []