From fff59517a8acd401770bdc7f7c872cee796c7e38 Mon Sep 17 00:00:00 2001
From: quintela <unknown>
Date: Tue, 2 Dec 1997 18:50:36 +0000
Subject: [PATCH] [project @ 1997-12-02 18:50:36 by quintela] Deleted old
Warning staff and added new ones
---
ghc/compiler/deSugar/DsMonad.lhs | 61 ++++++--------------------------
1 file changed, 10 insertions(+), 51 deletions(-)
diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index 3428be644653..7ed81cfe2bce 100644
--- 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}
--
GitLab