{-# 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 -> [Doc]
le_context   :: [CtxMsg]
    }

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

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

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

instance Monad LogProgress where
    return :: forall a. a -> LogProgress a
return = a -> LogProgress a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    LogProgress LogEnv -> Progress Doc Doc a
m >>= :: forall a b. LogProgress a -> (a -> LogProgress b) -> LogProgress b
>>= a -> LogProgress b
f = (LogEnv -> Progress Doc Doc b) -> LogProgress b
forall a. (LogEnv -> Progress Doc Doc a) -> LogProgress a
LogProgress ((LogEnv -> Progress Doc Doc b) -> LogProgress b)
-> (LogEnv -> Progress Doc Doc b) -> LogProgress b
forall a b. (a -> b) -> a -> b
$ \LogEnv
r -> LogEnv -> Progress Doc Doc a
m LogEnv
r Progress Doc Doc a
-> (a -> Progress Doc Doc b) -> Progress Doc Doc b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> LogProgress b -> LogEnv -> Progress Doc Doc b
forall a. LogProgress a -> LogEnv -> Progress Doc Doc 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 -> IO a
runLogProgress :: forall a. Verbosity -> LogProgress a -> IO a
runLogProgress Verbosity
verbosity (LogProgress LogEnv -> Progress Doc Doc a
m) =
    (Doc -> IO a -> IO a)
-> (Doc -> IO a) -> (a -> IO a) -> Progress Doc Doc a -> IO a
forall step a fail done.
(step -> a -> a)
-> (fail -> a) -> (done -> a) -> Progress step fail done -> a
foldProgress Doc -> IO a -> IO a
forall a. Doc -> IO a -> IO a
step_fn Doc -> IO a
forall a. Doc -> IO a
fail_fn a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LogEnv -> Progress Doc Doc a
m LogEnv
env)
  where
    env :: LogEnv
env = LogEnv :: Verbosity -> [Doc] -> LogEnv
LogEnv {
        le_verbosity :: Verbosity
le_verbosity = Verbosity
verbosity,
        le_context :: [Doc]
le_context   = []
      }
    step_fn :: LogMsg -> IO a -> IO a
    step_fn :: forall a. Doc -> IO a -> IO a
step_fn Doc
doc IO a
go = do
        String -> IO ()
putStrLn (Doc -> String
render Doc
doc)
        IO a
go
    fail_fn :: Doc -> IO a
    fail_fn :: forall a. Doc -> IO a
fail_fn Doc
doc = do
        Verbosity -> String -> IO a
forall a. Verbosity -> String -> IO a
dieNoWrap Verbosity
verbosity (Doc -> String
render Doc
doc)

-- | Output a warning trace message in 'LogProgress'.
warnProgress :: Doc -> LogProgress ()
warnProgress :: Doc -> LogProgress ()
warnProgress Doc
s = (LogEnv -> Progress Doc Doc ()) -> LogProgress ()
forall a. (LogEnv -> Progress Doc Doc a) -> LogProgress a
LogProgress ((LogEnv -> Progress Doc Doc ()) -> LogProgress ())
-> (LogEnv -> Progress Doc Doc ()) -> LogProgress ()
forall a b. (a -> b) -> a -> b
$ \LogEnv
env ->
    Bool -> Progress Doc Doc () -> Progress Doc Doc ()
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 Doc Doc () -> Progress Doc Doc ())
-> Progress Doc Doc () -> Progress Doc Doc ()
forall a b. (a -> b) -> a -> b
$
        Doc -> Progress Doc Doc ()
forall step fail. step -> Progress step fail ()
stepProgress (Doc -> Progress Doc Doc ()) -> Doc -> Progress Doc Doc ()
forall a b. (a -> b) -> a -> b
$
            Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"Warning:") Int
4 ([Doc] -> Doc -> Doc
formatMsg (LogEnv -> [Doc]
le_context LogEnv
env) Doc
s)

-- | Output an informational trace message in 'LogProgress'.
infoProgress :: Doc -> LogProgress ()
infoProgress :: Doc -> LogProgress ()
infoProgress Doc
s = (LogEnv -> Progress Doc Doc ()) -> LogProgress ()
forall a. (LogEnv -> Progress Doc Doc a) -> LogProgress a
LogProgress ((LogEnv -> Progress Doc Doc ()) -> LogProgress ())
-> (LogEnv -> Progress Doc Doc ()) -> LogProgress ()
forall a b. (a -> b) -> a -> b
$ \LogEnv
env ->
    Bool -> Progress Doc Doc () -> Progress Doc Doc ()
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 Doc Doc () -> Progress Doc Doc ())
-> Progress Doc Doc () -> Progress Doc Doc ()
forall a b. (a -> b) -> a -> b
$
        Doc -> Progress Doc Doc ()
forall step fail. step -> Progress step fail ()
stepProgress Doc
s

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

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

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