module GHC.Utils.Logger
( Logger
, HasLogger (..)
, ContainsLogger (..)
, initLogger
, LogAction
, DumpAction
, TraceAction
, DumpFormat (..)
, popLogHook
, pushLogHook
, popDumpHook
, pushDumpHook
, popTraceHook
, pushTraceHook
, makeThreadSafe
, LogFlags (..)
, defaultLogFlags
, log_dopt
, log_set_dopt
, setLogFlags
, updateLogFlags
, logFlags
, logHasDumpFlag
, logVerbAtLeast
, jsonLogAction
, putLogMsg
, defaultLogAction
, defaultLogActionHPrintDoc
, defaultLogActionHPutStrDoc
, logMsg
, logDumpMsg
, defaultDumpAction
, putDumpFile
, putDumpFileMaybe
, putDumpFileMaybe'
, withDumpFileHandle
, touchDumpFile
, logDumpFile
, 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 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 qualified Data.List.NonEmpty as NE
import Data.Time
import System.IO
import Control.Monad
import Control.Concurrent.MVar
import System.IO.Unsafe
import Debug.Trace (trace)
data LogFlags = LogFlags
{ log_default_user_context :: SDocContext
, log_default_dump_context :: SDocContext
, log_dump_flags :: !(EnumSet DumpFlag)
, log_show_caret :: !Bool
, log_show_warn_groups :: !Bool
, log_enable_timestamps :: !Bool
, log_dump_to_file :: !Bool
, log_dump_dir :: !(Maybe FilePath)
, log_dump_prefix :: !FilePath
, log_dump_prefix_override :: !(Maybe FilePath)
, log_enable_debug :: !Bool
, log_verbosity :: !Int
}
defaultLogFlags :: LogFlags
defaultLogFlags = LogFlags
{ log_default_user_context = defaultSDocContext
, log_default_dump_context = defaultSDocContext
, log_dump_flags = EnumSet.empty
, log_show_caret = True
, log_show_warn_groups = True
, log_enable_timestamps = True
, log_dump_to_file = False
, log_dump_dir = Nothing
, log_dump_prefix = ""
, log_dump_prefix_override = Nothing
, log_enable_debug = False
, log_verbosity = 0
}
log_dopt :: DumpFlag -> LogFlags -> Bool
log_dopt f logflags = f `EnumSet.member` log_dump_flags logflags
log_set_dopt :: DumpFlag -> LogFlags -> LogFlags
log_set_dopt f logflags = logflags { log_dump_flags = EnumSet.insert f (log_dump_flags logflags) }
logHasDumpFlag :: Logger -> DumpFlag -> Bool
logHasDumpFlag logger f = log_dopt f (logFlags logger)
logVerbAtLeast :: Logger -> Int -> Bool
logVerbAtLeast logger v = log_verbosity (logFlags logger) >= v
updateLogFlags :: Logger -> (LogFlags -> LogFlags) -> Logger
updateLogFlags logger f = setLogFlags logger (f (logFlags logger))
setLogFlags :: Logger -> LogFlags -> Logger
setLogFlags logger flags = logger { logFlags = flags }
type LogAction = LogFlags
-> MessageClass
-> SrcSpan
-> SDoc
-> IO ()
type DumpAction = LogFlags
-> PprStyle
-> DumpFlag
-> String
-> DumpFormat
-> SDoc
-> IO ()
type TraceAction a = LogFlags -> String -> SDoc -> a -> a
data DumpFormat
= FormatHaskell
| FormatCore
| FormatSTG
| FormatByteCode
| FormatCMM
| FormatASM
| FormatC
| FormatLLVM
| FormatText
deriving (Show,Eq)
type DumpCache = IORef (Set FilePath)
data Logger = Logger
{ log_hook :: [LogAction -> LogAction]
, dump_hook :: [DumpAction -> DumpAction]
, trace_hook :: forall a. [TraceAction a -> TraceAction a]
, generated_dumps :: DumpCache
, trace_flush :: IO ()
, logFlags :: !LogFlags
}
loggerTraceFlushUpdate :: Logger -> (IO () -> IO ()) -> Logger
loggerTraceFlushUpdate logger upd = logger { trace_flush = upd (trace_flush logger) }
loggerTraceFlush :: Logger -> IO ()
loggerTraceFlush logger = trace_flush logger
defaultTraceFlush :: IO ()
defaultTraceFlush = hFlush stderr
initLogger :: IO Logger
initLogger = do
dumps <- newIORef Set.empty
return $ Logger
{ log_hook = []
, dump_hook = []
, trace_hook = []
, generated_dumps = dumps
, trace_flush = defaultTraceFlush
, logFlags = defaultLogFlags
}
putLogMsg :: Logger -> LogAction
putLogMsg logger = foldr ($) defaultLogAction (log_hook logger)
putDumpFile :: Logger -> DumpAction
putDumpFile logger =
let
fallback = putLogMsg logger
dumps = generated_dumps logger
deflt = defaultDumpAction dumps fallback
in foldr ($) deflt (dump_hook logger)
putTraceMsg :: Logger -> TraceAction a
putTraceMsg logger = foldr ($) defaultTraceAction (trace_hook logger)
pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger
pushLogHook h logger = logger { log_hook = h:log_hook logger }
popLogHook :: Logger -> Logger
popLogHook logger = case log_hook logger of
[] -> panic "popLogHook: empty hook stack"
_:hs -> logger { log_hook = hs }
pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger
pushDumpHook h logger = logger { dump_hook = h:dump_hook logger }
popDumpHook :: Logger -> Logger
popDumpHook logger = case dump_hook logger of
[] -> panic "popDumpHook: empty hook stack"
_:hs -> logger { dump_hook = hs }
pushTraceHook :: (forall a. TraceAction a -> TraceAction a) -> Logger -> Logger
pushTraceHook h logger = logger { trace_hook = h:trace_hook logger }
popTraceHook :: Logger -> Logger
popTraceHook logger = case trace_hook logger of
[] -> panic "popTraceHook: empty hook stack"
_ -> logger { trace_hook = tail (trace_hook logger) }
makeThreadSafe :: Logger -> IO Logger
makeThreadSafe logger = do
lock <- newMVar ()
let
with_lock :: forall a. IO a -> IO a
with_lock act = withMVar lock (const act)
log action logflags msg_class loc doc =
with_lock (action logflags msg_class loc doc)
dmp action logflags sty opts str fmt doc =
with_lock (action logflags sty opts str fmt doc)
trc :: forall a. TraceAction a -> TraceAction a
trc action logflags str doc v =
unsafePerformIO (with_lock (return $! action logflags str doc v))
return $ pushLogHook log
$ pushDumpHook dmp
$ pushTraceHook trc
$ logger
jsonLogAction :: LogAction
jsonLogAction _ (MCDiagnostic SevIgnore _) _ _ = return ()
jsonLogAction logflags msg_class srcSpan msg
=
defaultLogActionHPutStrDoc logflags True stdout
(withPprStyle (PprCode CStyle) (doc $$ text ""))
where
str = renderWithContext (log_default_user_context logflags) msg
doc = renderJSON $
JSObject [ ( "span", json srcSpan )
, ( "doc" , JSString str )
, ( "messageClass", json msg_class )
]
defaultLogAction :: LogAction
defaultLogAction logflags msg_class srcSpan msg
| log_dopt Opt_D_dump_json logflags = jsonLogAction logflags msg_class srcSpan msg
| otherwise = case msg_class of
MCOutput -> printOut msg
MCDump -> printOut (msg $$ blankLine)
MCInteractive -> putStrSDoc msg
MCInfo -> printErrs msg
MCFatal -> printErrs msg
MCDiagnostic SevIgnore _ -> pure ()
MCDiagnostic sev rea -> printDiagnostics sev rea
where
printOut = defaultLogActionHPrintDoc logflags False stdout
printErrs = defaultLogActionHPrintDoc logflags False stderr
putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout
message sev rea = mkLocMessageAnn (flagMsg sev rea) msg_class srcSpan msg
printDiagnostics severity reason = do
hPutChar stderr '\n'
caretDiagnostic <-
if log_show_caret logflags
then getCaretDiagnostic msg_class srcSpan
else pure empty
printErrs $ getPprStyle $ \style ->
withPprStyle (setStyleColoured True style)
(message severity reason $+$ caretDiagnostic)
flagMsg :: Severity -> DiagnosticReason -> Maybe String
flagMsg SevIgnore _ = panic "Called flagMsg with SevIgnore"
flagMsg SevError WarningWithoutFlag = Just "-Werror"
flagMsg SevError (WarningWithFlag wflag) = do
let name = NE.head (warnFlagNames wflag)
return $
"-W" ++ name ++ warnFlagGrp wflag ++
", -Werror=" ++ name
flagMsg SevError ErrorWithoutFlag = Nothing
flagMsg SevWarning WarningWithoutFlag = Nothing
flagMsg SevWarning (WarningWithFlag wflag) = do
let name = NE.head (warnFlagNames wflag)
return ("-W" ++ name ++ warnFlagGrp wflag)
flagMsg SevWarning ErrorWithoutFlag =
panic "SevWarning with ErrorWithoutFlag"
warnFlagGrp flag
| log_show_warn_groups logflags =
case smallestWarningGroups flag of
[] -> ""
groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"
| otherwise = ""
defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc logflags asciiSpace h d
= defaultLogActionHPutStrDoc logflags asciiSpace h (d $$ text "")
defaultLogActionHPutStrDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPutStrDoc logflags asciiSpace h d
= printSDoc (log_default_user_context logflags) (Pretty.PageMode asciiSpace) h d
defaultDumpAction :: DumpCache -> LogAction -> DumpAction
defaultDumpAction dumps log_action logflags sty flag title _fmt doc =
dumpSDocWithStyle dumps log_action sty logflags flag title doc
dumpSDocWithStyle :: DumpCache -> LogAction -> PprStyle -> LogFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpSDocWithStyle dumps log_action sty logflags flag hdr doc =
withDumpFileHandle dumps logflags flag writeDump
where
writeDump (Just handle) = do
doc' <- if null hdr
then return doc
else do timeStamp <- if log_enable_timestamps logflags
then (text . show) <$> getCurrentTime
else pure empty
let d = timeStamp
$$ blankLine
$$ doc
return $ mkDumpDoc hdr d
defaultLogActionHPrintDoc logflags True handle (withPprStyle sty doc')
writeDump Nothing = do
let (doc', msg_class)
| null hdr = (doc, MCOutput)
| otherwise = (mkDumpDoc hdr doc, MCDump)
log_action logflags msg_class noSrcSpan (withPprStyle sty doc')
withDumpFileHandle :: DumpCache -> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
withDumpFileHandle dumps logflags flag action = do
let mFile = chooseDumpFile logflags flag
case mFile of
Just fileName -> do
gd <- readIORef dumps
let append = Set.member fileName gd
mode = if append then AppendMode else WriteMode
unless append $
writeIORef dumps (Set.insert fileName gd)
createDirectoryIfMissing True (takeDirectory fileName)
withFile fileName mode $ \handle -> do
hSetEncoding handle utf8
action (Just handle)
Nothing -> action Nothing
chooseDumpFile :: LogFlags -> DumpFlag -> Maybe FilePath
chooseDumpFile logflags flag
| log_dump_to_file logflags || forced_to_file
= Just $ setDir (getPrefix ++ dump_suffix)
| otherwise
= Nothing
where
(forced_to_file, dump_suffix) = case flag of
Opt_D_th_dec_file -> (True, "th.hs")
_ -> (False, default_suffix)
default_suffix = map (\c -> if c == '_' then '-' else c) $
let str = show flag
in case stripPrefix "Opt_D_" str of
Just x -> x
Nothing -> panic ("chooseDumpFile: bad flag name: " ++ str)
getPrefix
| Just prefix <- log_dump_prefix_override logflags
= prefix
| otherwise
= log_dump_prefix logflags
setDir f = case log_dump_dir logflags of
Just d -> d </> f
Nothing -> f
defaultTraceAction :: TraceAction a
defaultTraceAction logflags title doc x =
if not (log_enable_debug logflags)
then x
else trace (renderWithContext (log_default_dump_context logflags)
(sep [text title, nest 2 doc])) x
logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg
logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
logDumpFile logger = putDumpFile logger (logFlags logger)
logTraceMsg :: Logger -> String -> SDoc -> a -> a
logTraceMsg logger hdr doc a = putTraceMsg logger (logFlags logger) hdr doc a
logDumpMsg :: Logger -> String -> SDoc -> IO ()
logDumpMsg logger hdr doc = logMsg logger MCDump noSrcSpan
(withPprStyle defaultDumpStyle
(mkDumpDoc hdr doc))
mkDumpDoc :: String -> SDoc -> SDoc
mkDumpDoc hdr doc
= vcat [blankLine,
line <+> text hdr <+> line,
doc,
blankLine]
where
line = text "===================="
putDumpFileMaybe :: Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe logger = putDumpFileMaybe' logger alwaysQualify
putDumpFileMaybe'
:: Logger
-> PrintUnqualified
-> DumpFlag
-> String
-> DumpFormat
-> SDoc
-> IO ()
putDumpFileMaybe' logger printer flag hdr fmt doc
= when (logHasDumpFlag logger flag) $
logDumpFile' logger printer flag hdr fmt doc
logDumpFile' :: Logger -> PrintUnqualified -> DumpFlag
-> String -> DumpFormat -> SDoc -> IO ()
logDumpFile' logger printer flag hdr fmt doc
= logDumpFile logger (mkDumpStyle printer) flag hdr fmt doc
touchDumpFile :: Logger -> DumpFlag -> IO ()
touchDumpFile logger flag =
withDumpFileHandle (generated_dumps logger) (logFlags logger) flag (const (return ()))
class HasLogger m where
getLogger :: m Logger
class ContainsLogger t where
extractLogger :: t -> Logger