{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Rank2Types #-}

module Distribution.Utils.LogProgress
  ( LogProgress
  , runLogProgress
  , warnProgress
  , infoProgress
  , dieProgress
  , addProgressCtx
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.Simple.Utils
import Distribution.Utils.Progress
import Distribution.Verbosity
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 a b. (a -> b) -> (LogEnv -> a) -> LogEnv -> 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 a b.
(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 a. a -> LogEnv -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Progress LogMsg LogMsg a
forall a. 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 a. 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 a b.
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 a. 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 = s : le_context env}