X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FdeSugar%2FDsMonad.lhs;h=3428be64465324c973a2cb5a722228066016cb10;hb=0f55a795b8e3b6a9e679caca96512bb1e6fdac50;hp=c2034d75e5cc046f88eb8dd3b58784fcecb16a1c;hpb=2494407a750053daa61718fac371487d04818e57;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index c2034d7..3428be6 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -16,12 +16,11 @@ module DsMonad ( newFailLocalDs, getSrcLocDs, putSrcLocDs, getModuleAndGroupDs, - extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs, + extendEnvDs, lookupEnvDs, SYN_IE(DsIdEnv), - lookupId, dsShadowWarn, dsIncompleteWarn, - DsWarnings(..), + SYN_IE(DsWarnings), DsMatchContext(..), DsMatchKind(..), pprDsWarnings, DsWarnFlavour -- Nuke with 1.4 @@ -29,23 +28,27 @@ module DsMonad ( IMP_Ubiq() -import Bag ( emptyBag, snocBag, bagToList ) -import CmdLineOpts ( opt_SccGroup ) +import Bag ( emptyBag, snocBag, bagToList, Bag ) +import BasicTypes ( SYN_IE(Module) ) +import CmdLineOpts ( opt_PprUserLength ) import CoreSyn ( SYN_IE(CoreExpr) ) import CoreUtils ( substCoreExpr ) import HsSyn ( OutPat ) import Id ( mkSysLocal, mkIdWithNewUniq, - lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv) + lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv), + SYN_IE(Id) ) import PprType ( GenType, GenTyVar ) -import PprStyle ( PprStyle(..) ) +import Outputable ( pprQuote, Outputable(..), PprStyle(..) ) import Pretty import SrcLoc ( noSrcLoc, SrcLoc ) import TcHsSyn ( SYN_IE(TypecheckedPat) ) -import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} ) +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, SYN_IE(UniqSM) ) + mapUs, thenUs, returnUs, SYN_IE(UniqSM), + UniqSupply ) import Util ( assoc, mapAccumL, zipWithEqual, panic ) infixr 9 `thenDs` @@ -57,8 +60,8 @@ 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) @@ -66,6 +69,9 @@ type DsM result = type DsWarnings = Bag (DsWarnFlavour, DsMatchContext) -- The desugarer reports matches which are -- completely shadowed or incomplete patterns + +type Group = FAST_STRING + {-# INLINE andDs #-} {-# INLINE thenDs #-} {-# INLINE returnDs #-} @@ -74,17 +80,12 @@ type DsWarnings = Bag (DsWarnFlavour, DsMatchContext) 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 +initDs init_us env module_and_group action = 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 -> _PK_ xx - Nothing -> mod_name -- default: module name thenDs :: DsM a -> (a -> DsM b) -> DsM b andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a @@ -128,18 +129,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 @@ -201,41 +202,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) + = then_do us loc mod_and_grp (growIdEnvList old_env pairs) warns -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} %************************************************************************ @@ -260,42 +239,43 @@ data DsMatchKind | DoBindMatch deriving () -pprDsWarnings :: PprStyle -> DsWarnings -> Pretty +pprDsWarnings :: PprStyle -> DsWarnings -> Doc pprDsWarnings sty warns - = ppAboves (map pp_warn (bagToList warns)) + = vcat (map pp_warn (bagToList warns)) where - pp_warn (flavour, NoMatchContext) = ppSep [ppPStr SLIT("Warning: Some match is"), + pp_warn (flavour, NoMatchContext) = sep [ptext SLIT("Warning: Some match is"), case flavour of - Shadowed -> ppPStr SLIT("shadowed") - Incomplete -> ppPStr SLIT("possibly incomplete")] + Shadowed -> ptext SLIT("shadowed") + Incomplete -> ptext SLIT("possibly incomplete")] pp_warn (flavour, DsMatchContext kind pats loc) - = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")]) - 4 (ppHang msg + = hang (hcat [ppr (PprForUser opt_PprUserLength) loc, ptext SLIT(": ")]) + 4 (hang 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") + Shadowed -> ptext SLIT("Warning: Pattern match(es) completely overlapped") + Incomplete -> ptext SLIT("Warning: Possibly incomplete patterns") pp_match (FunMatch fun) pats - = ppCat [ppPStr SLIT("in the definition of function"), ppQuote (ppr sty fun)] + = hsep [ptext SLIT("in the definition of function"), ppr sty fun] pp_match CaseMatch pats - = ppHang (ppPStr SLIT("in a group of case alternatives beginning:")) - 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 - = ppHang (ppPStr SLIT("in a `do' pattern binding:")) - 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) + = 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}