Cabal/src/Distribution/Utils/Progress.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE DeriveFunctor #-}
   3
   4 -- Note: This module was copied from cabal-install.
   5
   6 -- | A progress monad, which we use to report failure and logging from
   7 -- otherwise pure code.
   8 module Distribution.Utils.Progress
   9   ( Progress
  10   , stepProgress
  11   , failProgress
  12   , foldProgress
  13   ) where
  14
  15 import Distribution.Compat.Prelude
  16 import Prelude ()
  17
  18 import qualified Data.Monoid as Mon
  19
  20 -- | A type to represent the unfolding of an expensive long running
  21 -- calculation that may fail (or maybe not expensive, but complicated!)
  22 -- We may get intermediate steps before the final
  23 -- result which may be used to indicate progress and\/or logging messages.
  24 --
  25 -- TODO: Apply Codensity to avoid left-associativity problem.
  26 -- See http://comonad.com/reader/2011/free-monads-for-less/ and
  27 -- http://blog.ezyang.com/2012/01/problem-set-the-codensity-transformation/
  28 data Progress step fail done
  29   = Step step (Progress step fail done)
  30   | Fail fail
  31   | Done done
  32   deriving (Functor)
  33
  34 -- | Emit a step and then continue.
  35 stepProgress :: step -> Progress step fail ()
  36 stepProgress step = Step step (Done ())
  37
  38 -- | Fail the computation.
  39 failProgress :: fail -> Progress step fail done
  40 failProgress err = Fail err
  41
  42 -- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two
  43 -- base cases, one for a final result and one for failure.
  44 --
  45 -- Eg to convert into a simple 'Either' result use:
  46 --
  47 -- > foldProgress (flip const) Left Right
  48 foldProgress
  49   :: (step -> a -> a)
  50   -> (fail -> a)
  51   -> (done -> a)
  52   -> Progress step fail done
  53   -> a
  54 foldProgress step err done = fold
  55   where
  56     fold (Step s p) = step s (fold p)
  57     fold (Fail f) = err f
  58     fold (Done r) = done r
  59
  60 instance Monad (Progress step fail) where
  61   return = pure
  62   p >>= f = foldProgress Step Fail f p
  63
  64 instance Applicative (Progress step fail) where
  65   pure a = Done a
  66   p <*> x = foldProgress Step Fail (flip fmap x) p
  67
  68 instance Monoid fail => Alternative (Progress step fail) where
  69   empty = Fail Mon.mempty
  70   p <|> q = foldProgress Step (const q) Done p