{-# LANGUAGE RankNTypes #-}

-- | Logger
module GHC.Utils.Logger
    ( Logger
    , initLogger
    , HasLogger (..)
    , ContainsLogger (..)
    , LogAction
    , DumpAction
    , TraceAction
    , DumpFormat (..)
    , putLogMsg
    , putDumpMsg
    , putTraceMsg

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

    -- * Logging
    , jsonLogAction
    , defaultLogAction
    , defaultLogActionHPrintDoc
    , defaultLogActionHPutStrDoc

    -- * Dumping
    , defaultDumpAction
    , withDumpFileHandle
    , touchDumpFile
    , dumpIfSet
    , dumpIfSet_dyn
    , dumpIfSet_dyn_printer

    -- * Tracing
    , defaultTraceAction
    )
where

import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Ppr
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 Data.IORef
import System.Directory
import System.FilePath  ( takeDirectory, (</>) )
import qualified Data.Set as Set
import Data.Set (Set)
import Data.List (intercalate, stripPrefix)
import Data.Time
import System.IO
import Control.Monad
import Control.Concurrent.MVar
import System.IO.Unsafe

type LogAction = DynFlags
              -> WarnReason
              -> Severity
              -> SrcSpan
              -> SDoc
              -> IO ()

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

type TraceAction a = DynFlags -> 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
   | 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
showList :: [DumpFormat] -> ShowS
$cshowList :: [DumpFormat] -> ShowS
show :: DumpFormat -> FilePath
$cshow :: DumpFormat -> FilePath
showsPrec :: Int -> DumpFormat -> ShowS
$cshowsPrec :: Int -> DumpFormat -> ShowS
Show,DumpFormat -> DumpFormat -> Bool
(DumpFormat -> DumpFormat -> Bool)
-> (DumpFormat -> DumpFormat -> Bool) -> Eq DumpFormat
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)

type DumpCache = IORef (Set FilePath)

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

initLogger :: IO Logger
initLogger :: IO Logger
initLogger = do
    DumpCache
dumps <- Set FilePath -> IO DumpCache
forall a. a -> IO (IORef a)
newIORef Set FilePath
forall a. Set a
Set.empty
    Logger -> IO Logger
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger -> IO Logger) -> Logger -> IO Logger
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
        }

-- | Log something
putLogMsg :: Logger -> LogAction
putLogMsg :: Logger -> LogAction
putLogMsg Logger
logger = ((LogAction -> LogAction) -> LogAction -> LogAction)
-> LogAction -> [LogAction -> LogAction] -> LogAction
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)

-- | Dump something
putDumpMsg :: Logger -> DumpAction
putDumpMsg :: Logger -> DumpAction
putDumpMsg 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 (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 (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 :: [LogAction -> LogAction]
log_hook = LogAction -> LogAction
h(LogAction -> LogAction)
-> [LogAction -> LogAction] -> [LogAction -> LogAction]
forall 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
    []   -> FilePath -> Logger
forall a. 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
h(DumpAction -> DumpAction)
-> [DumpAction -> DumpAction] -> [DumpAction -> DumpAction]
forall 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
    []   -> FilePath -> Logger
forall a. 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 = TraceAction a -> TraceAction a
forall a. TraceAction a -> TraceAction a
h(TraceAction a -> TraceAction a)
-> [TraceAction a -> TraceAction a]
-> [TraceAction a -> TraceAction a]
forall 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
    [] -> FilePath -> Logger
forall a. FilePath -> a
panic FilePath
"popTraceHook: empty hook stack"
    [TraceAction Any -> TraceAction Any]
_  -> Logger
logger { trace_hook :: forall a. [TraceAction a -> TraceAction a]
trace_hook = [TraceAction a -> TraceAction a]
-> [TraceAction a -> TraceAction a]
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 <- () -> IO (MVar ())
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 = 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 -> t -> IO a) -> t -> t -> t -> t -> t -> IO a
log t -> t -> t -> t -> t -> IO a
action t
dflags t
reason t
sev t
loc t
doc =
            IO a -> IO a
forall a. IO a -> IO a
with_lock (t -> t -> t -> t -> t -> IO a
action t
dflags t
reason t
sev 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
dflags 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
dflags 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 DynFlags
dflags 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 (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$! TraceAction a
action DynFlags
dflags FilePath
str SDoc
doc a
v))

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

-- See Note [JSON Error Messages]
--
jsonLogAction :: LogAction
jsonLogAction :: LogAction
jsonLogAction DynFlags
dflags WarnReason
reason Severity
severity SrcSpan
srcSpan SDoc
msg
  =
    DynFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc DynFlags
dflags Bool
True Handle
stdout
      (PprStyle -> SDoc -> SDoc
withPprStyle (LabelStyle -> PprStyle
PprCode LabelStyle
CStyle) (SDoc
doc SDoc -> SDoc -> SDoc
$$ FilePath -> SDoc
text FilePath
""))
    where
      str :: FilePath
str = SDocContext -> SDoc -> FilePath
renderWithContext (DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle) 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
forall a. ToJson a => a -> JsonDoc
json SrcSpan
srcSpan )
                       , ( FilePath
"doc" , FilePath -> JsonDoc
JSString FilePath
str )
                       , ( FilePath
"severity", Severity -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json Severity
severity )
                       , ( FilePath
"reason" ,   WarnReason -> JsonDoc
forall a. ToJson a => a -> JsonDoc
json WarnReason
reason )
                       ]


defaultLogAction :: LogAction
defaultLogAction :: LogAction
defaultLogAction DynFlags
dflags WarnReason
reason Severity
severity SrcSpan
srcSpan SDoc
msg
  | DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_json DynFlags
dflags = LogAction
jsonLogAction DynFlags
dflags WarnReason
reason Severity
severity SrcSpan
srcSpan SDoc
msg
  | Bool
otherwise = case Severity
severity of
      Severity
SevOutput      -> SDoc -> IO ()
printOut SDoc
msg
      Severity
SevDump        -> SDoc -> IO ()
printOut (SDoc
msg SDoc -> SDoc -> SDoc
$$ SDoc
blankLine)
      Severity
SevInteractive -> SDoc -> IO ()
putStrSDoc SDoc
msg
      Severity
SevInfo        -> SDoc -> IO ()
printErrs SDoc
msg
      Severity
SevFatal       -> SDoc -> IO ()
printErrs SDoc
msg
      Severity
SevWarning     -> IO ()
printWarns
      Severity
SevError       -> IO ()
printWarns
    where
      printOut :: SDoc -> IO ()
printOut   = DynFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc  DynFlags
dflags Bool
False Handle
stdout
      printErrs :: SDoc -> IO ()
printErrs  = DynFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc  DynFlags
dflags Bool
False Handle
stderr
      putStrSDoc :: SDoc -> IO ()
putStrSDoc = DynFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc DynFlags
dflags Bool
False Handle
stdout
      -- Pretty print the warning flag, if any (#10752)
      message :: SDoc
message = Maybe FilePath -> Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessageAnn Maybe FilePath
flagMsg Severity
severity SrcSpan
srcSpan SDoc
msg

      printWarns :: IO ()
printWarns = do
        Handle -> Char -> IO ()
hPutChar Handle
stderr Char
'\n'
        SDoc
caretDiagnostic <-
            if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DiagnosticsShowCaret DynFlags
dflags
            then Severity -> SrcSpan -> IO SDoc
getCaretDiagnostic Severity
severity SrcSpan
srcSpan
            else SDoc -> IO SDoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure SDoc
empty
        SDoc -> IO ()
printErrs (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ (PprStyle -> SDoc) -> SDoc
getPprStyle ((PprStyle -> SDoc) -> SDoc) -> (PprStyle -> SDoc) -> SDoc
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.

      flagMsg :: Maybe FilePath
flagMsg =
        case WarnReason
reason of
          WarnReason
NoReason -> Maybe FilePath
forall a. Maybe a
Nothing
          Reason WarningFlag
wflag -> do
            FlagSpec WarningFlag
spec <- WarningFlag -> Maybe (FlagSpec WarningFlag)
flagSpecOf WarningFlag
wflag
            FilePath -> Maybe FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
"-W" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FlagSpec WarningFlag -> FilePath
forall flag. FlagSpec flag -> FilePath
flagSpecName FlagSpec WarningFlag
spec FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ WarningFlag -> FilePath
warnFlagGrp WarningFlag
wflag)
          ErrReason Maybe WarningFlag
Nothing ->
            FilePath -> Maybe FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"-Werror"
          ErrReason (Just WarningFlag
wflag) -> do
            FlagSpec WarningFlag
spec <- WarningFlag -> Maybe (FlagSpec WarningFlag)
flagSpecOf WarningFlag
wflag
            FilePath -> Maybe FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$
              FilePath
"-W" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FlagSpec WarningFlag -> FilePath
forall flag. FlagSpec flag -> FilePath
flagSpecName FlagSpec WarningFlag
spec FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ WarningFlag -> FilePath
warnFlagGrp WarningFlag
wflag FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++
              FilePath
", -Werror=" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FlagSpec WarningFlag -> FilePath
forall flag. FlagSpec flag -> FilePath
flagSpecName FlagSpec WarningFlag
spec

      warnFlagGrp :: WarningFlag -> FilePath
warnFlagGrp WarningFlag
flag
          | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ShowWarnGroups DynFlags
dflags =
                case WarningFlag -> [FilePath]
smallestGroups WarningFlag
flag of
                    [] -> FilePath
""
                    [FilePath]
groups -> FilePath
" (in " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " (ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-W"FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++) [FilePath]
groups) FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
")"
          | Bool
otherwise = FilePath
""

-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc DynFlags
dflags Bool
asciiSpace Handle
h SDoc
d
 = DynFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc DynFlags
dflags Bool
asciiSpace Handle
h (SDoc
d SDoc -> SDoc -> SDoc
$$ FilePath -> SDoc
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 :: DynFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc DynFlags
dflags 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 SDocContext
ctx (Bool -> Mode
Pretty.PageMode Bool
asciiSpace) Handle
h SDoc
d
    where
      ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle

--
-- 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 DynFlags
dflags PprStyle
sty DumpFlag
flag FilePath
title DumpFormat
_fmt SDoc
doc =
  DumpCache
-> LogAction
-> PprStyle
-> DynFlags
-> DumpFlag
-> FilePath
-> SDoc
-> IO ()
dumpSDocWithStyle DumpCache
dumps LogAction
log_action PprStyle
sty DynFlags
dflags 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 the LogAction parameter).
--
-- When @hdr@ is empty, we print in a more compact format (no separators and
-- blank lines)
dumpSDocWithStyle :: DumpCache -> LogAction -> PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpSDocWithStyle :: DumpCache
-> LogAction
-> PprStyle
-> DynFlags
-> DumpFlag
-> FilePath
-> SDoc
-> IO ()
dumpSDocWithStyle DumpCache
dumps LogAction
log_action PprStyle
sty DynFlags
dflags DumpFlag
flag FilePath
hdr SDoc
doc =
    DumpCache
-> DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle DumpCache
dumps DynFlags
dflags DumpFlag
flag Maybe Handle -> IO ()
writeDump
  where
    -- write dump to file
    writeDump :: Maybe Handle -> IO ()
writeDump (Just Handle
handle) = do
        SDoc
doc' <- if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
hdr
                then SDoc -> IO SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
doc
                else do UTCTime
t <- IO UTCTime
getCurrentTime
                        let timeStamp :: SDoc
timeStamp = if (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressTimestamps DynFlags
dflags)
                                          then SDoc
empty
                                          else FilePath -> SDoc
text (UTCTime -> FilePath
forall a. Show a => a -> FilePath
show UTCTime
t)
                        let d :: SDoc
d = SDoc
timeStamp
                                SDoc -> SDoc -> SDoc
$$ SDoc
blankLine
                                SDoc -> SDoc -> SDoc
$$ SDoc
doc
                        SDoc -> IO SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> IO SDoc) -> SDoc -> IO SDoc
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.
        DynFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc DynFlags
dflags 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', Severity
severity)
              | FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
hdr  = (SDoc
doc, Severity
SevOutput)
              | Bool
otherwise = (FilePath -> SDoc -> SDoc
mkDumpDoc FilePath
hdr SDoc
doc, Severity
SevDump)
        LogAction
log_action DynFlags
dflags WarnReason
NoReason Severity
severity 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 -> DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle :: DumpCache
-> DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle DumpCache
dumps DynFlags
dflags DumpFlag
flag Maybe Handle -> IO ()
action = do
    let mFile :: Maybe FilePath
mFile = DynFlags -> DumpFlag -> Maybe FilePath
chooseDumpFile DynFlags
dflags DumpFlag
flag
    case Maybe FilePath
mFile of
      Just FilePath
fileName -> do
        Set FilePath
gd <- DumpCache -> IO (Set FilePath)
forall a. IORef a -> IO a
readIORef DumpCache
dumps
        let append :: Bool
append = FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FilePath
fileName Set FilePath
gd
            mode :: IOMode
mode = if Bool
append then IOMode
AppendMode else IOMode
WriteMode
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
append (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            DumpCache -> Set FilePath -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef DumpCache
dumps (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
Set.insert FilePath
fileName Set FilePath
gd)
        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory FilePath
fileName)
        FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
fileName IOMode
mode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
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 (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 DynFlags and DumpFlag
chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
chooseDumpFile DynFlags
dflags DumpFlag
flag
    | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DumpToFile DynFlags
dflags Bool -> Bool -> Bool
|| Bool
forced_to_file
    , Just FilePath
prefix <- Maybe FilePath
getPrefix
    = 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
prefix FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
dump_suffix)

    | Bool
otherwise
    = Maybe FilePath
forall a. Maybe a
Nothing
  where
    (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. FilePath -> a
panic (FilePath
"chooseDumpFile: bad flag name: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
str)

    getPrefix :: Maybe FilePath
getPrefix
         -- dump file location is being forced
         --      by the --ddump-file-prefix flag.
       | Just FilePath
prefix <- DynFlags -> Maybe FilePath
dumpPrefixForce DynFlags
dflags
          = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
prefix
         -- dump file location chosen by GHC.Driver.Pipeline.runPipeline
       | Just FilePath
prefix <- DynFlags -> Maybe FilePath
dumpPrefix DynFlags
dflags
          = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
prefix
         -- we haven't got a place to put a dump file.
       | Bool
otherwise
          = Maybe FilePath
forall a. Maybe a
Nothing
    setDir :: ShowS
setDir FilePath
f = case DynFlags -> Maybe FilePath
dumpDir DynFlags
dflags of
                 Just FilePath
d  -> FilePath
d FilePath -> ShowS
</> FilePath
f
                 Maybe FilePath
Nothing ->       FilePath
f

-- | This is a helper for 'dumpIfSet' to ensure that it's not duplicated
-- despite the fact that 'dumpIfSet' has an @INLINE@.
doDump :: Logger -> DynFlags -> String -> SDoc -> IO ()
doDump :: Logger -> DynFlags -> FilePath -> SDoc -> IO ()
doDump Logger
logger DynFlags
dflags FilePath
hdr SDoc
doc =
  Logger -> LogAction
putLogMsg Logger
logger DynFlags
dflags
            WarnReason
NoReason
            Severity
SevDump
            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
vcat [SDoc
blankLine,
           SDoc
line SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text FilePath
hdr SDoc -> SDoc -> SDoc
<+> SDoc
line,
           SDoc
doc,
           SDoc
blankLine]
     where
        line :: SDoc
line = FilePath -> SDoc
text FilePath
"===================="


dumpIfSet :: Logger -> DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet :: Logger -> DynFlags -> Bool -> FilePath -> SDoc -> IO ()
dumpIfSet Logger
logger DynFlags
dflags Bool
flag FilePath
hdr SDoc
doc
  | Bool -> Bool
not Bool
flag   = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise  = Logger -> DynFlags -> FilePath -> SDoc -> IO ()
doDump Logger
logger DynFlags
dflags FilePath
hdr SDoc
doc
{-# INLINE dumpIfSet #-}  -- see Note [INLINE conditional tracing utilities]

-- | A wrapper around 'dumpAction'.
-- First check whether the dump flag is set
-- Do nothing if it is unset
dumpIfSet_dyn :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn :: Logger
-> DynFlags -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn = PrintUnqualified
-> Logger
-> DynFlags
-> DumpFlag
-> FilePath
-> DumpFormat
-> SDoc
-> IO ()
dumpIfSet_dyn_printer PrintUnqualified
alwaysQualify
{-# INLINE dumpIfSet_dyn #-}  -- see Note [INLINE conditional tracing utilities]

-- | A wrapper around 'putDumpMsg'.
-- First check whether the dump flag is set
-- Do nothing if it is unset
--
-- Unlike 'dumpIfSet_dyn', has a printer argument
dumpIfSet_dyn_printer
    :: PrintUnqualified
    -> Logger
    -> DynFlags
    -> DumpFlag
    -> String
    -> DumpFormat
    -> SDoc
    -> IO ()
dumpIfSet_dyn_printer :: PrintUnqualified
-> Logger
-> DynFlags
-> DumpFlag
-> FilePath
-> DumpFormat
-> SDoc
-> IO ()
dumpIfSet_dyn_printer PrintUnqualified
printer Logger
logger DynFlags
dflags DumpFlag
flag FilePath
hdr DumpFormat
fmt SDoc
doc
  = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DumpFlag -> DynFlags -> Bool
dopt DumpFlag
flag DynFlags
dflags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let sty :: PprStyle
sty = PrintUnqualified -> PprStyle
mkDumpStyle PrintUnqualified
printer
      Logger -> DumpAction
putDumpMsg Logger
logger DynFlags
dflags PprStyle
sty DumpFlag
flag FilePath
hdr DumpFormat
fmt SDoc
doc
{-# INLINE dumpIfSet_dyn_printer #-}  -- see Note [INLINE conditional tracing utilities]

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


-- | Default action for 'traceAction' hook
defaultTraceAction :: TraceAction a
defaultTraceAction :: forall a. TraceAction a
defaultTraceAction DynFlags
dflags FilePath
title SDoc
doc = DynFlags -> FilePath -> SDoc -> a -> a
forall a. TraceAction a
pprTraceWithFlags DynFlags
dflags FilePath
title SDoc
doc



class HasLogger m where
    getLogger :: m Logger

class ContainsLogger t where
    extractLogger :: t -> Logger