Update Trac ticket URLs to point to GitLab
[ghc.git] / compiler / main / ErrUtils.hs
index c7fb8ba..4f19437 100644 (file)
@@ -22,6 +22,7 @@ module ErrUtils (
         errMsgSpan, errMsgContext,
         errorsFound, isEmptyMessages,
         isWarnMsgFatal,
+        warningsToMessages,
 
         -- ** Formatting
         pprMessageBag, pprErrMsgBagWithLoc,
@@ -40,7 +41,8 @@ module ErrUtils (
 
         -- * Dump files
         dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,
-        mkDumpDoc, dumpSDoc,
+        mkDumpDoc, dumpSDoc, dumpSDocForUser,
+        dumpSDocWithStyle,
 
         -- * Issuing messages during compilation
         putMsg, printInfoForUser, printOutputForUser,
@@ -358,6 +360,15 @@ isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs
 errorsFound :: DynFlags -> Messages -> Bool
 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
 
+warningsToMessages :: DynFlags -> WarningMessages -> Messages
+warningsToMessages dflags =
+  partitionBagWith $ \warn ->
+    case isWarnMsgFatal dflags warn of
+      Nothing -> Left warn
+      Just err_reason ->
+        Right warn{ errMsgSeverity = SevError
+                  , errMsgReason = ErrReason err_reason }
+
 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
 printBagOfErrors dflags bag_of_errors
   = sequence_ [ let style = mkErrStyle dflags unqual
@@ -474,12 +485,26 @@ withDumpFileHandle dflags flag action = do
             -- We do not want the dump file to be affected by
             -- environment variables, but instead to always use
             -- UTF8. See:
-            -- https://ghc.haskell.org/trac/ghc/ticket/10762
+            -- https://gitlab.haskell.org/ghc/ghc/issues/10762
             hSetEncoding handle utf8
 
             action (Just handle)
       Nothing -> action Nothing
 
+
+dumpSDoc, dumpSDocForUser
+  :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
+
+-- | A wrapper around 'dumpSDocWithStyle' which uses 'PprDump' style.
+dumpSDoc dflags print_unqual
+  = dumpSDocWithStyle dump_style dflags
+  where dump_style = mkDumpStyle dflags print_unqual
+
+-- | A wrapper around 'dumpSDocWithStyle' which uses 'PprUser' style.
+dumpSDocForUser dflags print_unqual
+  = dumpSDocWithStyle user_style dflags
+  where user_style = mkUserStyle dflags print_unqual AllTheWay
+
 -- | Write out a dump.
 -- If --dump-to-file is set then this goes to a file.
 -- otherwise emit to stdout.
@@ -489,12 +514,10 @@ withDumpFileHandle dflags flag action = do
 --
 -- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@
 -- is used; it is not used to decide whether to dump the output
-dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
-dumpSDoc dflags print_unqual flag hdr doc =
+dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()
+dumpSDocWithStyle sty dflags flag hdr doc =
     withDumpFileHandle dflags flag writeDump
   where
-    dump_style = mkDumpStyle dflags print_unqual
-
     -- write dump to file
     writeDump (Just handle) = do
         doc' <- if null hdr
@@ -507,14 +530,14 @@ dumpSDoc dflags print_unqual flag hdr doc =
                                 $$ blankLine
                                 $$ doc
                         return $ mkDumpDoc hdr d
-        defaultLogActionHPrintDoc dflags handle doc' dump_style
+        defaultLogActionHPrintDoc dflags handle doc' sty
 
     -- write the dump to stdout
     writeDump Nothing = do
         let (doc', severity)
               | null hdr  = (doc, SevOutput)
               | otherwise = (mkDumpDoc hdr doc, SevDump)
-        putLogMsg dflags NoReason severity noSrcSpan dump_style doc'
+        putLogMsg dflags NoReason severity noSrcSpan sty doc'
 
 
 -- | Choose where to put a dump file based on DynFlags