    {-# 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}