Simon Hengel pushed to branch wip/sol/core-diagnostics at Glasgow Haskell Compiler / GHC

Commits:

6 changed files:

Changes:

  • compiler/GHC/Core/Opt/Monad.hs
    ... ... @@ -33,7 +33,7 @@ module GHC.Core.Opt.Monad (
    33 33 
         getAnnotations, getFirstAnnotations,
    34 34
    35 35 
         -- ** Screen output
    36 
    -    putMsg, putMsgS, errorMsg, msg,
    36 
    +    putMsg, putMsgS, errorMsg, msg, diagnostic,
    37 37 
         fatalErrorMsg, fatalErrorMsgS,
    38 38 
         debugTraceMsg, debugTraceMsgS,
    39 39 
       ) where
    ... ... @@ -41,6 +41,8 @@ module GHC.Core.Opt.Monad (
    41 41 
     import GHC.Prelude hiding ( read )
    42 42
    43 43 
     import GHC.Driver.DynFlags
    44 
    +import GHC.Driver.Errors ( reportDiagnostic, reportError )
    45 
    +import GHC.Driver.Config.Diagnostic ( initDiagOpts )
    44 46 
     import GHC.Driver.Env
    45 47
    46 48 
     import GHC.Core.Rules     ( RuleBase, RuleEnv, mkRuleEnv )
    ... ... @@ -52,7 +54,6 @@ import GHC.Types.Name.Env
    52 54 
     import GHC.Types.SrcLoc
    53 55 
     import GHC.Types.Error
    54 56
    55 
    -import GHC.Utils.Error ( errorDiagnostic )
    56 57 
     import GHC.Utils.Outputable as Outputable
    57 58 
     import GHC.Utils.Logger
    58 59 
     import GHC.Utils.Monad
    ... ... @@ -383,9 +384,22 @@ putMsgS = putMsg . text
    383 384 
     putMsg :: SDoc -> CoreM ()
    384 385 
     putMsg = msg MCInfo
    385 386
    387 
    +diagnostic :: DiagnosticReason -> SDoc -> CoreM ()
    388 
    +diagnostic reason doc = do
    389 
    +    logger <- getLogger
    390 
    +    loc <- getSrcSpanM
    391 
    +    name_ppr_ctx <- getNamePprCtx
    392 
    +    diag_opts <- initDiagOpts <$> getDynFlags
    393 
    +    liftIO $ reportDiagnostic logger name_ppr_ctx diag_opts loc reason doc
    394 
    +
    386 395 
     -- | Output an error to the screen. Does not cause the compiler to die.
    387 396 
     errorMsg :: SDoc -> CoreM ()
    388 
    -errorMsg doc = msg errorDiagnostic doc
    397 
    +errorMsg doc = do
    398 
    +    logger <- getLogger
    399 
    +    loc <- getSrcSpanM
    400 
    +    name_ppr_ctx <- getNamePprCtx
    401 
    +    diag_opts <- initDiagOpts <$> getDynFlags
    402 
    +    liftIO $ reportError logger name_ppr_ctx diag_opts loc doc
    389 403
    390 404 
     -- | Output a fatal error to the screen. Does not cause the compiler to die.
    391 405 
     fatalErrorMsgS :: String -> CoreM ()

  • compiler/GHC/Core/Opt/SpecConstr.hs
    ... ... @@ -45,7 +45,7 @@ import GHC.Core.Make ( mkImpossibleExpr )
    45 45 
     import GHC.Unit.Module
    46 46 
     import GHC.Unit.Module.ModGuts
    47 47
    48 
    -import GHC.Types.Error (MessageClass(..), Severity(..), DiagnosticReason(WarningWithoutFlag), ResolvedDiagnosticReason (..))
    48 
    +import GHC.Types.Error (DiagnosticReason(..))
    49 49 
     import GHC.Types.Literal ( litIsLifted )
    50 50 
     import GHC.Types.Id
    51 51 
     import GHC.Types.Id.Info ( IdDetails(..) )
    ... ... @@ -783,12 +783,11 @@ specConstrProgram guts
    783 783 
            ; let (_usg, binds', warnings) = initUs_ us $
    784 784 
                                   scTopBinds env0 (mg_binds guts)
    785 785
    786 
    -       ; when (not (null warnings)) $ msg specConstr_warn_class (warn_msg warnings)
    786 
    +       ; when (not (null warnings)) $ diagnostic WarningWithoutFlag (warn_msg warnings)
    787 787
    788 788 
            ; return (guts { mg_binds = binds' }) }
    789 789
    790 790 
       where
    791 
    -    specConstr_warn_class = MCDiagnostic SevWarning (ResolvedDiagnosticReason WarningWithoutFlag) Nothing
    792 791 
         warn_msg :: SpecFailWarnings -> SDoc
    793 792 
         warn_msg warnings = text "SpecConstr encountered one or more function(s) with a SPEC argument that resulted in too many arguments," $$
    794 793 
                             text "which resulted in no specialization being generated for these functions:" $$

  • compiler/GHC/Core/Opt/Specialise.hs
    ... ... @@ -12,7 +12,6 @@ import GHC.Prelude
    12 12
    13 13 
     import GHC.Driver.DynFlags
    14 14 
     import GHC.Driver.Config
    15 
    -import GHC.Driver.Config.Diagnostic
    16 15 
     import GHC.Driver.Config.Core.Rules ( initRuleOpts )
    17 16
    18 17 
     import GHC.Core.Type  hiding( substTy, substCo, extendTvSubst, zapSubst )
    ... ... @@ -55,7 +54,6 @@ import GHC.Types.Id
    55 54 
     import GHC.Types.Id.Info
    56 55 
     import GHC.Types.Error
    57 56
    58 
    -import GHC.Utils.Error ( mkMCDiagnostic )
    59 57 
     import GHC.Utils.Monad    ( foldlM )
    60 58 
     import GHC.Utils.Misc
    61 59 
     import GHC.Utils.Outputable
    ... ... @@ -938,10 +936,12 @@ tryWarnMissingSpecs dflags callers fn calls_for_fn
    938 936 
       | wopt Opt_WarnAllMissedSpecs dflags    = doWarn $ WarningWithFlag Opt_WarnAllMissedSpecs
    939 937 
       | otherwise                             = return ()
    940 938 
       where
    939 
    +    allCallersInlined :: Bool
    941 940 
         allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers
    942 
    -    diag_opts = initDiagOpts dflags
    941 
    +
    942 
    +    doWarn :: DiagnosticReason -> CoreM ()
    943 943 
         doWarn reason =
    944 
    -      msg (mkMCDiagnostic diag_opts reason Nothing)
    944 
    +      diagnostic reason
    945 945 
             (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))
    946 946 
                     2 (vcat [ text "when specialising" <+> quotes (ppr caller)
    947 947 
                             | caller <- callers])

  • compiler/GHC/Driver/Errors.hs
    1 1 
     {-# LANGUAGE ScopedTypeVariables #-}
    2 2 
     module GHC.Driver.Errors (
    3 
    -    printOrThrowDiagnostics
    3 
    +    reportError
    4 
    +  , reportDiagnostic
    4 5 
       , printMessages
    6 
    +  , printOrThrowDiagnostics
    5 7 
       , mkDriverPsHeaderMessage
    6 8 
       ) where
    7 9
    ... ... @@ -14,6 +16,28 @@ import GHC.Utils.Error
    14 16 
     import GHC.Utils.Outputable
    15 17 
     import GHC.Utils.Logger
    16 18
    19 
    +reportError :: Logger -> NamePprCtx -> DiagOpts -> SrcSpan -> SDoc -> IO ()
    20 
    +reportError logger nameContext opts span doc = do
    21 
    +  let
    22 
    +    message :: MsgEnvelope DiagnosticMessage
    23 
    +    message = mkErrorMsgEnvelope span nameContext DiagnosticMessage {
    24 
    +        diagMessage = mkDecorated [doc]
    25 
    +      , diagReason = ErrorWithoutFlag
    26 
    +      , diagHints = []
    27 
    +      }
    28 
    +  printMessage logger NoDiagnosticOpts opts message
    29 
    +
    30 
    +reportDiagnostic :: Logger -> NamePprCtx -> DiagOpts -> SrcSpan -> DiagnosticReason -> SDoc -> IO ()
    31 
    +reportDiagnostic logger nameContext opts span reason doc = do
    32 
    +  let
    33 
    +    message :: MsgEnvelope DiagnosticMessage
    34 
    +    message = mkMsgEnvelope opts span nameContext DiagnosticMessage {
    35 
    +        diagMessage = mkDecorated [doc]
    36 
    +      , diagReason = reason
    37 
    +      , diagHints = []
    38 
    +      }
    39 
    +  printMessage logger NoDiagnosticOpts opts message
    40 
    +
    17 41 
     printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
    18 42 
     printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) . sortMessages
    19 43 
       where

  • compiler/GHC/SysTools/Process.hs
    ... ... @@ -26,6 +26,8 @@ import GHC.Utils.Logger
    26 26 
     import GHC.Utils.TmpFs
    27 27 
     import GHC.Utils.CliOption
    28 28
    29 
    +import GHC.Driver.Errors (reportError)
    30 
    +
    29 31 
     import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan )
    30 32 
     import GHC.Data.FastString
    31 33
    ... ... @@ -286,8 +288,7 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea
    286 288 
             BuildMsg msg -> do
    287 289 
               logInfo logger $ withPprStyle defaultUserStyle msg
    288 290 
             BuildError loc msg -> do
    289 
    -          logMsg logger errorDiagnostic (mkSrcSpan loc loc)
    290 
    -              $ withPprStyle defaultUserStyle msg
    291 
    +          reportError logger neverQualify emptyDiagOpts (mkSrcSpan loc loc) msg
    291 292
    292 293 
     parseBuildMessages :: [String] -> [BuildMessage]
    293 294 
     parseBuildMessages str = loop str Nothing

  • ghc/GHCi/UI.hs
    ... ... @@ -53,7 +53,7 @@ import GHC.Core.DataCon
    53 53 
     import GHC.Core.ConLike
    54 54 
     import GHC.Core.PatSyn
    55 55 
     import GHC.Driver.Flags
    56 
    -import GHC.Driver.Errors
    56 
    +import GHC.Driver.Errors (printOrThrowDiagnostics)
    57 57 
     import GHC.Driver.Errors.Types
    58 58 
     import GHC.Driver.Phases
    59 59 
     import GHC.Driver.Session as DynFlags

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help