summaryrefslogtreecommitdiff
path: root/compiler/GHC/Utils/Logger.hs
blob: 341d68b2e50807670e88fb826c3dbbe78f3d1e32 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
{-# 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
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