-- | Logger
--
-- The Logger is an configurable entity that is used by the compiler to output
-- messages on the console (stdout, stderr) and in dump files.
--
-- The behaviour of default Logger returned by `initLogger` can be modified with
-- hooks. The compiler itself uses hooks in multithreaded code (--make) and it
-- is also probably used by ghc-api users (IDEs, etc.).
--
-- In addition to hooks, the Logger supports LogFlags: basically a subset of the
-- command-line flags that control the logger behaviour at a higher level than
-- hooks.
--
--  1. Hooks are used to define how to generate a info/warning/error/dump messages
--  2. LogFlags are used to decide when and how to generate messages
--
module GHC.Utils.Logger
    ( Logger
    , HasLogger (..)
    , ContainsLogger (..)

    -- * Logger setup
    , initLogger
    , LogAction
    , LogJsonAction
    , DumpAction
    , TraceAction
    , DumpFormat (..)

    -- ** Hooks
    , popLogHook
    , pushLogHook
    , popJsonLogHook
    , pushJsonLogHook
    , popDumpHook
    , pushDumpHook
    , popTraceHook
    , pushTraceHook
    , makeThreadSafe

    -- ** Flags
    , LogFlags (..)
    , defaultLogFlags
    , log_dopt
    , log_set_dopt
    , setLogFlags
    , updateLogFlags
    , logFlags
    , logHasDumpFlag
    , logVerbAtLeast

    -- * Logging
    , putLogMsg
    , defaultLogAction
    , defaultLogActionWithHandles
    , defaultLogJsonAction
    , defaultLogActionHPrintDoc
    , defaultLogActionHPutStrDoc
    , logMsg
    , logJsonMsg
    , logDumpMsg

    , decorateDiagnostic

    -- * Dumping
    , defaultDumpAction
    , putDumpFile
    , putDumpFileMaybe
    , putDumpFileMaybe'
    , withDumpFileHandle
    , touchDumpFile
    , logDumpFile

    -- * Tracing
    , defaultTraceAction
    , putTraceMsg
    , loggerTraceFlushUpdate
    , loggerTraceFlush
    , logTraceMsg
    )
where

import GHC.Prelude
import GHC.Driver.Flags
import GHC.Types.Error
  ( MessageClass (..), Severity (..)
  , mkLocMessageWarningGroups,getCaretDiagnostic )
-- import GHC.Types.Error ()
import GHC.Types.SrcLoc

import qualified GHC.Utils.Ppr as Pretty
import GHC.Utils.Outputable
import GHC.Utils.Json
import GHC.Utils.Panic

import GHC.Data.EnumSet (EnumSet)
import qualified GHC.Data.EnumSet as EnumSet
import GHC.Data.FastString

import System.Directory
import System.FilePath  ( takeDirectory, (</>) )
import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
import Data.List (stripPrefix)
import Data.Time
import System.IO
import Control.Monad
import Control.Concurrent.MVar
import System.IO.Unsafe
import Debug.Trace (trace)
import GHC.Platform.Ways

---------------------------------------------------------------
-- Log flags
---------------------------------------------------------------

-- | Logger flags
data LogFlags = LogFlags
  { LogFlags -> SDocContext
log_default_user_context :: SDocContext
  , LogFlags -> SDocContext
log_default_dump_context :: SDocContext
  , LogFlags -> EnumSet DumpFlag
log_dump_flags           :: !(EnumSet DumpFlag) -- ^ Dump flags
  , LogFlags -> Bool
log_show_caret           :: !Bool               -- ^ Show caret in diagnostics
  , LogFlags -> Bool
log_diagnostics_as_json  :: !Bool               -- ^ Format diagnostics as JSON
  , LogFlags -> Bool
log_show_warn_groups     :: !Bool               -- ^ Show warning flag groups
  , LogFlags -> Bool
log_enable_timestamps    :: !Bool               -- ^ Enable timestamps
  , LogFlags -> Bool
log_dump_to_file         :: !Bool               -- ^ Enable dump to file
  , LogFlags -> Maybe FilePath
log_dump_dir             :: !(Maybe FilePath)   -- ^ Dump directory
  , LogFlags -> FilePath
log_dump_prefix          :: !FilePath           -- ^ Normal dump path ("basename.")
  , LogFlags -> Maybe FilePath
log_dump_prefix_override :: !(Maybe FilePath)   -- ^ Overriden dump path
  , LogFlags -> Bool
log_with_ways            :: !Bool               -- ^ Use different dump files names for different ways
  , LogFlags -> Bool
log_enable_debug         :: !Bool               -- ^ Enable debug output
  , LogFlags -> Int
log_verbosity            :: !Int                -- ^ Verbosity level
  , LogFlags -> Maybe Ways
log_ways                 :: !(Maybe Ways)         -- ^ Current ways (to name dump files)
  }

-- | Default LogFlags
defaultLogFlags :: LogFlags
defaultLogFlags :: LogFlags
defaultLogFlags = LogFlags
  { log_default_user_context :: SDocContext
log_default_user_context = SDocContext
defaultSDocContext
  , log_default_dump_context :: SDocContext
log_default_dump_context = SDocContext
defaultSDocContext
  , log_dump_flags :: EnumSet DumpFlag
log_dump_flags           = EnumSet DumpFlag
forall {k} (a :: k). EnumSet a
EnumSet.empty
  , log_show_caret :: Bool
log_show_caret           = Bool
True
  , log_diagnostics_as_json :: Bool
log_diagnostics_as_json  = Bool
False
  , log_show_warn_groups :: Bool
log_show_warn_groups     = Bool
True
  , log_enable_timestamps :: Bool
log_enable_timestamps    = Bool
True
  , log_dump_to_file :: Bool
log_dump_to_file         = Bool
False
  , log_dump_dir :: Maybe FilePath
log_dump_dir             = Maybe FilePath
forall a. Maybe a
Nothing
  , log_dump_prefix :: FilePath
log_dump_prefix          = FilePath
""
  , log_dump_prefix_override :: Maybe FilePath
log_dump_prefix_override = Maybe FilePath
forall a. Maybe a
Nothing
  , log_with_ways :: Bool
log_with_ways           = Bool
True
  , log_enable_debug :: Bool
log_enable_debug         = Bool
False
  , log_verbosity :: Int
log_verbosity            = Int
0
  , log_ways :: Maybe Ways
log_ways                 = Maybe Ways
forall a. Maybe a
Nothing
  }

-- | Test if a DumpFlag is enabled
log_dopt :: DumpFlag -> LogFlags -> Bool
log_dopt :: DumpFlag -> LogFlags -> Bool
log_dopt = (LogFlags -> Int)
-> (LogFlags -> EnumSet DumpFlag) -> DumpFlag -> LogFlags -> Bool
forall a.
(a -> Int) -> (a -> EnumSet DumpFlag) -> DumpFlag -> a -> Bool
getDumpFlagFrom LogFlags -> Int
log_verbosity LogFlags -> EnumSet DumpFlag
log_dump_flags

-- | Enable a DumpFlag
log_set_dopt :: DumpFlag -> LogFlags -> LogFlags
log_set_dopt :: DumpFlag -> LogFlags -> LogFlags
log_set_dopt DumpFlag
f LogFlags
logflags = LogFlags
logflags { log_dump_flags = EnumSet.insert f (log_dump_flags logflags) }

-- | Test if a DumpFlag is set
logHasDumpFlag :: Logger -> DumpFlag -> Bool
logHasDumpFlag :: Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
f = DumpFlag -> LogFlags -> Bool
log_dopt DumpFlag
f (Logger -> LogFlags
logFlags Logger
logger)

-- | Test if verbosity is >= to the given value
logVerbAtLeast :: Logger -> Int -> Bool
logVerbAtLeast :: Logger -> Int -> Bool
logVerbAtLeast Logger
logger Int
v = LogFlags -> Int
log_verbosity (Logger -> LogFlags
logFlags Logger
logger) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
v

-- | Update LogFlags
updateLogFlags :: Logger -> (LogFlags -> LogFlags) -> Logger
updateLogFlags :: Logger -> (LogFlags -> LogFlags) -> Logger
updateLogFlags Logger
logger LogFlags -> LogFlags
f = Logger -> LogFlags -> Logger
setLogFlags Logger
logger (LogFlags -> LogFlags
f (Logger -> LogFlags
logFlags Logger
logger))

-- | Set LogFlags
setLogFlags :: Logger -> LogFlags -> Logger
setLogFlags :: Logger -> LogFlags -> Logger
setLogFlags Logger
logger LogFlags
flags = Logger
logger { logFlags = flags }


---------------------------------------------------------------
-- Logger
---------------------------------------------------------------

type LogAction = LogFlags
              -> MessageClass
              -> SrcSpan
              -> SDoc
              -> IO ()

type LogJsonAction = LogFlags
                   -> MessageClass
                   -> JsonDoc
                   -> IO ()

type DumpAction = LogFlags
               -> PprStyle
               -> DumpFlag
               -> String
               -> DumpFormat
               -> SDoc
               -> IO ()

type TraceAction a = LogFlags -> String -> SDoc -> a -> a

-- | Format of a dump
--
-- Dump formats are loosely defined: dumps may contain various additional
-- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint
-- (e.g. for syntax highlighters).
data DumpFormat
   = FormatHaskell   -- ^ Haskell
   | FormatCore      -- ^ Core
   | FormatSTG       -- ^ STG
   | FormatByteCode  -- ^ ByteCode
   | FormatCMM       -- ^ Cmm
   | FormatASM       -- ^ Assembly code
   | FormatC         -- ^ C code/header
   | FormatLLVM      -- ^ LLVM bytecode
   | FormatJS        -- ^ JavaScript code
   | FormatText      -- ^ Unstructured dump
   deriving (Int -> DumpFormat -> ShowS
[DumpFormat] -> ShowS
DumpFormat -> FilePath
(Int -> DumpFormat -> ShowS)
-> (DumpFormat -> FilePath)
-> ([DumpFormat] -> ShowS)
-> Show DumpFormat
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DumpFormat -> ShowS
showsPrec :: Int -> DumpFormat -> ShowS
$cshow :: DumpFormat -> FilePath
show :: DumpFormat -> FilePath
$cshowList :: [DumpFormat] -> ShowS
showList :: [DumpFormat] -> ShowS
Show,DumpFormat -> DumpFormat -> Bool
(DumpFormat -> DumpFormat -> Bool)
-> (DumpFormat -> DumpFormat -> Bool) -> Eq DumpFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DumpFormat -> DumpFormat -> Bool
== :: DumpFormat -> DumpFormat -> Bool
$c/= :: DumpFormat -> DumpFormat -> Bool
/= :: DumpFormat -> DumpFormat -> Bool
Eq)

-- | A set of the dump files to which we have written thusfar. Each dump file
-- has a corresponding MVar to ensure that a dump file has at most one active
-- writer at a time, avoiding interleaved output.
type DumpCache = MVar (Map FilePath (MVar ()))

data Logger = Logger
    { Logger -> [LogAction -> LogAction]
log_hook   :: [LogAction -> LogAction]
        -- ^ Log hooks stack

    , Logger -> [LogJsonAction -> LogJsonAction]
json_log_hook :: [LogJsonAction -> LogJsonAction]
        -- ^ Json log hooks stack

    , Logger -> [DumpAction -> DumpAction]
dump_hook  :: [DumpAction -> DumpAction]
        -- ^ Dump hooks stack

    , Logger -> forall a. [TraceAction a -> TraceAction a]
trace_hook :: forall a. [TraceAction a -> TraceAction a]
        -- ^ Trace hooks stack

    , Logger -> DumpCache
generated_dumps :: DumpCache
        -- ^ Already dumped files (to append instead of overwriting them)

    , Logger -> IO ()
trace_flush :: IO ()
        -- ^ Flush the trace buffer

    , Logger -> LogFlags
logFlags :: !LogFlags
        -- ^ Logger flags
    }

-- | Set the trace flushing function
--
-- The currently set trace flushing function is passed to the updating function
loggerTraceFlushUpdate :: Logger -> (IO () -> IO ()) -> Logger
loggerTraceFlushUpdate :: Logger -> (IO () -> IO ()) -> Logger
loggerTraceFlushUpdate Logger
logger IO () -> IO ()
upd = Logger
logger { trace_flush = upd (trace_flush logger) }

-- | Calls the trace flushing function
loggerTraceFlush :: Logger -> IO ()
loggerTraceFlush :: Logger -> IO ()
loggerTraceFlush Logger
logger = Logger -> IO ()
trace_flush Logger
logger

-- | Default trace flushing function (flush stderr)
defaultTraceFlush :: IO ()
defaultTraceFlush :: IO ()
defaultTraceFlush = Handle -> IO ()
hFlush Handle
stderr

initLogger :: IO Logger
initLogger :: IO Logger
initLogger = do
    dumps <- Map FilePath (MVar ()) -> IO DumpCache
forall a. a -> IO (MVar a)
newMVar Map FilePath (MVar ())
forall k a. Map k a
Map.empty
    return $ Logger
        { log_hook        = []
        , json_log_hook   = []
        , dump_hook       = []
        , trace_hook      = []
        , generated_dumps = dumps
        , trace_flush     = defaultTraceFlush
        , logFlags        = defaultLogFlags
        }

-- | Log something
putLogMsg :: Logger -> LogAction
putLogMsg :: Logger -> LogAction
putLogMsg Logger
logger = ((LogAction -> LogAction) -> LogAction -> LogAction)
-> LogAction -> [LogAction -> LogAction] -> LogAction
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (LogAction -> LogAction) -> LogAction -> LogAction
forall a b. (a -> b) -> a -> b
($) LogAction
defaultLogAction (Logger -> [LogAction -> LogAction]
log_hook Logger
logger)

-- | Log a JsonDoc
putJsonLogMsg :: Logger -> LogJsonAction
putJsonLogMsg :: Logger -> LogJsonAction
putJsonLogMsg Logger
logger = ((LogJsonAction -> LogJsonAction)
 -> LogJsonAction -> LogJsonAction)
-> LogJsonAction
-> [LogJsonAction -> LogJsonAction]
-> LogJsonAction
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (LogJsonAction -> LogJsonAction) -> LogJsonAction -> LogJsonAction
forall a b. (a -> b) -> a -> b
($) LogJsonAction
defaultLogJsonAction (Logger -> [LogJsonAction -> LogJsonAction]
json_log_hook Logger
logger)

-- | Dump something
putDumpFile :: Logger -> DumpAction
putDumpFile :: Logger -> DumpAction
putDumpFile Logger
logger =
    let
        fallback :: LogAction
fallback = Logger -> LogAction
putLogMsg Logger
logger
        dumps :: DumpCache
dumps    = Logger -> DumpCache
generated_dumps Logger
logger
        deflt :: DumpAction
deflt    = DumpCache -> LogAction -> DumpAction
defaultDumpAction DumpCache
dumps LogAction
fallback
    in ((DumpAction -> DumpAction) -> DumpAction -> DumpAction)
-> DumpAction -> [DumpAction -> DumpAction] -> DumpAction
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (DumpAction -> DumpAction) -> DumpAction -> DumpAction
forall a b. (a -> b) -> a -> b
($) DumpAction
deflt (Logger -> [DumpAction -> DumpAction]
dump_hook Logger
logger)

-- | Trace something
putTraceMsg :: Logger -> TraceAction a
putTraceMsg :: forall a. Logger -> TraceAction a
putTraceMsg Logger
logger = ((TraceAction a -> TraceAction a)
 -> TraceAction a -> TraceAction a)
-> TraceAction a
-> [TraceAction a -> TraceAction a]
-> TraceAction a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TraceAction a -> TraceAction a) -> TraceAction a -> TraceAction a
forall a b. (a -> b) -> a -> b
($) TraceAction a
forall a. TraceAction a
defaultTraceAction (Logger -> forall a. [TraceAction a -> TraceAction a]
trace_hook Logger
logger)


-- | Push a log hook
pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger
pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger
pushLogHook LogAction -> LogAction
h Logger
logger = Logger
logger { log_hook = h:log_hook logger }

-- | Pop a log hook
popLogHook :: Logger -> Logger
popLogHook :: Logger -> Logger
popLogHook Logger
logger = case Logger -> [LogAction -> LogAction]
log_hook Logger
logger of
    []   -> FilePath -> Logger
forall a. HasCallStack => FilePath -> a
panic FilePath
"popLogHook: empty hook stack"
    LogAction -> LogAction
_:[LogAction -> LogAction]
hs -> Logger
logger { log_hook = hs }

-- | Push a json log hook
pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger
pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger
pushJsonLogHook LogJsonAction -> LogJsonAction
h Logger
logger = Logger
logger { json_log_hook = h:json_log_hook logger }

popJsonLogHook :: Logger -> Logger
popJsonLogHook :: Logger -> Logger
popJsonLogHook Logger
logger = case Logger -> [LogJsonAction -> LogJsonAction]
json_log_hook Logger
logger of
    []   -> FilePath -> Logger
forall a. HasCallStack => FilePath -> a
panic FilePath
"popJsonLogHook: empty hook stack"
    LogJsonAction -> LogJsonAction
_:[LogJsonAction -> LogJsonAction]
hs -> Logger
logger { json_log_hook = hs}

-- | Push a dump hook
pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger
pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger
pushDumpHook DumpAction -> DumpAction
h Logger
logger = Logger
logger { dump_hook = h:dump_hook logger }

-- | Pop a dump hook
popDumpHook :: Logger -> Logger
popDumpHook :: Logger -> Logger
popDumpHook Logger
logger = case Logger -> [DumpAction -> DumpAction]
dump_hook Logger
logger of
    []   -> FilePath -> Logger
forall a. HasCallStack => FilePath -> a
panic FilePath
"popDumpHook: empty hook stack"
    DumpAction -> DumpAction
_:[DumpAction -> DumpAction]
hs -> Logger
logger { dump_hook = hs }

-- | Push a trace hook
pushTraceHook :: (forall a. TraceAction a -> TraceAction a) -> Logger -> Logger
pushTraceHook :: (forall a. TraceAction a -> TraceAction a) -> Logger -> Logger
pushTraceHook forall a. TraceAction a -> TraceAction a
h Logger
logger = Logger
logger { trace_hook = h:trace_hook logger }

-- | Pop a trace hook
popTraceHook :: Logger -> Logger
popTraceHook :: Logger -> Logger
popTraceHook Logger
logger = case Logger -> forall a. [TraceAction a -> TraceAction a]
trace_hook Logger
logger of
    [] -> FilePath -> Logger
forall a. HasCallStack => FilePath -> a
panic FilePath
"popTraceHook: empty hook stack"
    [TraceAction a_0 -> TraceAction a_0]
_  -> Logger
logger { trace_hook = tail (trace_hook logger) }

-- | Make the logger thread-safe
makeThreadSafe :: Logger -> IO Logger
makeThreadSafe :: Logger -> IO Logger
makeThreadSafe Logger
logger = do
    lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
    let
        with_lock :: forall a. IO a -> IO a
        with_lock IO a
act = MVar () -> (() -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock (IO a -> () -> IO a
forall a b. a -> b -> a
const IO a
act)

        log t -> t -> t -> t -> IO a
action t
logflags t
msg_class t
loc t
doc =
            IO a -> IO a
forall a. IO a -> IO a
with_lock (t -> t -> t -> t -> IO a
action t
logflags t
msg_class t
loc t
doc)

        dmp t -> t -> t -> t -> t -> t -> IO a
action t
logflags t
sty t
opts t
str t
fmt t
doc =
            IO a -> IO a
forall a. IO a -> IO a
with_lock (t -> t -> t -> t -> t -> t -> IO a
action t
logflags t
sty t
opts t
str t
fmt t
doc)

        trc :: forall a. TraceAction a -> TraceAction a
        trc TraceAction a
action LogFlags
logflags FilePath
str SDoc
doc a
v =
            IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> IO a
forall a. IO a -> IO a
with_lock (a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$! TraceAction a
action LogFlags
logflags FilePath
str SDoc
doc a
v))

    return $ pushLogHook log
           $ pushDumpHook dmp
           $ pushTraceHook trc
           $ logger

-- See Note [JSON Error Messages]
defaultLogJsonAction :: LogJsonAction
defaultLogJsonAction :: LogJsonAction
defaultLogJsonAction LogFlags
logflags MessageClass
msg_class JsonDoc
jsdoc =
  case MessageClass
msg_class of
      MessageClass
MCOutput                     -> SDoc -> IO ()
printOut SDoc
msg
      MessageClass
MCDump                       -> SDoc -> IO ()
printOut (SDoc
msg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
blankLine)
      MessageClass
MCInteractive                -> SDoc -> IO ()
putStrSDoc SDoc
msg
      MessageClass
MCInfo                       -> SDoc -> IO ()
printErrs SDoc
msg
      MessageClass
MCFatal                      -> SDoc -> IO ()
printErrs SDoc
msg
      MCDiagnostic Severity
SevIgnore ResolvedDiagnosticReason
_ Maybe DiagnosticCode
_   -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- suppress the message
      MCDiagnostic Severity
_sev ResolvedDiagnosticReason
_rea Maybe DiagnosticCode
_code -> SDoc -> IO ()
printErrs SDoc
msg
  where
    printOut :: SDoc -> IO ()
printOut   = LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc  LogFlags
logflags Bool
False Handle
stdout
    printErrs :: SDoc -> IO ()
printErrs  = LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc  LogFlags
logflags Bool
False Handle
stderr
    putStrSDoc :: SDoc -> IO ()
putStrSDoc = LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc LogFlags
logflags Bool
False Handle
stdout
    msg :: SDoc
msg = JsonDoc -> SDoc
renderJSON JsonDoc
jsdoc

-- See Note [JSON Error Messages]
-- this is to be removed
jsonLogActionWithHandle :: Handle {-^ Standard out -} -> LogAction
jsonLogActionWithHandle :: Handle -> LogAction
jsonLogActionWithHandle Handle
_ LogFlags
_ (MCDiagnostic Severity
SevIgnore ResolvedDiagnosticReason
_ Maybe DiagnosticCode
_) SrcSpan
_ SDoc
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- suppress the message
jsonLogActionWithHandle Handle
out LogFlags
logflags MessageClass
msg_class SrcSpan
srcSpan SDoc
msg
  =
    LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc LogFlags
logflags Bool
True Handle
out
      (PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
PprCode (SDoc
doc SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
""))
    where
      str :: FilePath
str = SDocContext -> SDoc -> FilePath
renderWithContext (LogFlags -> SDocContext
log_default_user_context LogFlags
logflags) SDoc
msg
      doc :: SDoc
doc = JsonDoc -> SDoc
renderJSON (JsonDoc -> SDoc) -> JsonDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
              [(FilePath, JsonDoc)] -> JsonDoc
JSObject [ ( FilePath
"span", SrcSpan -> JsonDoc
spanToDumpJSON SrcSpan
srcSpan )
                       , ( FilePath
"doc" , FilePath -> JsonDoc
JSString FilePath
str )
                       , ( FilePath
"messageClass", MessageClass -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json MessageClass
msg_class )
                       ]
      spanToDumpJSON :: SrcSpan -> JsonDoc
      spanToDumpJSON :: SrcSpan -> JsonDoc
spanToDumpJSON SrcSpan
s = case SrcSpan
s of
                 (RealSrcSpan RealSrcSpan
rss Maybe BufSpan
_) -> [(FilePath, JsonDoc)] -> JsonDoc
JSObject [ (FilePath
"file", FilePath -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json FilePath
file)
                                                , (FilePath
"startLine", Int -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json (Int -> JsonDoc) -> Int -> JsonDoc
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rss)
                                                , (FilePath
"startCol", Int -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json (Int -> JsonDoc) -> Int -> JsonDoc
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
rss)
                                                , (FilePath
"endLine", Int -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json (Int -> JsonDoc) -> Int -> JsonDoc
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
rss)
                                                , (FilePath
"endCol", Int -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json (Int -> JsonDoc) -> Int -> JsonDoc
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
rss)
                                                ]
                   where file :: FilePath
file = FastString -> FilePath
unpackFS (FastString -> FilePath) -> FastString -> FilePath
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
rss
                 GeneratedSrcSpan{} -> JsonDoc
JSNull
                 UnhelpfulSpan{} -> JsonDoc
JSNull

-- | The default 'LogAction' prints to 'stdout' and 'stderr'.
--
-- To replicate the default log action behaviour with different @out@ and @err@
-- handles, see 'defaultLogActionWithHandles'.
defaultLogAction :: LogAction
defaultLogAction :: LogAction
defaultLogAction = Handle -> Handle -> LogAction
defaultLogActionWithHandles Handle
stdout Handle
stderr

-- | The default 'LogAction' parametrized over the standard output and standard error handles.
-- Allows clients to replicate the log message formatting of GHC with custom handles.
defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction
defaultLogActionWithHandles :: Handle -> Handle -> LogAction
defaultLogActionWithHandles Handle
out Handle
err LogFlags
logflags MessageClass
msg_class SrcSpan
srcSpan SDoc
msg
  | DumpFlag -> LogFlags -> Bool
log_dopt DumpFlag
Opt_D_dump_json LogFlags
logflags = Handle -> LogAction
jsonLogActionWithHandle Handle
out LogFlags
logflags MessageClass
msg_class SrcSpan
srcSpan SDoc
msg
  | Bool
otherwise = case MessageClass
msg_class of
      MessageClass
MCOutput                     -> SDoc -> IO ()
printOut SDoc
msg
      MessageClass
MCDump                       -> SDoc -> IO ()
printOut (SDoc
msg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
blankLine)
      MessageClass
MCInteractive                -> SDoc -> IO ()
putStrSDoc SDoc
msg
      MessageClass
MCInfo                       -> SDoc -> IO ()
printErrs SDoc
msg
      MessageClass
MCFatal                      -> SDoc -> IO ()
printErrs SDoc
msg
      MCDiagnostic Severity
SevIgnore ResolvedDiagnosticReason
_ Maybe DiagnosticCode
_   -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- suppress the message
      MCDiagnostic Severity
_sev ResolvedDiagnosticReason
_rea Maybe DiagnosticCode
_code -> LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc
decorateDiagnostic LogFlags
logflags MessageClass
msg_class SrcSpan
srcSpan SDoc
msg IO SDoc -> (SDoc -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SDoc -> IO ()
printErrs
    where
      printOut :: SDoc -> IO ()
printOut   = LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc  LogFlags
logflags Bool
False Handle
out
      printErrs :: SDoc -> IO ()
printErrs  = LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc  LogFlags
logflags Bool
False Handle
err
      putStrSDoc :: SDoc -> IO ()
putStrSDoc = LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc LogFlags
logflags Bool
False Handle
out

-- This function is used by `defaultLogActionWithHandles` for non-JSON output,
-- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered`
-- message on `-fdiagnostics-as-json`.
--
-- We would want to eventually consolidate this.  However, this is currently
-- not feasible for the following reasons:
--
-- 1. Some parts of the compiler sidestep `printMessages`, for that reason we
--    can not decorate the message in `printMessages`.
--
-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics.  For
--    that reason we can not decorate the message in `defaultLogActionWithHandles`.
--
--    See also Note [JSON Error Messages]:
--
--      `jsonLogAction` should be removed along with -ddump-json
--
-- Also note that (1) is the reason why some parts of the compiler produce
-- diagnostics that don't respect `-fdiagnostics-as-json`.
--
-- The plan as I see it is as follows:
--
--  1. Refactor all places in the compiler that report diagnostics to go
--     through `GHC.Driver.Errors.printMessages`.
--
--     (It's easy to find all those places by looking for who creates
--     MCDiagnostic, either directly or via `mkMCDiagnostic` or
--     `errorDiagnostic`.)
--
--  2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message
--     decoration at one place (either `printMessages` or
--     `defaultLogActionWithHandles`)
--
-- This story is tracked by #24113.
decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc
decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc
decorateDiagnostic LogFlags
logflags MessageClass
msg_class SrcSpan
srcSpan SDoc
msg = IO SDoc
addCaret
    where
      -- Pretty print the warning flag, if any (#10752)
      message :: SDoc
      message :: SDoc
message = Bool -> MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessageWarningGroups (LogFlags -> Bool
log_show_warn_groups LogFlags
logflags) MessageClass
msg_class SrcSpan
srcSpan SDoc
msg

      addCaret :: IO SDoc
      addCaret :: IO SDoc
addCaret = do
        caretDiagnostic <-
            if LogFlags -> Bool
log_show_caret LogFlags
logflags
            then MessageClass -> SrcSpan -> IO SDoc
getCaretDiagnostic MessageClass
msg_class SrcSpan
srcSpan
            else SDoc -> IO SDoc
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SDoc
forall doc. IsOutput doc => doc
empty
        return $ getPprStyle $ \PprStyle
style ->
          PprStyle -> SDoc -> SDoc
withPprStyle (Bool -> PprStyle -> PprStyle
setStyleColoured Bool
True PprStyle
style)
            (SDoc
message SDoc -> SDoc -> SDoc
$+$ SDoc
caretDiagnostic SDoc -> SDoc -> SDoc
$+$ SDoc
blankLine)

-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc LogFlags
logflags Bool
asciiSpace Handle
h SDoc
d
 = LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc LogFlags
logflags Bool
asciiSpace Handle
h (SDoc
d SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"")

-- | The boolean arguments let's the pretty printer know if it can optimize indent
-- by writing ascii ' ' characters without going through decoding.
defaultLogActionHPutStrDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc LogFlags
logflags Bool
asciiSpace Handle
h SDoc
d
  -- Don't add a newline at the end, so that successive
  -- calls to this log-action can output all on the same line
  = SDocContext -> Mode -> Handle -> SDoc -> IO ()
printSDoc (LogFlags -> SDocContext
log_default_user_context LogFlags
logflags) (Bool -> Mode
Pretty.PageMode Bool
asciiSpace) Handle
h SDoc
d

--
-- Note [JSON Error Messages]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- When the user requests the compiler output to be dumped as json
-- we used to collect them all in an IORef and then print them at the end.
-- This doesn't work very well with GHCi. (See #14078) So instead we now
-- use the simpler method of just outputting a JSON document inplace to
-- stdout.
--
-- Before the compiler calls log_action, it has already turned the `ErrMsg`
-- into a formatted message. This means that we lose some possible
-- information to provide to the user but refactoring log_action is quite
-- invasive as it is called in many places. So, for now I left it alone
-- and we can refine its behaviour as users request different output.
--
-- The recent work here replaces the purpose of flag -ddump-json with
-- -fdiagnostics-as-json. For temporary backwards compatibility while
-- -ddump-json is being deprecated, `jsonLogAction` has been added in, but
-- it should be removed along with -ddump-json. Similarly, the guard in
-- `defaultLogAction` should be removed. This cleanup is tracked in #24113.

-- | Default action for 'dumpAction' hook
defaultDumpAction :: DumpCache -> LogAction -> DumpAction
defaultDumpAction :: DumpCache -> LogAction -> DumpAction
defaultDumpAction DumpCache
dumps LogAction
log_action LogFlags
logflags PprStyle
sty DumpFlag
flag FilePath
title DumpFormat
_fmt SDoc
doc =
  DumpCache
-> LogAction
-> PprStyle
-> LogFlags
-> DumpFlag
-> FilePath
-> SDoc
-> IO ()
dumpSDocWithStyle DumpCache
dumps LogAction
log_action PprStyle
sty LogFlags
logflags DumpFlag
flag FilePath
title SDoc
doc

-- | Write out a dump.
--
-- If --dump-to-file is set then this goes to a file.
-- otherwise emit to stdout (via the LogAction parameter).
--
-- When @hdr@ is empty, we print in a more compact format (no separators and
-- blank lines)
dumpSDocWithStyle :: DumpCache -> LogAction -> PprStyle -> LogFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpSDocWithStyle :: DumpCache
-> LogAction
-> PprStyle
-> LogFlags
-> DumpFlag
-> FilePath
-> SDoc
-> IO ()
dumpSDocWithStyle DumpCache
dumps LogAction
log_action PprStyle
sty LogFlags
logflags DumpFlag
flag FilePath
hdr SDoc
doc =
    DumpCache
-> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle DumpCache
dumps LogFlags
logflags DumpFlag
flag Maybe Handle -> IO ()
writeDump
  where
    -- write dump to file
    writeDump :: Maybe Handle -> IO ()
writeDump (Just Handle
handle) = do
        doc' <- if FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
hdr
                then SDoc -> IO SDoc
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
doc
                else do timeStamp <- if LogFlags -> Bool
log_enable_timestamps LogFlags
logflags
                          then (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (FilePath -> SDoc) -> (UTCTime -> FilePath) -> UTCTime -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> FilePath
forall a. Show a => a -> FilePath
show) (UTCTime -> SDoc) -> IO UTCTime -> IO SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
                          else SDoc -> IO SDoc
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SDoc
forall doc. IsOutput doc => doc
empty
                        let d = SDoc
timeStamp
                                SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
blankLine
                                SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
doc
                        return $ mkDumpDoc hdr d
        -- When we dump to files we use UTF8. Which allows ascii spaces.
        defaultLogActionHPrintDoc logflags True handle (withPprStyle sty doc')

    -- write the dump to stdout
    writeDump Maybe Handle
Nothing = do
        let (SDoc
doc', MessageClass
msg_class)
              | FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
hdr  = (SDoc
doc, MessageClass
MCOutput)
              | Bool
otherwise = (FilePath -> SDoc -> SDoc
mkDumpDoc FilePath
hdr SDoc
doc, MessageClass
MCDump)
        LogAction
log_action LogFlags
logflags MessageClass
msg_class SrcSpan
noSrcSpan (PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
sty SDoc
doc')


-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a
-- file, otherwise 'Nothing'.
withDumpFileHandle :: DumpCache -> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle :: DumpCache
-> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle DumpCache
dumps LogFlags
logflags DumpFlag
flag Maybe Handle -> IO ()
action = do
    let dump_ways :: Maybe Ways
dump_ways = LogFlags -> Maybe Ways
log_ways LogFlags
logflags
    let mFile :: Maybe FilePath
mFile = LogFlags -> Maybe Ways -> DumpFlag -> Maybe FilePath
chooseDumpFile LogFlags
logflags Maybe Ways
dump_ways DumpFlag
flag
    case Maybe FilePath
mFile of
      Just FilePath
fileName -> do
        lock <- DumpCache
-> (Map FilePath (MVar ()) -> IO (Map FilePath (MVar ()), MVar ()))
-> IO (MVar ())
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar DumpCache
dumps ((Map FilePath (MVar ()) -> IO (Map FilePath (MVar ()), MVar ()))
 -> IO (MVar ()))
-> (Map FilePath (MVar ()) -> IO (Map FilePath (MVar ()), MVar ()))
-> IO (MVar ())
forall a b. (a -> b) -> a -> b
$ \Map FilePath (MVar ())
gd ->
            case FilePath -> Map FilePath (MVar ()) -> Maybe (MVar ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
fileName Map FilePath (MVar ())
gd of
              Maybe (MVar ())
Nothing -> do
                  lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
                  let gd' = FilePath
-> MVar () -> Map FilePath (MVar ()) -> Map FilePath (MVar ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FilePath
fileName MVar ()
lock Map FilePath (MVar ())
gd
                  -- ensure that file exists so we can append to it
                  createDirectoryIfMissing True (takeDirectory fileName)
                  writeFile fileName ""
                  return (gd', lock)
              Just MVar ()
lock -> do
                  (Map FilePath (MVar ()), MVar ())
-> IO (Map FilePath (MVar ()), MVar ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map FilePath (MVar ())
gd, MVar ()
lock)

        let withLock IO ()
k = MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \() -> IO ()
k IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        withLock $ withFile fileName AppendMode $ \Handle
handle -> do
            -- We do not want the dump file to be affected by
            -- environment variables, but instead to always use
            -- UTF8. See:
            -- https://gitlab.haskell.org/ghc/ghc/issues/10762
            Handle -> TextEncoding -> IO ()
hSetEncoding Handle
handle TextEncoding
utf8

            Maybe Handle -> IO ()
action (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
handle)
      Maybe FilePath
Nothing -> Maybe Handle -> IO ()
action Maybe Handle
forall a. Maybe a
Nothing

-- | Choose where to put a dump file based on LogFlags and DumpFlag
chooseDumpFile :: LogFlags -> Maybe Ways -> DumpFlag -> Maybe FilePath
chooseDumpFile :: LogFlags -> Maybe Ways -> DumpFlag -> Maybe FilePath
chooseDumpFile LogFlags
logflags Maybe Ways
ways DumpFlag
flag
    | LogFlags -> Bool
log_dump_to_file LogFlags
logflags Bool -> Bool -> Bool
|| Bool
forced_to_file
    = FilePath -> Maybe FilePath
FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ ShowS
setDir (FilePath
getPrefix FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
way_infix FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
dump_suffix)

    | Bool
otherwise
    = Maybe FilePath
forall a. Maybe a
Nothing
  where
    way_infix :: FilePath
way_infix = case Maybe Ways
ways of
      Maybe Ways
_ | Bool -> Bool
not (LogFlags -> Bool
log_with_ways LogFlags
logflags) -> FilePath
""
      Maybe Ways
Nothing -> FilePath
""
      Just Ways
ws
        | Ways -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Ways
ws Bool -> Bool -> Bool
|| FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Ways -> FilePath
waysTag Ways
ws) -> FilePath
""
        | Bool
otherwise -> Ways -> FilePath
waysTag Ways
ws FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"."
    (Bool
forced_to_file, FilePath
dump_suffix) = case DumpFlag
flag of
        -- -dth-dec-file dumps expansions of TH
        -- splices into MODULE.th.hs even when
        -- -ddump-to-file isn't set
        DumpFlag
Opt_D_th_dec_file -> (Bool
True, FilePath
"th.hs")
        DumpFlag
_                 -> (Bool
False, FilePath
default_suffix)

    -- build a suffix from the flag name
    -- e.g. -ddump-asm => ".dump-asm"
    default_suffix :: FilePath
default_suffix = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' then Char
'-' else Char
c) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      let str :: FilePath
str = DumpFlag -> FilePath
forall a. Show a => a -> FilePath
show DumpFlag
flag
      in case FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
"Opt_D_" FilePath
str of
        Just FilePath
x  -> FilePath
x
        Maybe FilePath
Nothing -> ShowS
forall a. HasCallStack => FilePath -> a
panic (FilePath
"chooseDumpFile: bad flag name: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
str)

    getPrefix :: FilePath
getPrefix
         -- dump file location is being forced
         --      by the -ddump-file-prefix flag.
       | Just FilePath
prefix <- LogFlags -> Maybe FilePath
log_dump_prefix_override LogFlags
logflags
          = FilePath
prefix
         -- dump file locations, module specified to [modulename] set by
         -- GHC.Driver.Pipeline.runPipeline; non-module specific, e.g. Chasing dependencies,
         -- to 'non-module' by default.
       | Bool
otherwise
          = LogFlags -> FilePath
log_dump_prefix LogFlags
logflags
    setDir :: ShowS
setDir FilePath
f = case LogFlags -> Maybe FilePath
log_dump_dir LogFlags
logflags of
                 Just FilePath
d  -> FilePath
d FilePath -> ShowS
</> FilePath
f
                 Maybe FilePath
Nothing ->       FilePath
f



-- | Default action for 'traceAction' hook
defaultTraceAction :: TraceAction a
defaultTraceAction :: forall a. TraceAction a
defaultTraceAction LogFlags
logflags FilePath
title SDoc
doc a
x =
  if Bool -> Bool
not (LogFlags -> Bool
log_enable_debug LogFlags
logflags)
    then a
x
    else FilePath -> a -> a
forall a. FilePath -> a -> a
trace (SDocContext -> SDoc -> FilePath
renderWithContext (LogFlags -> SDocContext
log_default_dump_context LogFlags
logflags)
                             ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
title, Int -> SDoc -> SDoc
nest Int
2 SDoc
doc])) a
x


-- | Log something
logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
mc SrcSpan
loc SDoc
msg = Logger -> LogAction
putLogMsg Logger
logger (Logger -> LogFlags
logFlags Logger
logger) MessageClass
mc SrcSpan
loc SDoc
msg

logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO ()
logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO ()
logJsonMsg Logger
logger MessageClass
mc = Logger -> LogJsonAction
putJsonLogMsg Logger
logger (Logger -> LogFlags
logFlags Logger
logger) MessageClass
mc

-- | Dump something
logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
logDumpFile :: Logger
-> PprStyle -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
logDumpFile Logger
logger = Logger -> DumpAction
putDumpFile Logger
logger (Logger -> LogFlags
logFlags Logger
logger)

-- | Log a trace message
logTraceMsg :: Logger -> String -> SDoc -> a -> a
logTraceMsg :: forall a. Logger -> FilePath -> SDoc -> a -> a
logTraceMsg Logger
logger FilePath
hdr SDoc
doc a
a = Logger -> TraceAction a
forall a. Logger -> TraceAction a
putTraceMsg Logger
logger (Logger -> LogFlags
logFlags Logger
logger) FilePath
hdr SDoc
doc a
a

-- | Log a dump message (not a dump file)
logDumpMsg :: Logger -> String -> SDoc -> IO ()
logDumpMsg :: Logger -> FilePath -> SDoc -> IO ()
logDumpMsg Logger
logger FilePath
hdr SDoc
doc = Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
MCDump SrcSpan
noSrcSpan
  (PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle
  (FilePath -> SDoc -> SDoc
mkDumpDoc FilePath
hdr SDoc
doc))

mkDumpDoc :: String -> SDoc -> SDoc
mkDumpDoc :: FilePath -> SDoc -> SDoc
mkDumpDoc FilePath
hdr SDoc
doc
   = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [SDoc
blankLine,
           SDoc
line SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
hdr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
line,
           SDoc
doc,
           SDoc
blankLine]
     where
        line :: SDoc
line = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"===================="


-- | Dump if the given DumpFlag is set
putDumpFileMaybe :: Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe :: Logger -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger = Logger
-> NamePprCtx
-> DumpFlag
-> FilePath
-> DumpFormat
-> SDoc
-> IO ()
putDumpFileMaybe' Logger
logger NamePprCtx
alwaysQualify
{-# INLINE putDumpFileMaybe #-}  -- see Note [INLINE conditional tracing utilities]

-- | Dump if the given DumpFlag is set
--
-- Unlike 'putDumpFileMaybe', has a NamePprCtx argument
putDumpFileMaybe'
    :: Logger
    -> NamePprCtx
    -> DumpFlag
    -> String
    -> DumpFormat
    -> SDoc
    -> IO ()
putDumpFileMaybe' :: Logger
-> NamePprCtx
-> DumpFlag
-> FilePath
-> DumpFormat
-> SDoc
-> IO ()
putDumpFileMaybe' Logger
logger NamePprCtx
name_ppr_ctx DumpFlag
flag FilePath
hdr DumpFormat
fmt SDoc
doc
  = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
flag) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Logger
-> NamePprCtx
-> DumpFlag
-> FilePath
-> DumpFormat
-> SDoc
-> IO ()
logDumpFile' Logger
logger NamePprCtx
name_ppr_ctx DumpFlag
flag FilePath
hdr DumpFormat
fmt SDoc
doc
{-# INLINE putDumpFileMaybe' #-}  -- see Note [INLINE conditional tracing utilities]


logDumpFile' :: Logger -> NamePprCtx -> DumpFlag
             -> String -> DumpFormat -> SDoc -> IO ()
{-# NOINLINE logDumpFile' #-}
-- NOINLINE: Now we are past the conditional, into the "cold" path,
--           don't inline, to reduce code size at the call site
-- See Note [INLINE conditional tracing utilities]
logDumpFile' :: Logger
-> NamePprCtx
-> DumpFlag
-> FilePath
-> DumpFormat
-> SDoc
-> IO ()
logDumpFile' Logger
logger NamePprCtx
name_ppr_ctx DumpFlag
flag FilePath
hdr DumpFormat
fmt SDoc
doc
  = Logger
-> PprStyle -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
logDumpFile Logger
logger (NamePprCtx -> PprStyle
mkDumpStyle NamePprCtx
name_ppr_ctx) DumpFlag
flag FilePath
hdr DumpFormat
fmt SDoc
doc

-- | Ensure that a dump file is created even if it stays empty
touchDumpFile :: Logger -> DumpFlag -> IO ()
touchDumpFile :: Logger -> DumpFlag -> IO ()
touchDumpFile Logger
logger DumpFlag
flag =
    DumpCache
-> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle (Logger -> DumpCache
generated_dumps Logger
logger) (Logger -> LogFlags
logFlags Logger
logger) DumpFlag
flag (IO () -> Maybe Handle -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()))

class HasLogger m where
    getLogger :: m Logger

class ContainsLogger t where
    extractLogger :: t -> Logger