{-# 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 {
        LogEnv -> Verbosity
le_verbosity :: Verbosity,
        LogEnv -> [CtxMsg]
le_context   :: [CtxMsg]
    }

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

instance Functor LogProgress where
    fmap :: (a -> b) -> LogProgress a -> LogProgress b
fmap a -> b
f (LogProgress LogEnv -> Progress CtxMsg CtxMsg a
m) = (LogEnv -> Progress CtxMsg CtxMsg b) -> LogProgress b
forall a. (LogEnv -> Progress CtxMsg CtxMsg a) -> LogProgress a
LogProgress ((Progress CtxMsg CtxMsg a -> Progress CtxMsg CtxMsg b)
-> (LogEnv -> Progress CtxMsg CtxMsg a)
-> LogEnv
-> Progress CtxMsg CtxMsg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Progress CtxMsg CtxMsg a -> Progress CtxMsg CtxMsg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) LogEnv -> Progress CtxMsg CtxMsg a
m)

instance Applicative LogProgress where
    pure :: a -> LogProgress a
pure a
x = (LogEnv -> Progress CtxMsg CtxMsg a) -> LogProgress a
forall a. (LogEnv -> Progress CtxMsg CtxMsg a) -> LogProgress a
LogProgress (Progress CtxMsg CtxMsg a -> LogEnv -> Progress CtxMsg CtxMsg a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Progress CtxMsg CtxMsg a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x))
    LogProgress LogEnv -> Progress CtxMsg CtxMsg (a -> b)
f <*> :: LogProgress (a -> b) -> LogProgress a -> LogProgress b
<*> LogProgress LogEnv -> Progress CtxMsg CtxMsg a
x = (LogEnv -> Progress CtxMsg CtxMsg b) -> LogProgress b
forall a. (LogEnv -> Progress CtxMsg CtxMsg a) -> LogProgress a
LogProgress ((LogEnv -> Progress CtxMsg CtxMsg b) -> LogProgress b)
-> (LogEnv -> Progress CtxMsg CtxMsg b) -> LogProgress b
forall a b. (a -> b) -> a -> b
$ \LogEnv
r -> LogEnv -> Progress CtxMsg CtxMsg (a -> b)
f LogEnv
r Progress CtxMsg CtxMsg (a -> b)
-> Progress CtxMsg CtxMsg a -> Progress CtxMsg CtxMsg b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` LogEnv -> Progress CtxMsg CtxMsg a
x LogEnv
r

instance Monad LogProgress where
    return :: a -> LogProgress a
return = a -> LogProgress a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    LogProgress LogEnv -> Progress CtxMsg CtxMsg a
m >>= :: LogProgress a -> (a -> LogProgress b) -> LogProgress b
>>= a -> LogProgress b
f = (LogEnv -> Progress CtxMsg CtxMsg b) -> LogProgress b
forall a. (LogEnv -> Progress CtxMsg CtxMsg a) -> LogProgress a
LogProgress ((LogEnv -> Progress CtxMsg CtxMsg b) -> LogProgress b)
-> (LogEnv -> Progress CtxMsg CtxMsg b) -> LogProgress b
forall a b. (a -> b) -> a -> b
$ \LogEnv
r -> LogEnv -> Progress CtxMsg CtxMsg a
m LogEnv
r Progress CtxMsg CtxMsg a
-> (a -> Progress CtxMsg CtxMsg b) -> Progress CtxMsg CtxMsg b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> LogProgress b -> LogEnv -> Progress CtxMsg CtxMsg b
forall a. LogProgress a -> LogEnv -> Progress CtxMsg CtxMsg a
unLogProgress (a -> LogProgress b
f a
x) LogEnv
r

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

-- | Output a warning trace message in 'LogProgress'.
warnProgress :: Doc -> LogProgress ()
warnProgress :: CtxMsg -> LogProgress ()
warnProgress CtxMsg
s = (LogEnv -> Progress CtxMsg CtxMsg ()) -> LogProgress ()
forall a. (LogEnv -> Progress CtxMsg CtxMsg a) -> LogProgress a
LogProgress ((LogEnv -> Progress CtxMsg CtxMsg ()) -> LogProgress ())
-> (LogEnv -> Progress CtxMsg CtxMsg ()) -> LogProgress ()
forall a b. (a -> b) -> a -> b
$ \LogEnv
env ->
    Bool -> Progress CtxMsg CtxMsg () -> Progress CtxMsg CtxMsg ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogEnv -> Verbosity
le_verbosity LogEnv
env Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
normal) (Progress CtxMsg CtxMsg () -> Progress CtxMsg CtxMsg ())
-> Progress CtxMsg CtxMsg () -> Progress CtxMsg CtxMsg ()
forall a b. (a -> b) -> a -> b
$
        CtxMsg -> Progress CtxMsg CtxMsg ()
forall step fail. step -> Progress step fail ()
stepProgress (CtxMsg -> Progress CtxMsg CtxMsg ())
-> CtxMsg -> Progress CtxMsg CtxMsg ()
forall a b. (a -> b) -> a -> b
$
            CtxMsg -> Int -> CtxMsg -> CtxMsg
hang (String -> CtxMsg
text String
"Warning:") Int
4 ([CtxMsg] -> CtxMsg -> CtxMsg
formatMsg (LogEnv -> [CtxMsg]
le_context LogEnv
env) CtxMsg
s)

-- | Output an informational trace message in 'LogProgress'.
infoProgress :: Doc -> LogProgress ()
infoProgress :: CtxMsg -> LogProgress ()
infoProgress CtxMsg
s = (LogEnv -> Progress CtxMsg CtxMsg ()) -> LogProgress ()
forall a. (LogEnv -> Progress CtxMsg CtxMsg a) -> LogProgress a
LogProgress ((LogEnv -> Progress CtxMsg CtxMsg ()) -> LogProgress ())
-> (LogEnv -> Progress CtxMsg CtxMsg ()) -> LogProgress ()
forall a b. (a -> b) -> a -> b
$ \LogEnv
env ->
    Bool -> Progress CtxMsg CtxMsg () -> Progress CtxMsg CtxMsg ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogEnv -> Verbosity
le_verbosity LogEnv
env Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
verbose) (Progress CtxMsg CtxMsg () -> Progress CtxMsg CtxMsg ())
-> Progress CtxMsg CtxMsg () -> Progress CtxMsg CtxMsg ()
forall a b. (a -> b) -> a -> b
$
        CtxMsg -> Progress CtxMsg CtxMsg ()
forall step fail. step -> Progress step fail ()
stepProgress CtxMsg
s

-- | Fail the computation with an error message.
dieProgress :: Doc -> LogProgress a
dieProgress :: CtxMsg -> LogProgress a
dieProgress CtxMsg
s = (LogEnv -> Progress CtxMsg CtxMsg a) -> LogProgress a
forall a. (LogEnv -> Progress CtxMsg CtxMsg a) -> LogProgress a
LogProgress ((LogEnv -> Progress CtxMsg CtxMsg a) -> LogProgress a)
-> (LogEnv -> Progress CtxMsg CtxMsg a) -> LogProgress a
forall a b. (a -> b) -> a -> b
$ \LogEnv
env ->
    CtxMsg -> Progress CtxMsg CtxMsg a
forall fail step done. fail -> Progress step fail done
failProgress (CtxMsg -> Progress CtxMsg CtxMsg a)
-> CtxMsg -> Progress CtxMsg CtxMsg a
forall a b. (a -> b) -> a -> b
$
        CtxMsg -> Int -> CtxMsg -> CtxMsg
hang (String -> CtxMsg
text String
"Error:") Int
4 ([CtxMsg] -> CtxMsg -> CtxMsg
formatMsg (LogEnv -> [CtxMsg]
le_context LogEnv
env) CtxMsg
s)

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

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