X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMonad.lhs;h=3ea0bc2eb1bfce4b4ab1b56aa8cef00a74cca840;hb=9d4c03805bafb6b1e1d47306b6a6c591c998e517;hp=9a01390cc9716b66debaeade9f69fa4d1df04f40;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 9a01390..3ea0bc2 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -1,13 +1,13 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % -\section[DesugarMonad]{@DesugarMonad@: monadery used in desugaring} +\section[DsMonad]{@DsMonad@: monadery used in desugaring} \begin{code} #include "HsVersions.h" module DsMonad ( - DsM(..), + SYN_IE(DsM), initDs, returnDs, thenDs, andDs, mapDs, listDs, mapAndUnzipDs, zipWithDs, uniqSMtoDsM, @@ -15,50 +15,35 @@ module DsMonad ( duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newFailLocalDs, getSrcLocDs, putSrcLocDs, - getSwitchCheckerDs, ifSwitchSetDs, getModuleAndGroupDs, extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs, - DsIdEnv(..), + SYN_IE(DsIdEnv), lookupId, dsShadowError, - DsMatchContext(..), DsMatchKind(..), pprDsWarnings, - -#ifdef DPH - listDs, -#endif - - -- and to make the interface self-sufficient... - Id, DataCon(..), SrcLoc, TyVar, TyVarTemplate, UniType, TauType(..), - ThetaType(..), SigmaType(..), SplitUniqSupply, UniqSM(..), - PlainCoreExpr(..), CoreExpr, GlobalSwitch, SwitchResult - - IF_ATTACK_PRAGMAS(COMMA lookupUFM COMMA lookupIdEnv) - IF_ATTACK_PRAGMAS(COMMA mkIdWithNewUniq COMMA mkSysLocal) - IF_ATTACK_PRAGMAS(COMMA unpackSrcLoc COMMA mkUniqueSupplyGrimily) - IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily) - IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA getSUnique) + DsMatchContext(..), DsMatchKind(..), pprDsWarnings ) where -import AbsSyn -import AbsUniType ( cloneTyVarFromTemplate, cloneTyVar, - TyVar, TyVarTemplate, UniType, TauType(..), - ThetaType(..), SigmaType(..), Class - IF_ATTACK_PRAGMAS(COMMA cmpTyVar) +IMP_Ubiq() + +import Bag ( emptyBag, snocBag, bagToList ) +import CmdLineOpts ( opt_SccGroup ) +import CoreSyn ( SYN_IE(CoreExpr) ) +import CoreUtils ( substCoreExpr ) +import HsSyn ( OutPat ) +import Id ( mkSysLocal, mkIdWithNewUniq, + lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv) ) -import Bag -import CmdLineOpts -- ( GlobalSwitch(..), SwitchResult(..), switchIsOn ) -import Id ( mkIdWithNewUniq, mkSysLocal, Id, DataCon(..) ) -import IdEnv -- ( mkIdEnv, IdEnv ) -import Maybes ( assocMaybe, Maybe(..) ) -import Outputable -import PlainCore +import PprType ( GenType, GenTyVar ) +import PprStyle ( PprStyle(..) ) import Pretty import SrcLoc ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc ) -import TyVarEnv -- ( nullTyVarEnv, TyVarEnv ) -import SplitUniq -import Unique -import Util +import TcHsSyn ( SYN_IE(TypecheckedPat) ) +import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} ) +import Unique ( Unique{-instances-} ) +import UniqSupply ( splitUniqSupply, getUnique, getUniques, + mapUs, thenUs, returnUs, SYN_IE(UniqSM) ) +import Util ( assoc, mapAccumL, zipWithEqual, panic ) infixr 9 `thenDs` \end{code} @@ -68,56 +53,51 @@ a @UniqueSupply@ and some annotations, which presumably include source-file location information: \begin{code} type DsM result = - SplitUniqSupply - -> SrcLoc -- to put in pattern-matching error msgs - -> (GlobalSwitch -> SwitchResult) -- so we can consult global switches - -> (FAST_STRING, FAST_STRING) -- "module"+"group" : for SCC profiling + UniqSupply + -> SrcLoc -- to put in pattern-matching error msgs + -> (FAST_STRING, FAST_STRING) -- "module"+"group" : for SCC profiling -> DsIdEnv -> DsWarnings -> (result, DsWarnings) -type DsWarnings = Bag DsMatchContext -- The desugarer reports matches which are +type DsWarnings = Bag DsMatchContext -- The desugarer reports matches which are -- completely shadowed - -#ifdef __GLASGOW_HASKELL__ {-# INLINE andDs #-} {-# INLINE thenDs #-} {-# INLINE returnDs #-} -#endif -- initDs returns the UniqSupply out the end (not just the result) -initDs :: SplitUniqSupply +initDs :: UniqSupply -> DsIdEnv - -> (GlobalSwitch -> SwitchResult) -> FAST_STRING -- module name: for profiling; (group name: from switches) -> DsM a -> (a, DsWarnings) -initDs init_us env sw_chkr mod_name action - = action init_us mkUnknownSrcLoc sw_chkr module_and_group env emptyBag +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 (stringSwitchSet sw_chkr SccGroup) of + 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 -thenDs expr cont us loc sw_chkr mod_and_grp env warns - = case splitUniqSupply us of { (s1, s2) -> - case (expr s1 loc sw_chkr mod_and_grp env warns) of { (result, warns1) -> - cont result s2 loc sw_chkr mod_and_grp env warns1}} +thenDs m1 m2 us loc mod_and_grp env warns + = case splitUniqSupply us of { (s1, s2) -> + case (m1 s1 loc mod_and_grp env warns) of { (result, warns1) -> + m2 result s2 loc mod_and_grp env warns1}} -andDs combiner m1 m2 us loc sw_chkr mod_and_grp env warns - = case splitUniqSupply us of { (s1, s2) -> - case (m1 s1 loc sw_chkr mod_and_grp env warns) of { (result1, warns1) -> - case (m2 s2 loc sw_chkr mod_and_grp env warns1) of { (result2, warns2) -> +andDs combiner m1 m2 us loc mod_and_grp env warns + = case splitUniqSupply us of { (s1, s2) -> + case (m1 s1 loc mod_and_grp env warns) of { (result1, warns1) -> + case (m2 s2 loc mod_and_grp env warns1) of { (result2, warns2) -> (combiner result1 result2, warns2) }}} returnDs :: a -> DsM a -returnDs result us loc sw_chkr mod_and_grp env warns = (result, warns) +returnDs result us loc mod_and_grp env warns = (result, warns) listDs :: [DsM a] -> DsM [a] listDs [] = returnDs [] @@ -149,6 +129,7 @@ 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 @@ -156,9 +137,9 @@ 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 -> UniType -> DsM Id -newLocalDs nm ty us loc sw_chkr mod_and_grp env warns - = case (getSUnique us) of { assigned_uniq -> +newLocalDs :: FAST_STRING -> Type -> DsM Id +newLocalDs nm ty us loc mod_and_grp env warns + = case (getUnique us) of { assigned_uniq -> (mkSysLocal nm assigned_uniq ty loc, warns) } newSysLocalDs = newLocalDs SLIT("ds") @@ -166,22 +147,22 @@ newSysLocalsDs tys = mapDs (newLocalDs SLIT("ds")) tys newFailLocalDs = newLocalDs SLIT("fail") duplicateLocalDs :: Id -> DsM Id -duplicateLocalDs old_local us loc sw_chkr mod_and_grp env warns - = case (getSUnique us) of { assigned_uniq -> +duplicateLocalDs old_local us loc mod_and_grp env warns + = case (getUnique us) of { assigned_uniq -> (mkIdWithNewUniq old_local assigned_uniq, warns) } cloneTyVarsDs :: [TyVar] -> DsM [TyVar] -cloneTyVarsDs tyvars us loc sw_chkr mod_and_grp env warns - = case (getSUniques (length tyvars) us) of { uniqs -> - (zipWith cloneTyVar tyvars uniqs, warns) } +cloneTyVarsDs tyvars us loc mod_and_grp env warns + = case (getUniques (length tyvars) us) of { uniqs -> + (zipWithEqual "cloneTyVarsDs" cloneTyVar tyvars uniqs, warns) } \end{code} \begin{code} -newTyVarsDs :: [TyVarTemplate] -> DsM [TyVar] +newTyVarsDs :: [TyVar] -> DsM [TyVar] -newTyVarsDs tyvar_tmpls us loc sw_chkr mod_and_grp env warns - = case (getSUniques (length tyvar_tmpls) us) of { uniqs -> - (zipWith cloneTyVarFromTemplate tyvar_tmpls uniqs, warns) } +newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns + = case (getUniques (length tyvar_tmpls) us) of { uniqs -> + (zipWithEqual "newTyVarsDs" cloneTyVar tyvar_tmpls uniqs, warns) } \end{code} We can also reach out and either set/grab location information from @@ -189,69 +170,57 @@ the @SrcLoc@ being carried around. \begin{code} uniqSMtoDsM :: UniqSM a -> DsM a -uniqSMtoDsM u_action us loc sw_chkr mod_and_grp env warns - = let - us_to_use = mkUniqueSupplyGrimily us - in - (snd (u_action us_to_use), warns) +uniqSMtoDsM u_action us loc mod_and_grp env warns + = (u_action us, warns) getSrcLocDs :: DsM (String, String) -getSrcLocDs us loc sw_chkr mod_and_grp env warns +getSrcLocDs us loc mod_and_grp env warns = case (unpackSrcLoc loc) of { (x,y) -> ((_UNPK_ x, _UNPK_ y), warns) } putSrcLocDs :: SrcLoc -> DsM a -> DsM a -putSrcLocDs new_loc expr us old_loc sw_chkr mod_and_grp env warns - = expr us new_loc sw_chkr mod_and_grp env warns +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 sw_chkr mod_and_grp env warns +dsShadowError cxt us loc mod_and_grp env warns = ((), warns `snocBag` cxt) \end{code} \begin{code} -getSwitchCheckerDs :: DsM (GlobalSwitch -> Bool) -getSwitchCheckerDs us loc sw_chkr mod_and_grp env warns - = (switchIsOn sw_chkr, warns) - -ifSwitchSetDs :: GlobalSwitch -> DsM a -> DsM a -> DsM a -ifSwitchSetDs switch then_ else_ us loc sw_chkr mod_and_grp env warns - = (if switchIsOn sw_chkr switch then then_ else else_) - us loc sw_chkr mod_and_grp env warns - getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING) -getModuleAndGroupDs us loc sw_chkr mod_and_grp env warns +getModuleAndGroupDs us loc mod_and_grp env warns = (mod_and_grp, warns) \end{code} \begin{code} -type DsIdEnv = IdEnv PlainCoreExpr +type DsIdEnv = IdEnv CoreExpr -extendEnvDs :: [(Id, PlainCoreExpr)] -> DsM a -> DsM a +extendEnvDs :: [(Id, CoreExpr)] -> DsM a -> DsM a -extendEnvDs pairs expr us loc sw_chkr mod_and_grp old_env warns +extendEnvDs pairs then_do us loc mod_and_grp old_env warns = case splitUniqSupply us of { (s1, s2) -> - case (mapAccumL subst s1 pairs) of { (_, revised_pairs) -> - expr s2 loc sw_chkr mod_and_grp (growIdEnvList old_env revised_pairs) warns - }} + let + revised_pairs = subst_all pairs s1 + in + then_do s2 loc mod_and_grp (growIdEnvList old_env revised_pairs) warns + } where - subst us (v, expr) - = case splitUniqSupply us of { (s1, s2) -> - let - us_to_use = mkUniqueSupplyGrimily s1 - in - case (substCoreExpr us_to_use old_env nullTyVarEnv expr) of { (_, expr2) -> - (s2, (v, expr2)) }} - -lookupEnvDs :: Id -> DsM (Maybe PlainCoreExpr) -lookupEnvDs id us loc sw_chkr mod_and_grp env warns + 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) -lookupEnvWithDefaultDs :: Id -> PlainCoreExpr -> DsM PlainCoreExpr -lookupEnvWithDefaultDs id deflt us loc sw_chkr mod_and_grp env warns +lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr +lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns = (case (lookupIdEnv env id) of Nothing -> deflt Just xx -> xx, @@ -278,6 +247,7 @@ data DsMatchKind | CaseMatch | LambdaMatch | PatBindMatch + | DoBindMatch pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty pprDsWarnings sty warns @@ -305,5 +275,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}