Distribution/Utils/LogProgress.hs

    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {-# LANGUAGE Rank2Types #-}
    {-# LANGUAGE FlexibleContexts #-}
    module Distribution.Utils.LogProgress (
        LogProgress,
        runLogProgress,
        warnProgress,
        infoProgress,
        dieProgress,
        addProgressCtx,
    ) where

    import Prelude ()
    import Distribution.Compat.Prelude

    import Distribution.Utils.Progress
    import Distribution.Verbosity
    import Distribution.Simple.Utils
    import Text.PrettyPrint

    type CtxMsg = Doc
    type LogMsg = Doc
    type ErrMsg = Doc

    data LogEnv = LogEnv {
            le_verbosity :: Verbosity,
            le_context   :: [CtxMsg]
        }

    -- | The 'Progress' monad with specialized logging and
    -- error messages.
    newtype LogProgress a = LogProgress { unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a }

    instance Functor LogProgress where
        fmap f (LogProgress m) = LogProgress (fmap (fmap f) m)

    instance Applicative LogProgress where
        pure x = LogProgress (pure (pure x))
        LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r

    instance Monad LogProgress where
        return = pure
        LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r

    -- | Run 'LogProgress', outputting traces according to 'Verbosity',
    -- 'die' if there is an error.
    runLogProgress :: Verbosity -> LogProgress a -> NoCallStackIO a
    runLogProgress verbosity (LogProgress m) =
        foldProgress step_fn fail_fn return (m env)
      where
        env = LogEnv {
            le_verbosity = verbosity,
            le_context   = []
          }
        step_fn :: LogMsg -> NoCallStackIO a -> NoCallStackIO a
        step_fn doc go = do
            putStrLn (render doc)
            go
        fail_fn :: Doc -> NoCallStackIO a
        fail_fn doc = do
            dieNoWrap verbosity (render doc)

    -- | Output a warning trace message in 'LogProgress'.
    warnProgress :: Doc -> LogProgress ()
    warnProgress s = LogProgress $ \env ->
        when (le_verbosity env >= normal) $
            stepProgress $
                hang (text "Warning:") 4 (formatMsg (le_context env) s)

    -- | Output an informational trace message in 'LogProgress'.
    infoProgress :: Doc -> LogProgress ()
    infoProgress s = LogProgress $ \env ->
        when (le_verbosity env >= verbose) $
            stepProgress s

    -- | Fail the computation with an error message.
    dieProgress :: Doc -> LogProgress a
    dieProgress s = LogProgress $ \env ->
        failProgress $
            hang (text "Error:") 4 (formatMsg (le_context env) s)

    -- | Format a message with context. (Something simple for now.)
    formatMsg :: [CtxMsg] -> Doc -> Doc
    formatMsg ctx doc = doc $$ vcat ctx

    -- | Add a message to the error/warning context.
    addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a
    addProgressCtx s (LogProgress m) = LogProgress $ \env ->
        m env { le_context = s : le_context env }