{-# LANGUAGE RankNTypes #-}

-- | 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
    , defaultLogJsonAction
    , defaultLogActionHPrintDoc
    , defaultLogActionHPutStrDoc
    , logMsg
    , logJsonMsg
    , logDumpMsg

    -- * 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
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 (ZonkAny 0) -> TraceAction (ZonkAny 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
jsonLogAction :: LogAction
jsonLogAction :: LogAction
jsonLogAction 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
jsonLogAction LogFlags
logflags MessageClass
msg_class SrcSpan
srcSpan SDoc
msg
  =
    LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc LogFlags
logflags Bool
True Handle
stdout
      (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
                 UnhelpfulSpan UnhelpfulSpanReason
_ -> JsonDoc
JSNull

defaultLogAction :: LogAction
defaultLogAction :: LogAction
defaultLogAction LogFlags
logflags MessageClass
msg_class SrcSpan
srcSpan SDoc
msg
  | DumpFlag -> LogFlags -> Bool
log_dopt DumpFlag
Opt_D_dump_json LogFlags
logflags = LogAction
jsonLogAction 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 -> IO ()
printDiagnostics
    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
      -- Pretty print the warning flag, if any (#10752)
      message :: SDoc
message = Bool -> MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessageWarningGroups (LogFlags -> Bool
log_show_warn_groups LogFlags
logflags) MessageClass
msg_class SrcSpan
srcSpan SDoc
msg

      printDiagnostics :: IO ()
printDiagnostics = 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
        printErrs $ 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)
        -- careful (#2302): printErrs prints in UTF-8,
        -- whereas converting to string first and using
        -- hPutStr would just emit the low 8 bits of
        -- each unicode char.

-- | 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
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 :: ToJson a => Logger -> MessageClass -> a -> IO ()
logJsonMsg :: forall a. ToJson a => Logger -> MessageClass -> a -> IO ()
logJsonMsg Logger
logger MessageClass
mc a
d = Logger -> LogJsonAction
putJsonLogMsg Logger
logger (Logger -> LogFlags
logFlags Logger
logger) MessageClass
mc  (a -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json a
d)

-- | 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