X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMonad.lhs;h=a29cc5a4345f8a573c5bfa164cc35f5f7300382a;hb=dcef38bab91d45b56f7cf3ceeec96303d93728bb;hp=636ebf43eb18d85d29bad9c174aa439c8ee15d94;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 636ebf4..a29cc5a 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, @@ -16,39 +16,42 @@ module DsMonad ( newFailLocalDs, getSrcLocDs, putSrcLocDs, getModuleAndGroupDs, - extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs, - DsIdEnv(..), - lookupId, + extendEnvDs, lookupEnvDs, + SYN_IE(DsIdEnv), + + dsShadowWarn, dsIncompleteWarn, + SYN_IE(DsWarnings), + DsMatchContext(..), DsMatchKind(..), pprDsWarnings, + DsWarnFlavour -- Nuke with 1.4 - dsShadowError, - DsMatchContext(..), DsMatchKind(..), pprDsWarnings ) where -import Ubiq +IMP_Ubiq() -import Bag ( emptyBag, snocBag, bagToList ) +import Bag ( emptyBag, snocBag, bagToList, Bag ) import CmdLineOpts ( opt_SccGroup ) -import CoreSyn ( CoreExpr(..) ) +import CoreSyn ( SYN_IE(CoreExpr) ) import CoreUtils ( substCoreExpr ) import HsSyn ( OutPat ) -import Id ( mkSysLocal, lookupIdEnv, growIdEnvList, GenId, IdEnv(..) ) +import Id ( mkSysLocal, mkIdWithNewUniq, + lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv), + SYN_IE(Id) + ) import PprType ( GenType, GenTyVar ) import PprStyle ( PprStyle(..) ) +import Outputable ( pprQuote, Outputable(..) ) import Pretty -import SrcLoc ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc ) -import TcHsSyn ( TypecheckedPat(..) ) -import TyVar ( nullTyVarEnv, GenTyVar ) +import SrcLoc ( noSrcLoc, SrcLoc ) +import TcHsSyn ( SYN_IE(TypecheckedPat) ) +import Type ( SYN_IE(Type) ) +import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-}, SYN_IE(TyVar) ) import Unique ( Unique{-instances-} ) import UniqSupply ( splitUniqSupply, getUnique, getUniques, - mapUs, thenUs, returnUs, UniqSM(..) ) -import Unique ( Unique ) + mapUs, thenUs, returnUs, SYN_IE(UniqSM), + UniqSupply ) import Util ( assoc, mapAccumL, zipWithEqual, panic ) infixr 9 `thenDs` - -cloneTyVar = panic "DsMonad.cloneTyVar" -cloneTyVarFromTemplate = panic "DsMonad.cloneTyVarFromTemplate" -mkIdWithNewUniq = panic "DsMonad.mkIdWithNewUniq" \end{code} Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around @@ -63,8 +66,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 #-} @@ -78,11 +82,11 @@ 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 - Just xx -> xx + Just xx -> _PK_ xx Nothing -> mod_name -- default: module name thenDs :: DsM a -> (a -> DsM b) -> DsM b @@ -127,18 +131,18 @@ mapAndUnzipDs f (x:xs) zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c] -zipWithDs f [] [] = returnDs [] +zipWithDs f [] ys = returnDs [] zipWithDs f (x:xs) (y:ys) = f x y `thenDs` \ r -> zipWithDs f xs ys `thenDs` \ rs -> returnDs (r:rs) --- Note: crashes if lists not equal length (like zipWithEqual) \end{code} And all this mysterious stuff is so we can occasionally reach out and grab one or more names. @newLocalDs@ isn't exported---exported functions are defined with it. The difference in name-strings makes it easier to read debugging output. + \begin{code} newLocalDs :: FAST_STRING -> Type -> DsM Id newLocalDs nm ty us loc mod_and_grp env warns @@ -157,7 +161,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} @@ -165,7 +169,7 @@ newTyVarsDs :: [TyVar] -> DsM [TyVar] newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns = case (getUniques (length tyvar_tmpls) us) of { uniqs -> - (zipWithEqual cloneTyVarFromTemplate 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 @@ -176,18 +180,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} @@ -197,41 +204,19 @@ getModuleAndGroupDs us loc mod_and_grp env warns \end{code} \begin{code} -type DsIdEnv = IdEnv CoreExpr +type DsIdEnv = IdEnv Id -extendEnvDs :: [(Id, CoreExpr)] -> DsM a -> DsM a +extendEnvDs :: [(Id, Id)] -> DsM a -> DsM a extendEnvDs pairs then_do us loc mod_and_grp old_env warns - = case splitUniqSupply us of { (s1, s2) -> - let - revised_pairs = subst_all pairs s1 - in - then_do s2 loc mod_and_grp (growIdEnvList old_env revised_pairs) warns - } - where - subst_all pairs = mapUs subst pairs + = then_do us loc mod_and_grp (growIdEnvList old_env pairs) warns - subst (v, expr) - = substCoreExpr old_env nullTyVarEnv expr `thenUs` \ new_expr -> - returnUs (v, new_expr) - -lookupEnvDs :: Id -> DsM (Maybe CoreExpr) +lookupEnvDs :: Id -> DsM Id lookupEnvDs id us loc mod_and_grp env warns - = (lookupIdEnv env id, warns) - -- Note: we don't assert anything about the Id - -- being looked up. There's not really anything - -- much to say about it. (WDP 94/06) - -lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr -lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns = (case (lookupIdEnv env id) of - Nothing -> deflt + Nothing -> id Just xx -> xx, warns) - -lookupId :: [(Id, a)] -> Id -> a -lookupId env id - = assoc "lookupId" env id \end{code} %************************************************************************ @@ -241,41 +226,58 @@ 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 -> Doc pprDsWarnings sty warns - = ppAboves (map pp_cxt (bagToList warns)) + = vcat (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) = 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 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 - = ppHang (ppr sty fun) - 4 (ppSep [ppSep (map (ppr sty) pats), ppPStr SLIT("= ...")]) + = hsep [ptext SLIT("in the definition of function"), ppr sty fun] pp_match CaseMatch pats - = ppHang (ppPStr SLIT("in a case alternative:")) - 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) + = hang (ptext SLIT("in a group of case alternatives beginning:")) + 4 (ppr_pats pats) pp_match PatBindMatch pats - = ppHang (ppPStr SLIT("in a pattern binding:")) - 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) + = hang (ptext SLIT("in a pattern binding:")) + 4 (ppr_pats pats) pp_match LambdaMatch pats - = ppHang (ppPStr SLIT("in a lambda abstraction:")) - 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) + = 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) - pp_arrow_dotdotdot = ppPStr SLIT("-> ...") + ppr_pats pats = pprQuote sty $ \ sty -> + sep [sep (map (ppr sty) pats), ptext SLIT("-> ...")] \end{code}