Split GHC.Driver.Types

I was working on making DynFlags stateless (#17957), especially by
storing loaded plugins into HscEnv instead of DynFlags. It turned out to
be complicated because HscEnv is in GHC.Driver.Types but LoadedPlugin
isn't: it is in GHC.Driver.Plugins which depends on GHC.Driver.Types. I
didn't feel like introducing yet another hs-boot file to break the loop.

Additionally I remember that while we introduced the module hierarchy
(#13009) we talked about splitting GHC.Driver.Types because it contained
various unrelated types and functions, but we never executed. I didn't
feel like making GHC.Driver.Types bigger with more unrelated Plugins
related types, so finally I bit the bullet and split GHC.Driver.Types.

As a consequence this patch moves a lot of things. I've tried to put
them into appropriate modules but nothing is set in stone.

Several other things moved to avoid loops.

* Removed Binary instances from GHC.Utils.Binary for random compiler
  things
* Moved Typeable Binary instances into GHC.Utils.Binary.Typeable: they
  import a lot of things that users of GHC.Utils.Binary don't want to
  depend on.
* put everything related to Units/Modules under GHC.Unit:
  GHC.Unit.Finder, GHC.Unit.Module.{ModGuts,ModIface,Deps,etc.}
* Created several modules under GHC.Types: GHC.Types.Fixity, SourceText,
  etc.
* Split GHC.Utils.Error (into GHC.Types.Error)
* Finally removed GHC.Driver.Types

Note that this patch doesn't put loaded plugins into HscEnv. It's left
for another patch.

Bump haddock submodule

1 files changed, 51 insertions, 213 deletions

diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index 1bd3e57f56..2db4672f07 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -58,24 +58,27 @@ module GHC.Utils.Error (
         debugTraceMsg,
         ghcExit,
         prettyPrintGhcErrors,
-        traceCmd
+        traceCmd,
+
+        -- * Compilation errors and warnings
+        printOrThrowWarnings, handleFlagWarnings, shouldPrintWarning
     ) where
 
 #include "HsVersions.h"
 
 import GHC.Prelude
 
+import GHC.Driver.Session
+import GHC.Driver.Ppr
+import qualified GHC.Driver.CmdLine as CmdLine
+
 import GHC.Data.Bag
 import GHC.Utils.Exception
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
-import qualified GHC.Utils.Ppr.Colour as Col
+import GHC.Types.SourceError
+import GHC.Types.Error
 import GHC.Types.SrcLoc as SrcLoc
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Data.FastString (unpackFS)
-import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
-import GHC.Utils.Json
 
 import System.Directory
 import System.Exit      ( ExitCode(..), exitWith )
@@ -91,12 +94,9 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Catch as MC (handle)
 import System.IO
-import System.IO.Error  ( catchIOError )
 import GHC.Conc         ( getAllocationCounter )
 import System.CPUTime
 
--------------------------
-type MsgDoc  = SDoc
 
 -------------------------
 data Validity
@@ -126,209 +126,6 @@ orValid _       v = v
 -- -----------------------------------------------------------------------------
 -- Basic error messages: just render a message with a source location.
 
-type Messages        = (WarningMessages, ErrorMessages)
-type WarningMessages = Bag WarnMsg
-type ErrorMessages   = Bag ErrMsg
-
-unionMessages :: Messages -> Messages -> Messages
-unionMessages (warns1, errs1) (warns2, errs2) =
-  (warns1 `unionBags` warns2, errs1 `unionBags` errs2)
-
-data ErrMsg = ErrMsg {
-        errMsgSpan        :: SrcSpan,
-        errMsgContext     :: PrintUnqualified,
-        errMsgDoc         :: ErrDoc,
-        -- | This has the same text as errDocImportant . errMsgDoc.
-        errMsgShortString :: String,
-        errMsgSeverity    :: Severity,
-        errMsgReason      :: WarnReason
-        }
-        -- The SrcSpan is used for sorting errors into line-number order
-
-
--- | Categorise error msgs by their importance.  This is so each section can
--- be rendered visually distinct.  See Note [Error report] for where these come
--- from.
-data ErrDoc = ErrDoc {
-        -- | Primary error msg.
-        errDocImportant     :: [MsgDoc],
-        -- | Context e.g. \"In the second argument of ...\".
-        errDocContext       :: [MsgDoc],
-        -- | Supplementary information, e.g. \"Relevant bindings include ...\".
-        errDocSupplementary :: [MsgDoc]
-        }
-
-errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
-errDoc = ErrDoc
-
-mapErrDoc :: (MsgDoc -> MsgDoc) -> ErrDoc -> ErrDoc
-mapErrDoc f (ErrDoc a b c) = ErrDoc (map f a) (map f b) (map f c)
-
-type WarnMsg = ErrMsg
-
-data Severity
-  = SevOutput
-  | SevFatal
-  | SevInteractive
-
-  | SevDump
-    -- ^ Log message intended for compiler developers
-    -- No file\/line\/column stuff
-
-  | SevInfo
-    -- ^ Log messages intended for end users.
-    -- No file\/line\/column stuff.
-
-  | SevWarning
-  | SevError
-    -- ^ SevWarning and SevError are used for warnings and errors
-    --   o The message has a file\/line\/column heading,
-    --     plus "warning:" or "error:",
-    --     added by mkLocMessags
-    --   o Output is intended for end users
-  deriving Show
-
-
-instance ToJson Severity where
-  json s = JSString (show s)
-
-instance Show ErrMsg where
-    show em = errMsgShortString em
-
-pprMessageBag :: Bag MsgDoc -> SDoc
-pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
-
--- | Make an unannotated error message with location info.
-mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
-mkLocMessage = mkLocMessageAnn Nothing
-
--- | Make a possibly annotated error message with location info.
-mkLocMessageAnn
-  :: Maybe String                       -- ^ optional annotation
-  -> Severity                           -- ^ severity
-  -> SrcSpan                            -- ^ location
-  -> MsgDoc                             -- ^ message
-  -> MsgDoc
-  -- Always print the location, even if it is unhelpful.  Error messages
-  -- are supposed to be in a standard format, and one without a location
-  -- would look strange.  Better to say explicitly "<no location info>".
-mkLocMessageAnn ann severity locn msg
-    = sdocOption sdocColScheme $ \col_scheme ->
-      let locn' = sdocOption sdocErrorSpans $ \case
-                     True  -> ppr locn
-                     False -> ppr (srcSpanStart locn)
-
-          sevColour = getSeverityColour severity col_scheme
-
-          -- Add optional information
-          optAnn = case ann of
-            Nothing -> text ""
-            Just i  -> text " [" <> coloured sevColour (text i) <> text "]"
-
-          -- Add prefixes, like    Foo.hs:34: warning:
-          --                           <the warning message>
-          header = locn' <> colon <+>
-                   coloured sevColour sevText <> optAnn
-
-      in coloured (Col.sMessage col_scheme)
-                  (hang (coloured (Col.sHeader col_scheme) header) 4
-                        msg)
-
-  where
-    sevText =
-      case severity of
-        SevWarning -> text "warning:"
-        SevError   -> text "error:"
-        SevFatal   -> text "fatal:"
-        _          -> empty
-
-getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
-getSeverityColour SevWarning = Col.sWarning
-getSeverityColour SevError   = Col.sError
-getSeverityColour SevFatal   = Col.sFatal
-getSeverityColour _          = const mempty
-
-getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc
-getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
-getCaretDiagnostic severity (RealSrcSpan span _) = do
-  caretDiagnostic <$> getSrcLine (srcSpanFile span) row
-
-  where
-    getSrcLine fn i =
-      getLine i (unpackFS fn)
-        `catchIOError` \_ ->
-          pure Nothing
-
-    getLine i fn = do
-      -- StringBuffer has advantages over readFile:
-      -- (a) no lazy IO, otherwise IO exceptions may occur in pure code
-      -- (b) always UTF-8, rather than some system-dependent encoding
-      --     (Haskell source code must be UTF-8 anyway)
-      content <- hGetStringBuffer fn
-      case atLine i content of
-        Just at_line -> pure $
-          case lines (fix <$> lexemeToString at_line (len at_line)) of
-            srcLine : _ -> Just srcLine
-            _           -> Nothing
-        _ -> pure Nothing
-
-    -- allow user to visibly see that their code is incorrectly encoded
-    -- (StringBuffer.nextChar uses \0 to represent undecodable characters)
-    fix '\0' = '\xfffd'
-    fix c    = c
-
-    row = srcSpanStartLine span
-    rowStr = show row
-    multiline = row /= srcSpanEndLine span
-
-    caretDiagnostic Nothing = empty
-    caretDiagnostic (Just srcLineWithNewline) =
-      sdocOption sdocColScheme$ \col_scheme ->
-      let sevColour = getSeverityColour severity col_scheme
-          marginColour = Col.sMargin col_scheme
-      in
-      coloured marginColour (text marginSpace) <>
-      text ("\n") <>
-      coloured marginColour (text marginRow) <>
-      text (" " ++ srcLinePre) <>
-      coloured sevColour (text srcLineSpan) <>
-      text (srcLinePost ++ "\n") <>
-      coloured marginColour (text marginSpace) <>
-      coloured sevColour (text (" " ++ caretLine))
-
-      where
-
-        -- expand tabs in a device-independent manner #13664
-        expandTabs tabWidth i s =
-          case s of
-            ""        -> ""
-            '\t' : cs -> replicate effectiveWidth ' ' ++
-                         expandTabs tabWidth (i + effectiveWidth) cs
-            c    : cs -> c : expandTabs tabWidth (i + 1) cs
-          where effectiveWidth = tabWidth - i `mod` tabWidth
-
-        srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline)
-
-        start = srcSpanStartCol span - 1
-        end | multiline = length srcLine
-            | otherwise = srcSpanEndCol span - 1
-        width = max 1 (end - start)
-
-        marginWidth = length rowStr
-        marginSpace = replicate marginWidth ' ' ++ " |"
-        marginRow   = rowStr ++ " |"
-
-        (srcLinePre,  srcLineRest) = splitAt start srcLine
-        (srcLineSpan, srcLinePost) = splitAt width srcLineRest
-
-        caretEllipsis | multiline = "..."
-                      | otherwise = ""
-        caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis
-
-makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg
-makeIntoWarning reason err = err
-    { errMsgSeverity = SevWarning
-    , errMsgReason = reason }
 
 -- -----------------------------------------------------------------------------
 -- Collecting up messages for later ordering and printing.
@@ -993,3 +790,44 @@ dumpAction dflags = dump_action dflags dflags
 -- | Helper for `trace_action`
 traceAction :: TraceAction
 traceAction dflags = trace_action dflags dflags
+
+handleFlagWarnings :: DynFlags -> [CmdLine.Warn] -> IO ()
+handleFlagWarnings dflags warns = do
+  let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason)  warns
+
+      -- It would be nicer if warns :: [Located MsgDoc], but that
+      -- has circular import problems.
+      bag = listToBag [ mkPlainWarnMsg dflags loc (text warn)
+                      | CmdLine.Warn _ (L loc warn) <- warns' ]
+
+  printOrThrowWarnings dflags bag
+
+-- Given a warn reason, check to see if it's associated -W opt is enabled
+shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool
+shouldPrintWarning dflags CmdLine.ReasonDeprecatedFlag
+  = wopt Opt_WarnDeprecatedFlags dflags
+shouldPrintWarning dflags CmdLine.ReasonUnrecognisedFlag
+  = wopt Opt_WarnUnrecognisedWarningFlags dflags
+shouldPrintWarning _ _
+  = True
+
+
+-- | Given a bag of warnings, turn them into an exception if
+-- -Werror is enabled, or print them out otherwise.
+printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()
+printOrThrowWarnings dflags warns = do
+  let (make_error, warns') =
+        mapAccumBagL
+          (\make_err warn ->
+            case isWarnMsgFatal dflags warn of
+              Nothing ->
+                (make_err, warn)
+              Just err_reason ->
+                (True, warn{ errMsgSeverity = SevError
+                           , errMsgReason = ErrReason err_reason
+                           }))
+          False warns
+  if make_error
+    then throwIO (mkSrcErr warns')
+    else printBagOfErrors dflags warns
+