[project @ 1997-12-02 18:50:36 by quintela]

Deleted old Warning staff and added new ones

diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index 3428be6..7ed81cf 100644 (file)
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -19,10 +19,9 @@ module DsMonad (
        extendEnvDs, lookupEnvDs, 
        SYN_IE(DsIdEnv),
 
-       dsShadowWarn, dsIncompleteWarn,
+       dsWarn, 
        SYN_IE(DsWarnings),
-       DsMatchContext(..), DsMatchKind(..), pprDsWarnings,
-        DsWarnFlavour -- Nuke with 1.4
+       DsMatchContext(..), DsMatchKind(..), pprDsWarnings
 
     ) where
 
@@ -33,6 +32,7 @@ import BasicTypes       ( SYN_IE(Module) )
 import CmdLineOpts     ( opt_PprUserLength )
 import CoreSyn         ( SYN_IE(CoreExpr) )
 import CoreUtils       ( substCoreExpr )
+import ErrUtils        ( SYN_IE(Warning) )
 import HsSyn           ( OutPat )
 import Id              ( mkSysLocal, mkIdWithNewUniq,
                          lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv),
@@ -66,8 +66,7 @@ type DsM result =
        -> DsWarnings
        -> (result, DsWarnings)
 
-type DsWarnings = Bag (DsWarnFlavour, DsMatchContext)
-                                       -- The desugarer reports matches which are
+type DsWarnings = Bag Warning           -- The desugarer reports matches which are
                                        -- completely shadowed or incomplete patterns
 
 type Group = FAST_STRING
@@ -186,13 +185,9 @@ putSrcLocDs :: SrcLoc -> DsM a -> DsM a
 putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
   = expr us new_loc mod_and_grp env warns
 
-dsShadowWarn :: DsMatchContext -> DsM ()
-dsShadowWarn cxt us loc mod_and_grp env warns
-  = ((), warns `snocBag` (Shadowed, cxt))
+dsWarn :: Warning -> DsM ()
+dsWarn warn us loc mod_and_grp env warns = ((), warns `snocBag` warn)
 
-dsIncompleteWarn :: DsMatchContext -> DsM ()
-dsIncompleteWarn cxt us loc mod_and_grp env warns
-  = ((), warns `snocBag` (Incomplete, cxt))
 \end{code}
 
 \begin{code}
@@ -224,8 +219,6 @@ lookupEnvDs id us loc mod_and_grp env warns
 %************************************************************************
 
 \begin{code}
-data DsWarnFlavour = Shadowed | Incomplete deriving ()
-
 data DsMatchContext
   = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
   | NoMatchContext
@@ -237,45 +230,11 @@ data DsMatchKind
   | LambdaMatch
   | PatBindMatch
   | DoBindMatch
+  | ListCompMatch
+  | LetMatch
   deriving ()
 
 pprDsWarnings :: PprStyle -> DsWarnings -> Doc
-pprDsWarnings sty warns
-  = vcat (map pp_warn (bagToList warns))
-  where
-    pp_warn (flavour, NoMatchContext) = sep [ptext SLIT("Warning: Some match is"), 
-                                              case flavour of
-                                                       Shadowed   -> ptext SLIT("shadowed")
-                                                       Incomplete -> ptext SLIT("possibly incomplete")]
-
-    pp_warn (flavour, DsMatchContext kind pats loc)
-       = hang (hcat [ppr (PprForUser opt_PprUserLength) loc, ptext SLIT(": ")])
-            4 (hang msg
-                    4 (pp_match kind pats))
-       where
-       msg = case flavour of
-               Shadowed   -> ptext SLIT("Warning: Pattern match(es) completely overlapped")     
-               Incomplete -> ptext SLIT("Warning: Possibly incomplete patterns")
-
-    pp_match (FunMatch fun) pats
-      = hsep [ptext SLIT("in the definition of function"), ppr sty fun]
-
-    pp_match CaseMatch pats
-      = hang (ptext SLIT("in a group of case alternatives beginning:"))
-       4 (ppr_pats pats)
-
-    pp_match PatBindMatch pats
-      = hang (ptext SLIT("in a pattern binding:"))
-       4 (ppr_pats pats)
-
-    pp_match LambdaMatch pats
-      = hang (ptext SLIT("in a lambda abstraction:"))
-       4 (ppr_pats pats)
-
-    pp_match DoBindMatch pats
-      = hang (ptext SLIT("in a `do' pattern binding:"))
-       4 (ppr_pats pats)
-
-    ppr_pats pats = pprQuote sty $ \ sty ->
-                   sep [sep (map (ppr sty) pats), ptext SLIT("-> ...")]
+pprDsWarnings sty warns = vcat [ warn sty | warn <- (bagToList warns)]
+
 \end{code}