X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FErrUtils.lhs;h=486cb6ed072f3137f1bef3c7e277baf01420d6a2;hb=5295316c16a2abfa56796fad93017a45c5f3adf8;hp=e50ded59a7c0d126b172387a56a99374f41a10bb;hpb=a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs
index e50ded5..486cb6e 100644
--- a/ghc/compiler/main/ErrUtils.lhs
+++ b/ghc/compiler/main/ErrUtils.lhs
@@ -7,48 +7,56 @@
 #include "HsVersions.h"
 
 module ErrUtils (
-	Error(..), Warning(..), Message(..),
+	SYN_IE(Error), SYN_IE(Warning), SYN_IE(Message),
 	addErrLoc,
-	addShortErrLocLine,
+	addShortErrLocLine, addShortWarnLocLine,
 	dontAddErrLoc,
 	pprBagOfErrors,
-	ghcExit
+	ghcExit,
+	doIfSet, dumpIfSet
     ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
-import Bag		( bagToList )
-import PprStyle		( PprStyle(..) )
+import CmdLineOpts      ( opt_PprUserLength )
+import Bag		--( bagToList )
+import Outputable	( PprStyle(..), Outputable(..), printErrs )
 import Pretty
-import SrcLoc		( mkUnknownSrcLoc, SrcLoc{-instance-} )
+import SrcLoc		( noSrcLoc, SrcLoc{-instance-} )
 \end{code}
 
 \begin{code}
-type Error   = PprStyle -> Pretty
-type Warning = PprStyle -> Pretty
-type Message = PprStyle -> Pretty
+type Error   = PprStyle -> Doc
+type Warning = PprStyle -> Doc
+type Message = PprStyle -> Doc
 
 addErrLoc :: SrcLoc -> String -> Error -> Error
 addErrLoc locn title rest_of_err_msg sty
-  = ppHang (ppBesides [ppr PprForUser locn,
-		       if null title then ppNil else ppStr (": " ++ title),
-		       ppChar ':'])
+  = hang (hcat [ppr (PprForUser opt_PprUserLength) locn,
+		if null title then empty else text (": " ++ title),
+		char ':'])
     	 4 (rest_of_err_msg sty)
 
-addShortErrLocLine :: SrcLoc -> Error -> Error
+addShortErrLocLine, addShortWarnLocLine :: SrcLoc -> Error -> Error
+
 addShortErrLocLine locn rest_of_err_msg sty
-  = ppHang (ppBeside (ppr PprForUser locn) (ppChar ':'))
+  = hang ((<>) (ppr (PprForUser opt_PprUserLength) locn) (char ':'))
+	 4 (rest_of_err_msg sty)
+
+addShortWarnLocLine locn rest_of_err_msg sty
+  = hang ((<>) (ppr (PprForUser opt_PprUserLength) locn) (ptext SLIT(":warning:")))
 	 4 (rest_of_err_msg sty)
 
 dontAddErrLoc :: String -> Error -> Error
 dontAddErrLoc title rest_of_err_msg sty
-  = ppHang (ppBesides [ppStr title, ppChar ':'])
+  = hang (hcat [text title, char ':'])
     	 4 (rest_of_err_msg sty)
 
-pprBagOfErrors :: PprStyle -> Bag Error -> Pretty
+pprBagOfErrors :: PprStyle -> Bag Error -> Doc
 pprBagOfErrors sty bag_of_errors
-  = let  pretties = map ( \ e -> e sty ) (bagToList bag_of_errors)  in
-    ppAboves (map (\ p -> ppAbove ppSP p) pretties)
+  = let  pretties = map ( \ e -> e sty ) (bagToList bag_of_errors)
+    in
+    vcat (map (\ p -> ($$) space p) pretties)
 \end{code}
 
 \begin{code}
@@ -59,3 +67,23 @@ ghcExit val
     then error "Compilation had errors\n"
     else return ()
 \end{code}
+
+\begin{code}
+doIfSet :: Bool -> IO () -> IO ()
+doIfSet flag action | flag      = action
+		    | otherwise = return ()
+\end{code}
+
+\begin{code}
+dumpIfSet :: Bool -> String -> Doc -> IO ()
+dumpIfSet flag hdr doc
+  | not flag  = return ()
+  | otherwise = printErrs dump
+  where
+    dump = (line <+> text hdr <+> line)
+	   $$
+	   doc
+	   $$
+	   text ""
+    line = text (take 20 (repeat '='))
+\end{code}