{-# LANGUAGE FlexibleContexts #-}
{-# 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 System.IO (hFlush, hPutStr, hPutStrLn)
import Text.PrettyPrint

type CtxMsg = Doc
data LogMsg = WarnMsg Doc | InfoMsg Doc
type ErrMsg = Doc

data LogEnv = LogEnv
  { LogEnv -> Verbosity
le_verbosity :: Verbosity
  , LogEnv -> [ErrMsg]
le_context :: [CtxMsg]
  }

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

instance Applicative LogProgress where
  pure :: forall a. a -> LogProgress a
pure a
x = (LogEnv -> Progress LogMsg ErrMsg a) -> LogProgress a
forall a. (LogEnv -> Progress LogMsg ErrMsg a) -> LogProgress a
LogProgress (Progress LogMsg ErrMsg a -> LogEnv -> Progress LogMsg ErrMsg a
forall a. a -> LogEnv -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Progress LogMsg ErrMsg a
forall a. a -> Progress LogMsg ErrMsg a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x))
  LogProgress LogEnv -> Progress LogMsg ErrMsg (a -> b)
f <*> :: forall a b. LogProgress (a -> b) -> LogProgress a -> LogProgress b
<*> LogProgress LogEnv -> Progress LogMsg ErrMsg a
x = (LogEnv -> Progress LogMsg ErrMsg b) -> LogProgress b
forall a. (LogEnv -> Progress LogMsg ErrMsg a) -> LogProgress a
LogProgress ((LogEnv -> Progress LogMsg ErrMsg b) -> LogProgress b)
-> (LogEnv -> Progress LogMsg ErrMsg b) -> LogProgress b
forall a b. (a -> b) -> a -> b
$ \LogEnv
r -> LogEnv -> Progress LogMsg ErrMsg (a -> b)
f LogEnv
r Progress LogMsg ErrMsg (a -> b)
-> Progress LogMsg ErrMsg a -> Progress LogMsg ErrMsg b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` LogEnv -> Progress LogMsg ErrMsg 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 ErrMsg a
m >>= :: forall a b. LogProgress a -> (a -> LogProgress b) -> LogProgress b
>>= a -> LogProgress b
f = (LogEnv -> Progress LogMsg ErrMsg b) -> LogProgress b
forall a. (LogEnv -> Progress LogMsg ErrMsg a) -> LogProgress a
LogProgress ((LogEnv -> Progress LogMsg ErrMsg b) -> LogProgress b)
-> (LogEnv -> Progress LogMsg ErrMsg b) -> LogProgress b
forall a b. (a -> b) -> a -> b
$ \LogEnv
r -> LogEnv -> Progress LogMsg ErrMsg a
m LogEnv
r Progress LogMsg ErrMsg a
-> (a -> Progress LogMsg ErrMsg b) -> Progress LogMsg ErrMsg b
forall a b.
Progress LogMsg ErrMsg a
-> (a -> Progress LogMsg ErrMsg b) -> Progress LogMsg ErrMsg b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> LogProgress b -> LogEnv -> Progress LogMsg ErrMsg b
forall a. LogProgress a -> LogEnv -> Progress LogMsg ErrMsg 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 ErrMsg a
m) =
  (LogMsg -> IO a -> IO a)
-> (ErrMsg -> IO a)
-> (a -> IO a)
-> Progress LogMsg ErrMsg 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 ErrMsg -> IO a
forall a. ErrMsg -> IO a
fail_fn a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LogEnv -> Progress LogMsg ErrMsg a
m LogEnv
env)
  where
    env :: LogEnv
env =
      LogEnv
        { le_verbosity :: Verbosity
le_verbosity = Verbosity
verbosity
        , le_context :: [ErrMsg]
le_context = []
        }
    step_fn :: LogMsg -> IO a -> IO a
    step_fn :: forall a. LogMsg -> IO a -> IO a
step_fn (WarnMsg ErrMsg
doc) IO a
go = do
      -- Log the warning to the stderr handle, but flush the stdout handle first,
      -- to prevent interleaving (see Distribution.Simple.Utils.warnMessage).
      let h :: Handle
h = Verbosity -> Handle
verbosityErrorHandle Verbosity
verbosity
          flags :: VerbosityFlags
flags = Verbosity -> VerbosityFlags
verbosityFlags Verbosity
verbosity
      Handle -> IO ()
hFlush (Verbosity -> Handle
verbosityChosenOutputHandle Verbosity
verbosity)
      Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ VerbosityFlags -> String -> String
withOutputMarker VerbosityFlags
flags (ErrMsg -> String
render ErrMsg
doc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")
      IO a
go
    step_fn (InfoMsg ErrMsg
doc) IO a
go = do
      -- Don't mark 'infoProgress' messages (mostly Backpack internals)
      Handle -> String -> IO ()
hPutStrLn (Verbosity -> Handle
verbosityChosenOutputHandle Verbosity
verbosity) (ErrMsg -> String
render ErrMsg
doc)
      IO a
go
    fail_fn :: ErrMsg -> IO a
    fail_fn :: forall a. ErrMsg -> IO a
fail_fn ErrMsg
doc = do
      Verbosity -> String -> IO a
forall a. Verbosity -> String -> IO a
dieNoWrap Verbosity
verbosity (ErrMsg -> String
render ErrMsg
doc)

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

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

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

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

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