[project @ 1996-03-19 08:58:34 by partain]

[ghc-hetmet.git] / ghc / compiler / main / ErrUtils.lhs

diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs
index 5146016..d455ff0 100644 (file)
--- a/ghc/compiler/main/ErrUtils.lhs
+++ b/ghc/compiler/main/ErrUtils.lhs
@@ -3,25 +3,30 @@
 %
 \section[ErrsUtils]{Utilities for error reporting}
 
-This is an internal module---access to these functions is through
-@Errors@.
-
-DPH errors are in here, too.
-
 \begin{code}
 #include "HsVersions.h"
 
-module ErrUtils where
+module ErrUtils (
+
+       Error(..),
+       addErrLoc, addShortErrLocLine,
+       dontAddErrLoc, pprBagOfErrors,
+
+       TcError(..), TcWarning(..), Message(..),
+       mkTcErr, arityErr
 
-import Bag             ( Bag, bagToList )
-import Outputable
-import Pretty          -- to pretty-print error messages
-import SrcLoc          ( mkUnknownSrcLoc, SrcLoc )
-import Util
+    ) where
+
+import Ubiq{-uitous-}
+
+import Bag             ( bagToList )
+import PprStyle                ( PprStyle(..) )
+import Pretty
+import SrcLoc          ( mkUnknownSrcLoc, SrcLoc{-instance-} )
 \end{code}
 
 \begin{code}
-type Error = PprStyle -> Pretty
+type Error   = PprStyle -> Pretty
 
 addErrLoc :: SrcLoc -> String -> Error -> Error
 addErrLoc locn title rest_of_err_msg sty
@@ -44,18 +49,35 @@ pprBagOfErrors :: PprStyle -> Bag Error -> Pretty
 pprBagOfErrors sty bag_of_errors
   = let  pretties = map ( \ e -> e sty ) (bagToList bag_of_errors)  in
     ppAboves (map (\ p -> ppAbove ppSP p) pretties)
+\end{code}
+
+TypeChecking Errors
+~~~~~~~~~~~~~~~~~~~
+
+\begin{code}
+type Message   = PprStyle -> Pretty
+type TcError   = Message
+type TcWarning = Message
+
+
+mkTcErr :: SrcLoc              -- Where
+       -> [Message]            -- Context
+       -> Message              -- What went wrong
+       -> TcError              -- The complete error report
+
+mkTcErr locn ctxt msg sty
+  = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
+        4 (ppAboves [msg sty | msg <- ctxt])
+
 
-#ifdef DPH
-addWarningLoc :: SrcLoc -> Error -> Error
-addWarningLoc locn rest_of_err_msg sty
-  = ppHang (ppBesides [ppStr "*** Warning *** ",
-                      ppr PprForUser locn,ppStr ": "])
-        4 (ppAbove (rest_of_err_msg sty)
-                   (ppSP))
-
-addWarning :: Error -> Error
-addWarning rest_of_err_msg sty
-  = ppBeside (ppStr "*** Warning *** : ")
-            (rest_of_err_msg sty)
-#endif {- Data Parallel Haskell -}
+arityErr kind name n m sty =
+    ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
+               n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
+    where
+       errmsg = kind ++ " has too " ++ quantity ++ " arguments"
+       quantity | m < n     = "few"
+                | otherwise = "many"
+       n_arguments | n == 0 = ppStr "no arguments"
+                   | n == 1 = ppStr "1 argument"
+                   | True   = ppCat [ppInt n, ppStr "arguments"]
 \end{code}