Logger.hs

{-# 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 (Show,Eq)

type DumpCache = IORef (Set FilePath)

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

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

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

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

initLogger :: IO Logger
initLogger = do
    dumps <- newIORef Set.empty
    return $ Logger
        { log_hook        = []
        , dump_hook       = []
        , trace_hook      = []
        , generated_dumps = dumps
        }

-- | Log something
putLogMsg :: Logger -> LogAction
putLogMsg logger = foldr ($) defaultLogAction (log_hook logger)

-- | Dump something
putDumpMsg :: Logger -> DumpAction
putDumpMsg logger =
    let
        fallback = putLogMsg logger
        dumps    = generated_dumps logger
        deflt    = defaultDumpAction dumps fallback
    in foldr ($) deflt (dump_hook logger)

-- | Trace something
putTraceMsg :: Logger -> TraceAction a
putTraceMsg logger = foldr ($) defaultTraceAction (trace_hook logger)


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

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

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

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

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

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

-- | Make the logger thread-safe
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 dflags reason sev loc doc =
            with_lock (action dflags reason sev loc doc)

        dmp action dflags sty opts str fmt doc =
            with_lock (action dflags sty opts str fmt doc)

        trc :: forall a. TraceAction a -> TraceAction a
        trc action dflags str doc v =
            unsafePerformIO (with_lock (return $! action dflags str doc v))

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

-- See Note [JSON Error Messages]
--
jsonLogAction :: LogAction
jsonLogAction dflags reason severity srcSpan msg
  =
    defaultLogActionHPutStrDoc dflags True stdout
      (withPprStyle (PprCode CStyle) (doc $$ text ""))
    where
      str = renderWithContext (initSDocContext dflags defaultUserStyle) msg
      doc = renderJSON $
              JSObject [ ( "span", json srcSpan )
                       , ( "doc" , JSString str )
                       , ( "severity", json severity )
                       , ( "reason" ,   json reason )
                       ]


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

      printWarns = do
        hPutChar stderr '\n'
        caretDiagnostic <-
            if gopt Opt_DiagnosticsShowCaret dflags
            then getCaretDiagnostic severity srcSpan
            else pure empty
        printErrs $ getPprStyle $ \style ->
          withPprStyle (setStyleColoured True style)
            (message $+$ 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 =
        case reason of
          NoReason -> Nothing
          Reason wflag -> do
            spec <- flagSpecOf wflag
            return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag)
          ErrReason Nothing ->
            return "-Werror"
          ErrReason (Just wflag) -> do
            spec <- flagSpecOf wflag
            return $
              "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++
              ", -Werror=" ++ flagSpecName spec

      warnFlagGrp flag
          | gopt Opt_ShowWarnGroups dflags =
                case smallestGroups flag of
                    [] -> ""
                    groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"
          | otherwise = ""

-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()
defaultLogActionHPrintDoc dflags asciiSpace h d
 = defaultLogActionHPutStrDoc dflags asciiSpace h (d $$ text "")

-- | 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 dflags asciiSpace h d
  -- Don't add a newline at the end, so that successive
  -- calls to this log-action can output all on the same line
  = printSDoc ctx (Pretty.PageMode asciiSpace) h d
    where
      ctx = initSDocContext dflags 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 dumps log_action dflags sty flag title _fmt doc =
  dumpSDocWithStyle dumps log_action sty dflags flag title 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 dumps log_action sty dflags flag hdr doc =
    withDumpFileHandle dumps dflags flag writeDump
  where
    -- write dump to file
    writeDump (Just handle) = do
        doc' <- if null hdr
                then return doc
                else do t <- getCurrentTime
                        let timeStamp = if (gopt Opt_SuppressTimestamps dflags)
                                          then empty
                                          else text (show t)
                        let d = timeStamp
                                $$ blankLine
                                $$ doc
                        return $ mkDumpDoc hdr d
        -- When we dump to files we use UTF8. Which allows ascii spaces.
        defaultLogActionHPrintDoc dflags True handle (withPprStyle sty doc')

    -- write the dump to stdout
    writeDump Nothing = do
        let (doc', severity)
              | null hdr  = (doc, SevOutput)
              | otherwise = (mkDumpDoc hdr doc, SevDump)
        log_action dflags NoReason severity noSrcSpan (withPprStyle sty 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 dumps dflags flag action = do
    let mFile = chooseDumpFile dflags 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
            -- 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
            hSetEncoding handle utf8

            action (Just handle)
      Nothing -> action Nothing

-- | Choose where to put a dump file based on DynFlags and DumpFlag
chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath
chooseDumpFile dflags flag
    | gopt Opt_DumpToFile dflags || forced_to_file
    , Just prefix <- getPrefix
    = Just $ setDir (prefix ++ dump_suffix)

    | otherwise
    = Nothing
  where
    (forced_to_file, dump_suffix) = case flag of
        -- -dth-dec-file dumps expansions of TH
        -- splices into MODULE.th.hs even when
        -- -ddump-to-file isn't set
        Opt_D_th_dec_file -> (True, "th.hs")
        _                 -> (False, default_suffix)

    -- build a suffix from the flag name
    -- e.g. -ddump-asm => ".dump-asm"
    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
         -- dump file location is being forced
         --      by the --ddump-file-prefix flag.
       | Just prefix <- dumpPrefixForce dflags
          = Just prefix
         -- dump file location chosen by GHC.Driver.Pipeline.runPipeline
       | Just prefix <- dumpPrefix dflags
          = Just prefix
         -- we haven't got a place to put a dump file.
       | otherwise
          = Nothing
    setDir f = case dumpDir dflags of
                 Just d  -> d </> f
                 Nothing ->       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 dflags hdr doc =
  putLogMsg logger dflags
            NoReason
            SevDump
            noSrcSpan
            (withPprStyle defaultDumpStyle
              (mkDumpDoc hdr doc))

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


dumpIfSet :: Logger -> DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet logger dflags flag hdr doc
  | not flag   = return ()
  | otherwise  = doDump logger dflags hdr 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 = dumpIfSet_dyn_printer 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 printer logger dflags flag hdr fmt doc
  = when (dopt flag dflags) $ do
      let sty = mkDumpStyle printer
      putDumpMsg logger dflags sty flag hdr fmt 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 dflags flag =
    withDumpFileHandle (generated_dumps logger) dflags flag (const (return ()))


-- | Default action for 'traceAction' hook
defaultTraceAction :: TraceAction a
defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc



class HasLogger m where
    getLogger :: m Logger

class ContainsLogger t where
    extractLogger :: t -> Logger