Progress.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}

-- Note: This module was copied from cabal-install.

-- | A progress monad, which we use to report failure and logging from
-- otherwise pure code.
module Distribution.Utils.Progress
  ( Progress
  , stepProgress
  , failProgress
  , foldProgress
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import qualified Data.Monoid as Mon

-- | A type to represent the unfolding of an expensive long running
-- calculation that may fail (or maybe not expensive, but complicated!)
-- We may get intermediate steps before the final
-- result which may be used to indicate progress and\/or logging messages.
--
-- TODO: Apply Codensity to avoid left-associativity problem.
-- See http://comonad.com/reader/2011/free-monads-for-less/ and
-- http://blog.ezyang.com/2012/01/problem-set-the-codensity-transformation/
data Progress step fail done
  = Step step (Progress step fail done)
  | Fail fail
  | Done done
  deriving (Functor)

-- | Emit a step and then continue.
stepProgress :: step -> Progress step fail ()
stepProgress step = Step step (Done ())

-- | Fail the computation.
failProgress :: fail -> Progress step fail done
failProgress err = Fail err

-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two
-- base cases, one for a final result and one for failure.
--
-- Eg to convert into a simple 'Either' result use:
--
-- > foldProgress (flip const) Left Right
foldProgress
  :: (step -> a -> a)
  -> (fail -> a)
  -> (done -> a)
  -> Progress step fail done
  -> a
foldProgress step err done = fold
  where
    fold (Step s p) = step s (fold p)
    fold (Fail f) = err f
    fold (Done r) = done r

instance Monad (Progress step fail) where
  return = pure
  p >>= f = foldProgress Step Fail f p

instance Applicative (Progress step fail) where
  pure a = Done a
  p <*> x = foldProgress Step Fail (flip fmap x) p

instance Monoid fail => Alternative (Progress step fail) where
  empty = Fail Mon.mempty
  p <|> q = foldProgress Step (const q) Done p