diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2016 Daniel Díaz Carrete + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,43 @@ +# plan-applicative + +A writer-like Applicative/Arrow for resource estimation and progress tracking. + +## Motivation + +I run scripts in my machine. Their logic is simple and predictable, even if the +steps are many and take long to complete. + +The following infuriating situations happen: + +- 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. +- 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 +dynamic languages, some kind of [static](https://pypi.python.org/pypi/pyflakes) +[analysis](https://github.com/bbatsov/rubocop) tool. + +For the second problem, we need to have a summary of the resources that the +computation will require, before running the computation itself. This can be +done by hand, adding a new check at the beginning of the script when we change +something further down. But it's easy to forget to do so, and the initial +checks can become out of sync with the main code. It would be nice if each step +of the computation foresaw its own resource needs and these accumulated +automatically as we composed the steps. + +For the third problem, we need a channel that notifies you whenever a step of +the computation starts or finishes. Bonus points if nested steps are supported. + +## Problems + +Currently the *ApplicativeDo* extension doesn't work very well with this +package's *Applicative* because an extant bug in GHC: +[#10892](https://ghc.haskell.org/trac/ghc/ticket/10892). Sequencing actions +whose values are ignored gives an error. + +## Inspiration + +[StaticArrow](http://hackage.haskell.org/package/arrows-0.4.4.1/docs/Control-Arrow-Transformer-Static.html) +from the [arrows](http://hackage.haskell.org/package/arrows) package. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lib/Control/Plan.hs b/lib/Control/Plan.hs new file mode 100644 --- /dev/null +++ b/lib/Control/Plan.hs @@ -0,0 +1,124 @@ +{-| This module exports the 'Plan' Applicative. + +>>> :{ + 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))) + in + bifoldMap id (foldMap Prelude.show) (getSteps example) +:} +"(a)(a.a)1(a.a)2(b)(b.a)3(b.b)4" + +Some possible use cases: + +- Inspect the steps of an existing 'Plan' from @ghci@ using 'getSteps', + 'toForest' and 'Data.Tree.drawForest', as a form of documentation. + +- If your script requires files that must be already present in the file + system, use 'foretell' to annotate each 'Plan' action that requires a file, + then get the global list of files using 'getSteps' and 'foldMap', and check + that they all exist before running the 'Plan' with 'runPlan'. + +- 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 + '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. + +-} +module Control.Plan ( + -- * Constructing plans + Plan + ,plan + ,planIO + ,planK + ,planKIO + -- ** Declaring steps and annotations + ,step + ,skippable + ,foretell + -- * Analyzing plans + ,getSteps + ,Steps + ,mandatoriness + ,Mandatoriness(..) + ,foldSteps + -- * Adapting plans + -- $adapting + ,bimapSteps + ,zoomSteps + ,zipSteps + ,hoistPlan + -- * Running plans + ,unliftPlan + ,runPlan + ,onTick + ,tickToForest + ,Tick(..) + ,Context(..) + ,Progress(..) + ,Timeline + ,instants + ,foldTimeline + -- ** Running arrow plans + ,unliftPlanK + ,runPlanK + -- * The Lasagna typeclass + ,Lasagna(..) + -- * Re-exports + ,Data.Bifunctor.bimap + ,Data.Bifoldable.bifoldMap + ,Data.Bitraversable.bitraverse + ,Control.Comonad.extract + -- $extract + ,Streaming.hoist + ,Streaming.Prelude.effects + -- $effects + ) where + +import Data.Bifunctor +import Data.Bifoldable +import Data.Bitraversable +import Control.Comonad +import Streaming +import Streaming.Prelude + +import Control.Plan.Core + +{- $setup + +>>> :set -XNumDecimals +>>> import Control.Applicative +>>> import Control.Plan +>>> import Control.Concurrent(threadDelay) + +-} + +{- $adapting + + Sometimes, we might need to mix 'Plan's for which step tags and annotations + are of different types. These functions help with that. + +-} + +{- $extract + Besides its usefulness with 'Timeline', 'extract' lets you get the head of a + 'NonEmpty' or the second element of a tuple. +-} + +{- $effects + 'effects' lets you ignore all the update notifications while running a plan, + when you are only interested in the final 'Timeline' and the result. +-} diff --git a/lib/Control/Plan/Core.hs b/lib/Control/Plan/Core.hs new file mode 100644 --- /dev/null +++ b/lib/Control/Plan/Core.hs @@ -0,0 +1,491 @@ +-- | Prefer using the main module. If you manipulate the internals of `Plan` +-- to add fake steps, bad things might happen. + +{-# language DeriveFunctor #-} +{-# language DeriveFoldable #-} +{-# language DeriveTraversable #-} +{-# language FlexibleInstances #-} +{-# language RankNTypes #-} +{-# language ViewPatterns #-} +{-# language NamedFieldPuns #-} +module Control.Plan.Core (module Control.Plan.Core) where + +import Prelude hiding ((.),id) +import qualified Data.Bifunctor as Bifunctor +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.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) + +-- | A computation that takes inputs of type @i@ and produces outputs of type +-- @o@ working in the underlying monad @m@. The 'Applicative' instance cares +-- only about the outputs, the 'Arrow' instance cares about both inputs and +-- outputs. +-- +-- Parts of the computation can be labeled as steps with tags of type @s@. +-- +-- Computations can have monoidal resource annotations of type @w@. +-- +-- The structure of steps and the monoidal annotations can be inspected before +-- executing the computations. +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 + pure x = Plan mempty (pure x) + Plan forest1 f <*> Plan forest2 x = Plan (forest1 `mappend` forest2) (f <*> x) + +instance (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 (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 (Monoid w,Monad m) => Profunctor (Plan s w m) where + lmap f p = f ^>> p + rmap f p = p >>^ f + +-- | A 'Data.Tree.Forest' of steps tags of type @s@ interspersed with monoidal +-- annotations of type @w@. +data Steps s w = Steps !(Seq (w,s,Mandatoriness,Steps s w)) w + deriving (Functor,Foldable,Traversable,Eq,Show) + +-- | Steps of 'Plan's constructed in 'Applicative' fashion are always +-- 'Mandatory'. Only steps declared with 'skippable' are optional. +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 + +-- | 'bifoldMap' allows extracting the steps and the annotations together. +-- +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 Monoid w => Monoid (Steps s w) where + mempty = Steps mempty mempty + Steps s1 w1 `mappend` Steps s2 w2 = + case Seq.viewl s2 of + Seq.EmptyL -> Steps s1 (w1 `mappend` w2) + (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 +-- leaves upwards. +-- +-- Unlike 'foldMap' or 'bifoldMap', it allows a more structured analysis of the +-- annotations, by preserving their relationship with the hierarchy of steps. +-- +foldSteps :: ([(w,s,Mandatoriness,r)] -> w -> r) -- ^ A function that consumes a list of step tags of type @s@, surrounded and interleaved with annotations of type @w@. Each step is also annotated with its mandatoriness and with the result @r@ of consuming its substeps, if there were any. + -> 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 + +-- | Adapt the 'Step' value inside a 'Plan' without extracting it. +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 + +-- | Use a lens setter to "zoom" the monoidal annotations of a 'Plan' into a +-- wider monoidal context. +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) + +-- | Change the underlying monad of a 'Plan'. +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) + +-- | Inspect a plan without executing it. +getSteps :: Plan s w m i o -> Steps s w +getSteps (Plan steps _) = steps + +-- | Decorate each step tag with its mandatoriness. Useful in combination with 'toForest'. +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) + +-- | Declare a step by wrapping an existing plan (which may contain 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')) + +-- | Declare an optional step by wrapping an existing arrow plan. The step will +-- only be executed when the input is 'Just'. +-- +-- This function only makes sense when using the 'Arrow' instance of 'Plan', +-- because for 'Applicative's an effect cannot depend on previously obtained +-- values. +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')) + +-- | Declare a monoidal annotation. The annotation can be later inspected +-- without having to run the 'Plan'. +-- +-- Usually the annotations will represent resources that the 'Plan' is expected +-- to require. +foretell :: (Monad m) => w -> Plan s w m i () +foretell w = Plan (Steps mempty w) (pure ()) + +-- | Lift a monadic action to a 'Plan'. The input type remains polymorphic. +plan :: (Monoid w,Monad m) => m o -> Plan s w m i o +plan x = Plan mempty (Star (const (lift x))) + +-- | Lift an 'IO' action to a 'Plan'. The input type remains polymorphic. +planIO :: (Monoid w,MonadIO m) => IO o -> Plan s w m i o +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)) + +-- | 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)) + +zipSteps' :: Forest a -> Steps r w -> Maybe (Steps (a,r) w) +zipSteps' forest (Steps substeps w) + | length forest == length substeps = + let paired = Seq.zipWith (\(Node a subforest) (w',s,mandatory,substeps') -> + (w',(a,s),mandatory,zipSteps' 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 + +-- | Pair each step tag @s@ inside a 'Plan' with the corresponding element of the 'Forest'. +-- +-- If the forest doesn't have the same structure as the steps, the function +-- fails with 'Nothing'. +-- +-- This function can be useful to annotate each step tag with some information, +-- for example the time duration of the step in a previous execution of the +-- plan. See 'Timeline', 'instants', and 'toForest'. +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 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 + +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)) + +pendingToForest :: Forest c -> Forest (Maybe (Either t (t,Maybe t)),c) +pendingToForest forest = map (fmap (\c -> (Nothing,c))) forest + +skippedToForest :: Forest c -> t -> Forest (Maybe (Either t (t,Maybe t)),c) +skippedToForest forest t = map (fmap (\c -> (Just (Left t),c))) forest + +-- | 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 ()) + +-- | 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) + +-- | A 'Data.Tree.Forest' of steps tags of type @s@ interspersed with +-- measurements of type @t@. +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 + +-- | 'Timeline's always have at least one measurement. 'extract' gives the final measurement. +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 + +-- | Decorate each step tag with either the time the step was skipped, or the +-- time it was started and finished. Useful in combination with 'toForest'. +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')) + +-- | A catamorphism on 'Timeline's, that "destroys" the 'Timeline' value from the +-- leaves upwards. +-- +foldTimeline :: ([(t,s,Either (Forest s) r)] -> t -> r) -- ^ A function that consumes a list of step tags of type @s@, surrounded and interleaved with measurements of type @t@. Each step is also annotated with either its substeps, if it the step was skipped, or the results of consuming the substeps, if it was executed. + -> 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 + +-- | Represents how far we are along a sequence of sibling steps. +-- +-- For the already completed steps, a 'Timeline' of measurements is provided. 'extract' for the 'Timeline' returns the starting measurement of the current step. +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 + +-- | Represents some kind of progress through the 'Steps' of a 'Plan' while the +-- plan executes. +-- +-- The ascending list of contexts provides the current position of the +-- execution along the hierarchy of steps. +-- +-- If the plan only has a linear sequence of steps, the list will have only one +-- 'Context'. +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 + +-- | 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. + | Started (Forest s) -- ^ Provides the substeps that will be executed next. + | 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 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 + +-- | 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_ + +-- | Runs a plan that doesn't need input. It returns a 'Stream' of 'Tick' +-- updates that are emitted every time the execution advances through the +-- 'Steps'. +-- +-- For each 'Tick' update, a monadic measurement of type @t@ is taken. Usually +-- the measurement consists in getting the current time. +-- +-- When the execution finishes, a 'Timeline' with the measurements for each +-- 'Tick' is returned, along with the result value. +-- +-- Even if the plan didn't have any steps, the 'Timeline' will contain a +-- measurement taken when the computation finished. +runPlan :: Monad m + => 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 () + +-- | Like 'runPlan', but for 'Arrow'-like 'Plan's that take inputs. +runPlanK :: 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 = + 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) + +data RunState s t = RunState !(Seq (t,s,Either (Forest s) (Timeline s t))) + !(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 + -- | 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 [] + 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 [] + 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))) + 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 new file mode 100644 --- /dev/null +++ b/plan-applicative.cabal @@ -0,0 +1,70 @@ +name: plan-applicative +version: 1.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 + annotations are available before running the computations. + + It also allows tagging different parts of a computation as + separate steps, so that progress notifications can be + emitted during execution. Optional steps are allowed. +license: BSD3 +license-file: LICENSE +author: Daniel Diaz +maintainer: diaz.carrete@facebook.com +-- copyright: +category: Control +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +Extra-Source-Files: + README.md + +source-repository head + type: git + location: https://github.com/danidiaz/plan-applicative.git + +library + exposed-modules: Control.Plan + exposed-modules: Control.Plan.Core + build-depends: + base >= 4.6 && < 5, + containers >= 0.5.7 && < 0.6, + profunctors >= 5.2 && < 5.6, + bifunctors >= 5.4 && < 5.5, + streaming >= 0.1.4 && < 0.2, + transformers >= 0.5 && < 0.6, + comonad >= 5 && < 6 + hs-source-dirs: lib + default-language: Haskell2010 + ghc-options: -Wall + +test-suite doctests + type: exitcode-stdio-1.0 + ghc-options: -Wall -threaded + hs-source-dirs: tests + main-is: doctests.hs + build-depends: + base >= 4.6 && < 5, + doctest >= 0.11, + plan-applicative + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests, lib + main-is: tests.hs + other-modules: Control.Plan + Control.Plan.Core + build-depends: + base >=4.6 && <5, + containers >= 0.5.7 && < 0.6, + profunctors >= 5.2 && < 5.6, + bifunctors >= 5.4 && < 5.5, + streaming >= 0.1.4 && < 0.2, + transformers >= 0.5 && < 0.6, + comonad >= 5 && < 6, + tasty >=0.10.1.1, + tasty-hunit >=0.9.2 + default-language: Haskell2010 diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,6 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest [ "lib/Control/Plan.hs" ] diff --git a/tests/tests.hs b/tests/tests.hs new file mode 100644 --- /dev/null +++ b/tests/tests.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NumDecimals #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE Arrows #-} + +module Main where + +import Prelude hiding ((.),id) +import Data.Monoid +import Data.Foldable +import Data.Tree + +import Control.Category +import Control.Arrow +import Control.Monad +import Control.Monad.Trans.Writer +import Control.Monad.Trans.State +import Control.Comonad + +import Control.Plan +import Control.Plan.Core + +import Test.Tasty +import Test.Tasty.HUnit + +import Streaming +import qualified Streaming.Prelude + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [testCase "simple" testSimple + ,testCase "multi" testMulti + ,testCase "pathsMulti" testPathsMulti + ,testCase "runMulti" testRunMulti + ,testCase "skippy" testSkippy + ,testCase "runSkippy" testRunSkippy + ] + +testSimple :: IO () +testSimple = do + let plan' = pure 7 :: Plan Char () IO () Int + assertEqual "" [] + (bifoldMap pure (const []) (getSteps plan')) + +multi :: Plan String [Int] (Writer [String]) () () +multi = do + _ <- step "a" (do _ <- step "a1" (foretell [1] *> plan (tell ["a1"]) <* foretell [2]) + _ <- step "a2" (foretell [3] *> plan (tell ["a2"]) <* foretell [4]) + return ()) + _ <- step "b" (do _ <- step "b1" (foretell [5] *> plan (tell ["b1"]) <* foretell [6]) + _ <- step "b2" (foretell [7] *> plan (tell ["b2"]) <* foretell [8]) + return ()) + return () + +testMulti :: IO () +testMulti = assertEqual "" [Left "a" + ,Left "a1" + ,Right 1 + ,Right 2 + ,Left "a2" + ,Right 3 + ,Right 4 + ,Left "b" + ,Left "b1" + ,Right 5 + ,Right 6 + ,Left "b2" + ,Right 7 + ,Right 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) + +progressToTick' :: Progress s t -> Tick' +progressToTick' (Skipped {}) = Skipped' +progressToTick' (Started {}) = Started' +progressToTick' (Finished {}) = Finished' + +testRunMulti :: IO () +testRunMulti = do + let multi' = hoistPlan lift multi + addToCounter = modify' succ >> get + ((ticks :> (timeline,_),_),results) = runWriter + . flip runStateT 'a' + . Streaming.Prelude.toList + . runPlan addToCounter $ multi' + assertEqual "timeline" [Node (Right ('b','g'),"a") [Node (Right ('c','d'),"a1") [] + ,Node (Right ('e','f'),"a2") []] + ,Node (Right ('h','m'),"b") [Node (Right ('i','j'),"b1") [] + ,Node (Right ('k','l'),"b2") []]] + (toForest (instants timeline)) + assertEqual "timelineEnd" 'n' + (extract timeline) + assertEqual "ticksLen" 12 + (length ticks) + let simpleTicks = map (\(Tick ctxs progress) -> (toList . fmap (extract.completed) $ ctxs + ,toList . fmap current $ ctxs + ,progressToTick' progress)) + ticks + assertEqual "tickTypes" [("b" ,["a"],Started') + ,("cb",["a1","a"],Started') + ,("cb",["a1","a"],Finished') + ,("eb",["a2","a"],Started') + ,("eb",["a2","a"],Finished') + ,("b" ,["a"],Finished') + ,("h" ,["b"],Started') + ,("ih",["b1","b"],Started') + ,("ih",["b1","b"],Finished') + ,("kh",["b2","b"],Started') + ,("kh",["b2","b"],Finished') + ,("h" ,["b"],Finished') + ] + simpleTicks + let forestTicks = take 3 . map tickToForest $ ticks + assertEqual "tickForests" [[Node (Just (Right ('b',Nothing)),"a") [Node (Nothing,"a1") [] + ,Node (Nothing,"a2") []] + ,Node (Nothing,"b") [Node (Nothing,"b1") [] + ,Node (Nothing,"b2") []]] + ,[Node (Just (Right ('b',Nothing)),"a") [Node (Just (Right ('c',Nothing)),"a1") [] + ,Node (Nothing,"a2") []] + ,Node (Nothing,"b") [Node (Nothing,"b1") [] + ,Node (Nothing,"b2") []]] + + ,[Node (Just (Right ('b',Nothing)),"a") [Node (Just (Right ('c',Just 'd')),"a1") [] + ,Node (Nothing,"a2") []] + ,Node (Nothing,"b") [Node (Nothing,"b1") [] + ,Node (Nothing,"b2") []]]] + forestTicks + +skippy :: Plan String [Int] (Writer [String]) () () +skippy = step "a" (plan (return (Just ()))) + >>> + skippable "sa" (plan (tell ["sa"])) + >>> + step "b" (plan (return Nothing)) + >>> + skippable "sb" (plan (tell ["sb"])) + +testSkippy :: IO () +testSkippy = assertEqual "" [Left (Mandatory,"a") + ,Left (Skippable,"sa") + ,Left (Mandatory,"b") + ,Left (Skippable,"sb") + ] + (bifoldMap (pure . Left) (map Right) . mandatoriness . getSteps $ skippy) + +testRunSkippy :: IO () +testRunSkippy = do + let skippy' = hoistPlan lift skippy + addToCounter = modify' succ >> get + ((ticks :> (timeline,_),_),results) = runWriter + . flip runStateT 'a' + . Streaming.Prelude.toList + . runPlan addToCounter $ skippy' + assertEqual "timeline" [Node (Right ('b','c'),"a") [] + ,Node (Right ('d','e'),"sa") [] + ,Node (Right ('f','g'),"b") [] + ,Node (Left 'h',"sb") [] + ] + (toForest (instants timeline)) + assertEqual "timelineEnd" 'i' + (extract timeline) + assertEqual "ticksLen" 7 + (length ticks) + let simpleTicks = map (\(Tick ctxs progress) -> (toList . fmap (extract.completed) $ ctxs + ,toList . fmap current $ ctxs + ,progressToTick' progress)) + ticks + assertEqual "tickTypes" [("b",["a"],Started') + ,("b",["a"],Finished') + ,("d",["sa"],Started') + ,("d",["sa"],Finished') + ,("f",["b"],Started') + ,("f",["b"],Finished') + ,("h",["sb"],Skipped')] + simpleTicks + let forestTicks = take 1 . map tickToForest $ ticks + assertEqual "tickForests" [[Node (Just (Right ('b',Nothing)),"a") [] + ,Node (Nothing,"sa") [] + ,Node (Nothing,"b") [] + ,Node (Nothing,"sb") []]] + forestTicks