never executed always true always false

    1 module GHC.Driver.Errors (
    2     printOrThrowDiagnostics
    3   , printMessages
    4   , handleFlagWarnings
    5   , mkDriverPsHeaderMessage
    6   ) where
    7 
    8 import GHC.Driver.Errors.Types
    9 import GHC.Data.Bag
   10 import GHC.Prelude
   11 import GHC.Types.SrcLoc
   12 import GHC.Types.SourceError
   13 import GHC.Types.Error
   14 import GHC.Utils.Error
   15 import GHC.Utils.Outputable (hang, ppr, ($$), SDocContext,  text, withPprStyle, mkErrStyle, sdocStyle )
   16 import GHC.Utils.Logger
   17 import qualified GHC.Driver.CmdLine as CmdLine
   18 
   19 printMessages :: Diagnostic a => Logger -> DiagOpts -> Messages a -> IO ()
   20 printMessages logger opts msgs
   21   = sequence_ [ let style = mkErrStyle unqual
   22                     ctx   = (diag_ppr_ctx opts) { sdocStyle = style }
   23                 in logMsg logger (MCDiagnostic sev . diagnosticReason $ dia) s $
   24                    withPprStyle style (messageWithHints ctx dia)
   25               | MsgEnvelope { errMsgSpan      = s,
   26                               errMsgDiagnostic = dia,
   27                               errMsgSeverity = sev,
   28                               errMsgContext   = unqual } <- sortMsgBag (Just opts)
   29                                                                        (getMessages msgs) ]
   30   where
   31     messageWithHints :: Diagnostic a => SDocContext -> a -> SDoc
   32     messageWithHints ctx e =
   33       let main_msg = formatBulleted ctx $ diagnosticMessage e
   34           in case diagnosticHints e of
   35                []  -> main_msg
   36                [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h)
   37                hs  -> main_msg $$ hang (text "Suggested fixes:") 2
   38                                        (formatBulleted ctx . mkDecorated . map ppr $ hs)
   39 
   40 handleFlagWarnings :: Logger -> DiagOpts -> [CmdLine.Warn] -> IO ()
   41 handleFlagWarnings logger opts warns = do
   42   let -- It would be nicer if warns :: [Located SDoc], but that
   43       -- has circular import problems.
   44       bag = listToBag [ mkPlainMsgEnvelope opts loc $
   45                         GhcDriverMessage $
   46                         DriverUnknownMessage $
   47                         mkPlainDiagnostic reason noHints $ text warn
   48                       | CmdLine.Warn reason (L loc warn) <- warns ]
   49 
   50   printOrThrowDiagnostics logger opts (mkMessages bag)
   51 
   52 -- | Given a bag of diagnostics, turn them into an exception if
   53 -- any has 'SevError', or print them out otherwise.
   54 printOrThrowDiagnostics :: Logger -> DiagOpts -> Messages GhcMessage -> IO ()
   55 printOrThrowDiagnostics logger opts msgs
   56   | errorsOrFatalWarningsFound msgs
   57   = throwErrors msgs
   58   | otherwise
   59   = printMessages logger opts msgs
   60 
   61 -- | Convert a 'PsError' into a wrapped 'DriverMessage'; use it
   62 -- for dealing with parse errors when the driver is doing dependency analysis.
   63 -- Defined here to avoid module loops between GHC.Driver.Error.Types and
   64 -- GHC.Driver.Error.Ppr
   65 mkDriverPsHeaderMessage :: MsgEnvelope PsMessage -> MsgEnvelope DriverMessage
   66 mkDriverPsHeaderMessage = fmap DriverPsHeaderMessage