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

-- | The 'Progress' monad with specialized logging and
-- error messages.
newtype LogProgress a = LogProgress { forall a. LogProgress a -> LogEnv -> Progress LogMsg LogMsg 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 LogMsg LogMsg a
m) = (LogEnv -> Progress LogMsg LogMsg b) -> LogProgress b
forall a. (LogEnv -> Progress LogMsg LogMsg a) -> LogProgress a
LogProgress ((Progress LogMsg LogMsg a -> Progress LogMsg LogMsg b)
-> (LogEnv -> Progress LogMsg LogMsg a)
-> LogEnv
-> Progress LogMsg LogMsg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Progress LogMsg LogMsg a -> Progress LogMsg LogMsg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) LogEnv -> Progress LogMsg LogMsg a
m)

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

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

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

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

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

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