[project @ 1997-03-17 20:34:25 by simonpj]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsMonad.lhs

diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs
index 2900230..c2034d7 100644 (file)
--- a/ghc/compiler/deSugar/DsMonad.lhs
+++ b/ghc/compiler/deSugar/DsMonad.lhs
@@ -7,7 +7,7 @@
 #include "HsVersions.h"
 
 module DsMonad (
-       DsM(..),
+       SYN_IE(DsM),
        initDs, returnDs, thenDs, andDs, mapDs, listDs,
        mapAndUnzipDs, zipWithDs,
        uniqSMtoDsM,
@@ -17,32 +17,35 @@ module DsMonad (
        getSrcLocDs, putSrcLocDs,
        getModuleAndGroupDs,
        extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs,
-       DsIdEnv(..),
+       SYN_IE(DsIdEnv),
        lookupId,
 
-       dsShadowError,
-       DsMatchContext(..), DsMatchKind(..), pprDsWarnings
+       dsShadowWarn, dsIncompleteWarn,
+       DsWarnings(..),
+       DsMatchContext(..), DsMatchKind(..), pprDsWarnings,
+        DsWarnFlavour -- Nuke with 1.4
+
     ) where
 
-import Ubiq
+IMP_Ubiq()
 
 import Bag             ( emptyBag, snocBag, bagToList )
 import CmdLineOpts     ( opt_SccGroup )
-import CoreSyn         ( CoreExpr(..) )
+import CoreSyn         ( SYN_IE(CoreExpr) )
 import CoreUtils       ( substCoreExpr )
 import HsSyn           ( OutPat )
 import Id              ( mkSysLocal, mkIdWithNewUniq,
-                         lookupIdEnv, growIdEnvList, GenId, IdEnv(..)
+                         lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv)
                        )
 import PprType         ( GenType, GenTyVar )
 import PprStyle                ( PprStyle(..) )
 import Pretty
-import SrcLoc          ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc )
-import TcHsSyn         ( TypecheckedPat(..) )
+import SrcLoc          ( noSrcLoc, SrcLoc )
+import TcHsSyn         ( SYN_IE(TypecheckedPat) )
 import TyVar           ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
 import Unique          ( Unique{-instances-} )
 import UniqSupply      ( splitUniqSupply, getUnique, getUniques,
-                         mapUs, thenUs, returnUs, UniqSM(..) )
+                         mapUs, thenUs, returnUs, SYN_IE(UniqSM) )
 import Util            ( assoc, mapAccumL, zipWithEqual, panic )
 
 infixr 9 `thenDs`
@@ -60,8 +63,9 @@ type DsM result =
        -> DsWarnings
        -> (result, DsWarnings)
 
-type DsWarnings = Bag DsMatchContext   -- The desugarer reports matches which are
-                                       -- completely shadowed
+type DsWarnings = Bag (DsWarnFlavour, DsMatchContext)
+                                       -- The desugarer reports matches which are
+                                       -- completely shadowed or incomplete patterns
 {-# INLINE andDs #-}
 {-# INLINE thenDs #-}
 {-# INLINE returnDs #-}
@@ -75,7 +79,7 @@ initDs  :: UniqSupply
        -> (a, DsWarnings)
 
 initDs init_us env mod_name action
-  = action init_us mkUnknownSrcLoc module_and_group env emptyBag
+  = action init_us noSrcLoc module_and_group env emptyBag
   where
     module_and_group = (mod_name, grp_name)
     grp_name  = case opt_SccGroup of
@@ -154,7 +158,7 @@ duplicateLocalDs old_local us loc mod_and_grp env warns
 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 cloneTyVarsDs tyvars us loc mod_and_grp env warns
   = case (getUniques (length tyvars) us) of { uniqs ->
-    (zipWithEqual cloneTyVar tyvars uniqs, warns) }
+    (zipWithEqual "cloneTyVarsDs" cloneTyVar tyvars uniqs, warns) }
 \end{code}
 
 \begin{code}
@@ -162,7 +166,7 @@ newTyVarsDs :: [TyVar] -> DsM [TyVar]
 
 newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
   = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
-    (zipWithEqual cloneTyVar tyvar_tmpls uniqs, warns) }
+    (zipWithEqual "newTyVarsDs" cloneTyVar tyvar_tmpls uniqs, warns) }
 \end{code}
 
 We can also reach out and either set/grab location information from
@@ -173,18 +177,21 @@ uniqSMtoDsM :: UniqSM a -> DsM a
 uniqSMtoDsM u_action us loc mod_and_grp env warns
   = (u_action us, warns)
 
-getSrcLocDs :: DsM (String, String)
+getSrcLocDs :: DsM SrcLoc
 getSrcLocDs us loc mod_and_grp env warns
-  = case (unpackSrcLoc loc) of { (x,y) ->
-    ((_UNPK_ x, _UNPK_ y), warns) }
+  = (loc, warns)
 
 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
 
-dsShadowError :: DsMatchContext -> DsM ()
-dsShadowError cxt us loc mod_and_grp env warns
-  = ((), warns `snocBag` cxt)
+dsShadowWarn :: DsMatchContext -> DsM ()
+dsShadowWarn cxt us loc mod_and_grp env warns
+  = ((), warns `snocBag` (Shadowed, cxt))
+
+dsIncompleteWarn :: DsMatchContext -> DsM ()
+dsIncompleteWarn cxt us loc mod_and_grp env warns
+  = ((), warns `snocBag` (Incomplete, cxt))
 \end{code}
 
 \begin{code}
@@ -238,32 +245,44 @@ lookupId env id
 %************************************************************************
 
 \begin{code}
+data DsWarnFlavour = Shadowed | Incomplete deriving ()
+
 data DsMatchContext
   = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
   | NoMatchContext
+  deriving ()
 
 data DsMatchKind
   = FunMatch Id
   | CaseMatch
   | LambdaMatch
   | PatBindMatch
+  | DoBindMatch
+  deriving ()
 
-pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty
+pprDsWarnings :: PprStyle -> DsWarnings -> Pretty
 pprDsWarnings sty warns
-  = ppAboves (map pp_cxt (bagToList warns))
+  = ppAboves (map pp_warn (bagToList warns))
   where
-    pp_cxt NoMatchContext = ppPStr SLIT("Some match is shadowed; I don't know what")
-    pp_cxt (DsMatchContext kind pats loc)
-      = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")])
-            4 (ppHang (ppPStr SLIT("Pattern match(es) completely overlapped:"))
+    pp_warn (flavour, NoMatchContext) = ppSep [ppPStr SLIT("Warning: Some match is"), 
+                                              case flavour of
+                                                       Shadowed   -> ppPStr SLIT("shadowed")
+                                                       Incomplete -> ppPStr SLIT("possibly incomplete")]
+
+    pp_warn (flavour, DsMatchContext kind pats loc)
+       = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")])
+            4 (ppHang msg
                     4 (pp_match kind pats))
+       where
+       msg = case flavour of
+               Shadowed   -> ppPStr SLIT("Warning: Pattern match(es) completely overlapped")     
+               Incomplete -> ppPStr SLIT("Warning: Possibly incomplete patterns")
 
     pp_match (FunMatch fun) pats
-      = ppHang (ppr sty fun)
-       4 (ppSep [ppSep (map (ppr sty) pats), ppPStr SLIT("= ...")])
+      = ppCat [ppPStr SLIT("in the definition of function"), ppQuote (ppr sty fun)]
 
     pp_match CaseMatch pats
-      = ppHang (ppPStr SLIT("in a case alternative:"))
+      = ppHang (ppPStr SLIT("in a group of case alternatives beginning:"))
        4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
 
     pp_match PatBindMatch pats
@@ -274,5 +293,9 @@ pprDsWarnings sty warns
       = ppHang (ppPStr SLIT("in a lambda abstraction:"))
        4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
 
+    pp_match DoBindMatch pats
+      = ppHang (ppPStr SLIT("in a `do' pattern binding:"))
+       4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
+
     pp_arrow_dotdotdot = ppPStr SLIT("-> ...")
 \end{code}