X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMonad.lhs;h=c2034d75e5cc046f88eb8dd3b58784fcecb16a1c;hb=2494407a750053daa61718fac371487d04818e57;hp=2900230d523bdee7fe34fd3f913add8b189f16dd;hpb=c49d51f812da9b1c2ceca7e0dad8f2a3626041a9;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 2900230..c2034d7 100644 --- 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}