Cabal/src/Distribution/Utils/LogProgress.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE Rank2Types #-}
   4
   5 module Distribution.Utils.LogProgress
   6   ( LogProgress
   7   , runLogProgress
   8   , warnProgress
   9   , infoProgress
  10   , dieProgress
  11   , addProgressCtx
  12   ) where
  13
  14 import Distribution.Compat.Prelude
  15 import Prelude ()
  16
  17 import Distribution.Simple.Utils
  18 import Distribution.Utils.Progress
  19 import Distribution.Verbosity
  20 import Text.PrettyPrint
  21
  22 type CtxMsg = Doc
  23 type LogMsg = Doc
  24 type ErrMsg = Doc
  25
  26 data LogEnv = LogEnv
  27   { le_verbosity :: Verbosity
  28   , le_context :: [CtxMsg]
  29   }
  30
  31 -- | The 'Progress' monad with specialized logging and
  32 -- error messages.
  33 newtype LogProgress a = LogProgress {unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a}
  34
  35 instance Functor LogProgress where
  36   fmap f (LogProgress m) = LogProgress (fmap (fmap f) m)
  37
  38 instance Applicative LogProgress where
  39   pure x = LogProgress (pure (pure x))
  40   LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r
  41
  42 instance Monad LogProgress where
  43   return = pure
  44   LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r
  45
  46 -- | Run 'LogProgress', outputting traces according to 'Verbosity',
  47 -- 'die' if there is an error.
  48 runLogProgress :: Verbosity -> LogProgress a -> IO a
  49 runLogProgress verbosity (LogProgress m) =
  50   foldProgress step_fn fail_fn return (m env)
  51   where
  52     env =
  53       LogEnv
  54         { le_verbosity = verbosity
  55         , le_context = []
  56         }
  57     step_fn :: LogMsg -> IO a -> IO a
  58     step_fn doc go = do
  59       putStrLn (render doc)
  60       go
  61     fail_fn :: Doc -> IO a
  62     fail_fn doc = do
  63       dieNoWrap verbosity (render doc)
  64
  65 -- | Output a warning trace message in 'LogProgress'.
  66 warnProgress :: Doc -> LogProgress ()
  67 warnProgress s = LogProgress $ \env ->
  68   when (le_verbosity env >= normal) $
  69     stepProgress $
  70       hang (text "Warning:") 4 (formatMsg (le_context env) s)
  71
  72 -- | Output an informational trace message in 'LogProgress'.
  73 infoProgress :: Doc -> LogProgress ()
  74 infoProgress s = LogProgress $ \env ->
  75   when (le_verbosity env >= verbose) $
  76     stepProgress s
  77
  78 -- | Fail the computation with an error message.
  79 dieProgress :: Doc -> LogProgress a
  80 dieProgress s = LogProgress $ \env ->
  81   failProgress $
  82     hang (text "Error:") 4 (formatMsg (le_context env) s)
  83
  84 -- | Format a message with context. (Something simple for now.)
  85 formatMsg :: [CtxMsg] -> Doc -> Doc
  86 formatMsg ctx doc = doc $$ vcat ctx
  87
  88 -- | Add a message to the error/warning context.
  89 addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a
  90 addProgressCtx s (LogProgress m) = LogProgress $ \env ->
  91   m env{le_context = s : le_context env}