Add GhcMessage and ancillary types

This commit adds GhcMessage and ancillary (PsMessage, TcRnMessage, ..)
types.
These types will be expanded to represent more errors generated
by different subsystems within GHC. Right now, they are underused,
but more will come in the glorious future.

See
https://gitlab.haskell.org/ghc/ghc/-/wikis/Errors-as-(structured)-values
for a design overview.

Along the way, lots of other things had to happen:

* Adds Semigroup and Monoid instance for Bag

* Fixes #19746 by parsing OPTIONS_GHC pragmas into Located Strings.
  See GHC.Parser.Header.toArgs (moved from GHC.Utils.Misc, where it
  didn't belong anyway).

* Addresses (but does not completely fix) #19709, now reporting
  desugarer warnings and errors appropriately for TH splices.
  Not done: reporting type-checker warnings for TH splices.

* Some small refactoring around Safe Haskell inference, in order
  to keep separate classes of messages separate.

* Some small refactoring around initDsTc, in order to keep separate
  classes of messages separate.

* Separate out the generation of messages (that is, the construction
  of the text block) from the wrapping of messages (that is, assigning
  a SrcSpan). This is more modular than the previous design, which
  mixed the two.

Close #19746.

This was a collaborative effort by Alfredo di Napoli and
Richard Eisenberg, with a key assist on #19746 by Iavor
Diatchki.

Metric Increase:
    MultiLayerModules

1 files changed, 34 insertions, 6 deletions

diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index c53f6771b5..4f126b92b3 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -77,6 +77,7 @@ import GHC.Builtin.Types( stringTyCon_RDR )
 import GHC.Types.Name.Reader as RdrName ( getGRE_NameQualifier_maybes, getRdrName )
 import GHC.Types.SrcLoc as SrcLoc
 import qualified GHC.Parser.Lexer as Lexer
+import GHC.Parser.Header ( toArgs )
 
 import GHC.Unit
 import GHC.Unit.State
@@ -293,7 +294,7 @@ keepGoing' a str = a str >> return False
 
 keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
 keepGoingPaths a str
- = do case toArgs str of
+ = do case toArgsNoLoc str of
           Left err -> liftIO $ hPutStrLn stderr err
           Right args -> a args
       return False
@@ -1562,7 +1563,7 @@ pprInfo (thing, fixity, cls_insts, fam_insts, docs)
 -- :main
 
 runMain :: GhciMonad m => String -> m ()
-runMain s = case toArgs s of
+runMain s = case toArgsNoLoc s of
             Left err   -> liftIO (hPutStrLn stderr err)
             Right args ->
                 do dflags <- getDynFlags
@@ -1583,6 +1584,33 @@ doWithArgs :: GhciMonad m => [String] -> String -> m ()
 doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
                                        show args ++ " (" ++ cmd ++ ")"]
 
+{-
+Akin to @Prelude.words@, but acts like the Bourne shell, treating
+quoted strings as Haskell Strings, and also parses Haskell [String]
+syntax.
+-}
+
+getCmd :: String -> Either String             -- Error
+                           (String, String) -- (Cmd, Rest)
+getCmd s = case break isSpace $ dropWhile isSpace s of
+           ([], _) -> Left ("Couldn't find command in " ++ show s)
+           res -> Right res
+
+toCmdArgs :: String -> Either String             -- Error
+                              (String, [String]) -- (Cmd, Args)
+toCmdArgs s = case getCmd s of
+              Left err -> Left err
+              Right (cmd, s') -> case toArgsNoLoc s' of
+                                 Left err -> Left err
+                                 Right args -> Right (cmd, args)
+
+-- wrapper around GHC.Parser.Header.toArgs, but without locations
+toArgsNoLoc :: String -> Either String [String]
+toArgsNoLoc str = map unLoc <$> toArgs fake_loc str
+  where
+    fake_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
+    -- this should never be seen, because it's discarded with the `map unLoc`
+
 -----------------------------------------------------------------------------
 -- :cd
 
@@ -2854,11 +2882,11 @@ setCmd "-a" = showOptions True
 setCmd str
   = case getCmd str of
     Right ("args",    rest) ->
-        case toArgs rest of
+        case toArgsNoLoc rest of
             Left err -> liftIO (hPutStrLn stderr err)
             Right args -> setArgs args
     Right ("prog",    rest) ->
-        case toArgs rest of
+        case toArgsNoLoc rest of
             Right [prog] -> setProg prog
             _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
 
@@ -2877,7 +2905,7 @@ setCmd str
     Right ("stop",    rest) -> setStop    $ dropWhile isSpace rest
     Right ("local-config", rest) ->
         setLocalConfigBehaviour $ dropWhile isSpace rest
-    _ -> case toArgs str of
+    _ -> case toArgsNoLoc str of
          Left err -> liftIO (hPutStrLn stderr err)
          Right wds -> setOptions wds
 
@@ -2885,7 +2913,7 @@ setiCmd :: GhciMonad m => String -> m ()
 setiCmd ""   = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False
 setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True
 setiCmd str  =
-  case toArgs str of
+  case toArgsNoLoc str of
     Left err -> liftIO (hPutStrLn stderr err)
     Right wds -> newDynFlags True wds