X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMonad.lhs;h=19a4c33b40e6faba0eec9115cbd251b222df7b35;hb=f36fb2ce821caf594c1db5669dd10ca082f66361;hp=a6c8b6193420946e5f32c095fa2a750b14b0fc51;hpb=26741ec416bae2c502ef00a2ba0e79050a32cb67;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index a6c8b61..19a4c33 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -4,10 +4,8 @@ \section[DsMonad]{@DsMonad@: monadery used in desugaring} \begin{code} -#include "HsVersions.h" - module DsMonad ( - DsM(..), + DsM, initDs, returnDs, thenDs, andDs, mapDs, listDs, mapAndUnzipDs, zipWithDs, uniqSMtoDsM, @@ -16,34 +14,32 @@ module DsMonad ( newFailLocalDs, getSrcLocDs, putSrcLocDs, getModuleAndGroupDs, - extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs, - DsIdEnv(..), - lookupId, + extendEnvDs, lookupEnvDs, + DsIdEnv, - dsShadowError, + dsWarn, + DsWarnings, DsMatchContext(..), DsMatchKind(..), pprDsWarnings ) where -IMP_Ubiq() +#include "HsVersions.h" -import Bag ( emptyBag, snocBag, bagToList ) -import CmdLineOpts ( opt_SccGroup ) -import CoreSyn ( SYN_IE(CoreExpr) ) -import CoreUtils ( substCoreExpr ) +import Bag ( emptyBag, snocBag, bagToList, Bag ) +import BasicTypes ( Module ) +import ErrUtils ( WarnMsg ) import HsSyn ( OutPat ) -import Id ( mkSysLocal, mkIdWithNewUniq, - lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv) +import MkId ( mkSysLocal ) +import Id ( mkIdWithNewUniq, + lookupIdEnv, growIdEnvList, IdEnv, Id ) -import PprType ( GenType, GenTyVar ) -import PprStyle ( PprStyle(..) ) -import Pretty -import SrcLoc ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc ) -import TcHsSyn ( TypecheckedPat(..) ) -import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} ) -import Unique ( Unique{-instances-} ) +import Outputable +import SrcLoc ( noSrcLoc, SrcLoc ) +import TcHsSyn ( TypecheckedPat ) +import Type ( Type ) +import TyVar ( cloneTyVar, TyVar ) import UniqSupply ( splitUniqSupply, getUnique, getUniques, - mapUs, thenUs, returnUs, SYN_IE(UniqSM) ) -import Util ( assoc, mapAccumL, zipWithEqual, panic ) + UniqSM, UniqSupply ) +import Util ( zipWithEqual, panic ) infixr 9 `thenDs` \end{code} @@ -54,14 +50,17 @@ presumably include source-file location information: \begin{code} type DsM result = UniqSupply - -> SrcLoc -- to put in pattern-matching error msgs - -> (FAST_STRING, FAST_STRING) -- "module"+"group" : for SCC profiling + -> SrcLoc -- to put in pattern-matching error msgs + -> (Module, Group) -- module + group name : for SCC profiling -> DsIdEnv -> DsWarnings -> (result, DsWarnings) -type DsWarnings = Bag DsMatchContext -- The desugarer reports matches which are - -- completely shadowed +type DsWarnings = Bag WarnMsg -- The desugarer reports matches which are + -- completely shadowed or incomplete patterns + +type Group = FAST_STRING + {-# INLINE andDs #-} {-# INLINE thenDs #-} {-# INLINE returnDs #-} @@ -70,17 +69,12 @@ type DsWarnings = Bag DsMatchContext -- The desugarer reports matches which are initDs :: UniqSupply -> DsIdEnv - -> FAST_STRING -- module name: for profiling; (group name: from switches) + -> (Module, Group) -- module name: for profiling; (group name: from switches) -> DsM a -> (a, DsWarnings) -initDs init_us env mod_name action - = action init_us mkUnknownSrcLoc module_and_group env emptyBag - where - module_and_group = (mod_name, grp_name) - grp_name = case opt_SccGroup of - Just xx -> _PK_ xx - Nothing -> mod_name -- default: module name +initDs init_us env module_and_group action + = action init_us noSrcLoc module_and_group env emptyBag thenDs :: DsM a -> (a -> DsM b) -> DsM b andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a @@ -124,18 +118,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 @@ -173,18 +167,17 @@ 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) +dsWarn :: WarnMsg -> DsM () +dsWarn warn us loc mod_and_grp env warns = ((), warns `snocBag` warn) + \end{code} \begin{code} @@ -194,41 +187,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 - - subst (v, expr) - = substCoreExpr old_env nullTyVarEnv expr `thenUs` \ new_expr -> - returnUs (v, new_expr) - -lookupEnvDs :: Id -> DsM (Maybe CoreExpr) -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) + = then_do us loc mod_and_grp (growIdEnvList old_env pairs) warns -lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr -lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns +lookupEnvDs :: Id -> DsM Id +lookupEnvDs id 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,6 +212,7 @@ lookupId env id data DsMatchContext = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc | NoMatchContext + deriving () data DsMatchKind = FunMatch Id @@ -248,36 +220,10 @@ data DsMatchKind | LambdaMatch | PatBindMatch | DoBindMatch + | ListCompMatch + | LetMatch + deriving () -pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty -pprDsWarnings sty warns - = ppAboves (map pp_cxt (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:")) - 4 (pp_match kind pats)) - - pp_match (FunMatch fun) pats - = ppHang (ppr sty fun) - 4 (ppSep [ppSep (map (ppr sty) pats), ppPStr SLIT("= ...")]) - - pp_match CaseMatch pats - = ppHang (ppPStr SLIT("in a case alternative:")) - 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) - - pp_match PatBindMatch pats - = ppHang (ppPStr SLIT("in a pattern binding:")) - 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) - - pp_match LambdaMatch pats - = 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("-> ...") +pprDsWarnings :: DsWarnings -> SDoc +pprDsWarnings warns = vcat (bagToList warns) \end{code}