{-# 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
    , DumpAction
    , TraceAction
    , DumpFormat (..)

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

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

    -- * Logging
    , jsonLogAction
    , putLogMsg
    , defaultLogAction
    , defaultLogActionHPrintDoc
    , defaultLogActionHPutStrDoc
    , logMsg
    , 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 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_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           = forall a. EnumSet a
EnumSet.empty
  , log_show_caret :: Bool
log_show_caret           = Bool
True
  , 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             = forall a. Maybe a
Nothing
  , log_dump_prefix :: FilePath
log_dump_prefix          = FilePath
""
  , log_dump_prefix_override :: Maybe FilePath
log_dump_prefix_override = 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                 = forall a. Maybe a
Nothing
  }

-- | Test if a DumpFlag is enabled
log_dopt :: DumpFlag -> LogFlags -> Bool
log_dopt :: DumpFlag -> LogFlags -> Bool
log_dopt = 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 DumpFlag
log_dump_flags = forall a. Enum a => a -> EnumSet a -> EnumSet a
EnumSet.insert DumpFlag
f (LogFlags -> EnumSet DumpFlag
log_dump_flags LogFlags
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) 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 :: LogFlags
logFlags = LogFlags
flags }


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

type LogAction = LogFlags
              -> MessageClass
              -> SrcSpan
              -> SDoc
              -> 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
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [DumpFormat] -> ShowS
$cshowList :: [DumpFormat] -> ShowS
show :: DumpFormat -> FilePath
$cshow :: DumpFormat -> FilePath
showsPrec :: Int -> DumpFormat -> ShowS
$cshowsPrec :: Int -> DumpFormat -> ShowS
Show,DumpFormat -> DumpFormat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DumpFormat -> DumpFormat -> Bool
$c/= :: DumpFormat -> DumpFormat -> Bool
== :: DumpFormat -> DumpFormat -> Bool
$c== :: 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 -> [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 :: IO ()
trace_flush = IO () -> IO ()
upd (Logger -> IO ()
trace_flush Logger
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
    DumpCache
dumps <- forall a. a -> IO (MVar a)
newMVar forall k a. Map k a
Map.empty
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Logger
        { log_hook :: [LogAction -> LogAction]
log_hook        = []
        , dump_hook :: [DumpAction -> DumpAction]
dump_hook       = []
        , trace_hook :: forall a. [TraceAction a -> TraceAction a]
trace_hook      = []
        , generated_dumps :: DumpCache
generated_dumps = DumpCache
dumps
        , trace_flush :: IO ()
trace_flush     = IO ()
defaultTraceFlush
        , logFlags :: LogFlags
logFlags        = LogFlags
defaultLogFlags
        }

-- | Log something
putLogMsg :: Logger -> LogAction
putLogMsg :: Logger -> LogAction
putLogMsg Logger
logger = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) LogAction
defaultLogAction (Logger -> [LogAction -> LogAction]
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 forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) 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 :: [LogAction -> LogAction]
log_hook = LogAction -> LogAction
hforall a. a -> [a] -> [a]
:Logger -> [LogAction -> LogAction]
log_hook Logger
logger }

-- | Pop a log hook
popLogHook :: Logger -> Logger
popLogHook :: Logger -> Logger
popLogHook Logger
logger = case Logger -> [LogAction -> LogAction]
log_hook Logger
logger of
    []   -> forall a. HasCallStack => FilePath -> a
panic FilePath
"popLogHook: empty hook stack"
    LogAction -> LogAction
_:[LogAction -> LogAction]
hs -> Logger
logger { log_hook :: [LogAction -> LogAction]
log_hook = [LogAction -> LogAction]
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 :: [DumpAction -> DumpAction]
dump_hook = DumpAction -> DumpAction
hforall a. a -> [a] -> [a]
:Logger -> [DumpAction -> DumpAction]
dump_hook Logger
logger }

-- | Pop a dump hook
popDumpHook :: Logger -> Logger
popDumpHook :: Logger -> Logger
popDumpHook Logger
logger = case Logger -> [DumpAction -> DumpAction]
dump_hook Logger
logger of
    []   -> forall a. HasCallStack => FilePath -> a
panic FilePath
"popDumpHook: empty hook stack"
    DumpAction -> DumpAction
_:[DumpAction -> DumpAction]
hs -> Logger
logger { dump_hook :: [DumpAction -> DumpAction]
dump_hook = [DumpAction -> DumpAction]
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 :: forall a. [TraceAction a -> TraceAction a]
trace_hook = forall a. TraceAction a -> TraceAction a
hforall a. a -> [a] -> [a]
:Logger -> forall a. [TraceAction a -> TraceAction a]
trace_hook Logger
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
    [] -> forall a. HasCallStack => FilePath -> a
panic FilePath
"popTraceHook: empty hook stack"
    [TraceAction Any -> TraceAction Any]
_  -> Logger
logger { trace_hook :: forall a. [TraceAction a -> TraceAction a]
trace_hook = forall a. [a] -> [a]
tail (Logger -> forall a. [TraceAction a -> TraceAction a]
trace_hook Logger
logger) }

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

        log :: (t -> t -> t -> t -> IO a) -> t -> t -> t -> t -> IO a
log t -> t -> t -> t -> IO a
action t
logflags t
msg_class t
loc t
doc =
            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)
-> t -> t -> t -> t -> t -> t -> IO a
dmp t -> t -> t -> t -> t -> t -> IO a
action t
logflags t
sty t
opts t
str t
fmt t
doc =
            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 :: forall a. TraceAction a -> TraceAction a
trc TraceAction a
action LogFlags
logflags FilePath
str SDoc
doc a
v =
            forall a. IO a -> a
unsafePerformIO (forall a. IO a -> IO a
with_lock (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! TraceAction a
action LogFlags
logflags FilePath
str SDoc
doc a
v))

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (LogAction -> LogAction) -> Logger -> Logger
pushLogHook forall {t} {t} {t} {t} {a}.
(t -> t -> t -> t -> IO a) -> t -> t -> t -> t -> IO a
log
           forall a b. (a -> b) -> a -> b
$ (DumpAction -> DumpAction) -> Logger -> Logger
pushDumpHook forall {t} {t} {t} {t} {t} {t} {a}.
(t -> t -> t -> t -> t -> t -> IO a)
-> t -> t -> t -> t -> t -> t -> IO a
dmp
           forall a b. (a -> b) -> a -> b
$ (forall a. TraceAction a -> TraceAction a) -> Logger -> Logger
pushTraceHook forall a. TraceAction a -> TraceAction a
trc
           forall a b. (a -> b) -> a -> b
$ Logger
logger

-- See Note [JSON Error Messages]
--
jsonLogAction :: LogAction
jsonLogAction :: LogAction
jsonLogAction LogFlags
_ (MCDiagnostic Severity
SevIgnore DiagnosticReason
_ Maybe DiagnosticCode
_) SrcSpan
_ SDoc
_ = 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 forall doc. IsDoc doc => doc -> doc -> doc
$$ 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 forall a b. (a -> b) -> a -> b
$
              [(FilePath, JsonDoc)] -> JsonDoc
JSObject [ ( FilePath
"span", forall a. ToJson a => a -> JsonDoc
json SrcSpan
srcSpan )
                       , ( FilePath
"doc" , FilePath -> JsonDoc
JSString FilePath
str )
                       , ( FilePath
"messageClass", forall a. ToJson a => a -> JsonDoc
json MessageClass
msg_class )
                       ]

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 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 DiagnosticReason
_ Maybe DiagnosticCode
_   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- suppress the message
      MCDiagnostic Severity
_sev DiagnosticReason
_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
        Handle -> Char -> IO ()
hPutChar Handle
stderr Char
'\n'
        SDoc
caretDiagnostic <-
            if LogFlags -> Bool
log_show_caret LogFlags
logflags
            then MessageClass -> SrcSpan -> IO SDoc
getCaretDiagnostic MessageClass
msg_class SrcSpan
srcSpan
            else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall doc. IsOutput doc => doc
empty
        SDoc -> IO ()
printErrs forall a b. (a -> b) -> a -> b
$ (PprStyle -> SDoc) -> SDoc
getPprStyle forall a b. (a -> b) -> a -> b
$ \PprStyle
style ->
          PprStyle -> SDoc -> SDoc
withPprStyle (Bool -> PprStyle -> PprStyle
setStyleColoured Bool
True PprStyle
style)
            (SDoc
message SDoc -> SDoc -> SDoc
$+$ SDoc
caretDiagnostic)
        -- 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 forall doc. IsDoc doc => doc -> doc -> doc
$$ 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.

-- | 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
        SDoc
doc' <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
hdr
                then forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
doc
                else do SDoc
timeStamp <- if LogFlags -> Bool
log_enable_timestamps LogFlags
logflags
                          then (forall doc. IsLine doc => FilePath -> doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
show) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
                          else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall doc. IsOutput doc => doc
empty
                        let d :: SDoc
d = SDoc
timeStamp
                                forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
blankLine
                                forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
doc
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc -> SDoc
mkDumpDoc FilePath
hdr SDoc
d
        -- When we dump to files we use UTF8. Which allows ascii spaces.
        LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc LogFlags
logflags Bool
True Handle
handle (PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
sty SDoc
doc')

    -- write the dump to stdout
    writeDump Maybe Handle
Nothing = do
        let (SDoc
doc', MessageClass
msg_class)
              | 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
        MVar ()
lock <- forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar DumpCache
dumps forall a b. (a -> b) -> a -> b
$ \Map FilePath (MVar ())
gd ->
            case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
fileName Map FilePath (MVar ())
gd of
              Maybe (MVar ())
Nothing -> do
                  MVar ()
lock <- forall a. a -> IO (MVar a)
newMVar ()
                  let gd' :: Map FilePath (MVar ())
gd' = 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
                  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory FilePath
fileName)
                  FilePath -> FilePath -> IO ()
writeFile FilePath
fileName FilePath
""
                  forall (m :: * -> *) a. Monad m => a -> m a
return (Map FilePath (MVar ())
gd', MVar ()
lock)
              Just MVar ()
lock -> do
                  forall (m :: * -> *) a. Monad m => a -> m a
return (Map FilePath (MVar ())
gd, MVar ()
lock)

        let withLock :: IO () -> IO ()
withLock IO ()
k = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock forall a b. (a -> b) -> a -> b
$ \() -> IO ()
k forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        IO () -> IO ()
withLock forall a b. (a -> b) -> a -> b
$ forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
fileName IOMode
AppendMode forall a b. (a -> b) -> a -> b
$ \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 (forall a. a -> Maybe a
Just Handle
handle)
      Maybe FilePath
Nothing -> Maybe Handle -> IO ()
action 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
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ShowS
setDir (FilePath
getPrefix forall a. [a] -> [a] -> [a]
++ FilePath
way_infix forall a. [a] -> [a] -> [a]
++ FilePath
dump_suffix)

    | Bool
otherwise
    = 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
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null Ways
ws Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Ways -> FilePath
waysTag Ways
ws) -> FilePath
""
        | Bool
otherwise -> Ways -> FilePath
waysTag Ways
ws 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 = forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' then Char
'-' else Char
c) forall a b. (a -> b) -> a -> b
$
      let str :: FilePath
str = forall a. Show a => a -> FilePath
show DumpFlag
flag
      in case forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
"Opt_D_" FilePath
str of
        Just FilePath
x  -> FilePath
x
        Maybe FilePath
Nothing -> forall a. HasCallStack => FilePath -> a
panic (FilePath
"chooseDumpFile: bad flag name: " 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 forall a. FilePath -> a -> a
trace (SDocContext -> SDoc -> FilePath
renderWithContext (LogFlags -> SDocContext
log_default_dump_context LogFlags
logflags)
                             (forall doc. IsLine doc => [doc] -> doc
sep [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

-- | 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 = 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
   = forall doc. IsDoc doc => [doc] -> doc
vcat [SDoc
blankLine,
           SDoc
line forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => FilePath -> doc
text FilePath
hdr forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
line,
           SDoc
doc,
           SDoc
blankLine]
     where
        line :: SDoc
line = 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
  = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
flag) 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 (forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ()))

class HasLogger m where
    getLogger :: m Logger

class ContainsLogger t where
    extractLogger :: t -> Logger