X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnMonad.lhs;h=78f89184f7d3ea0f2e27dd747ad94b9a48616c57;hb=30cf375e0bc79a6b71074a5e0fd2ec393241a751;hp=c7955ae46e9af8ad730d04547fbdec017c648b6f;hpb=f0e42a460a3bb4857f3c4bfa92dd134fcf409849;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index c7955ae..78f8918 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -9,23 +9,25 @@ module RnMonad ( RnMonad(..), RnM(..), RnM_Fixes(..), RnDown, SST_R, initRn, thenRn, thenRn_, andRn, returnRn, - mapRn, mapAndUnzipRn, + mapRn, mapAndUnzipRn, mapAndUnzip3Rn, addErrRn, addErrIfRn, addWarnRn, addWarnIfRn, failButContinueRn, warnAndContinueRn, - setExtraRn, getExtraRn, + setExtraRn, getExtraRn, getRnEnv, getModuleRn, pushSrcLocRn, getSrcLocRn, getSourceRn, getOccurrenceUpRn, - getImplicitUpRn, ImplicitEnv(..), + getImplicitUpRn, ImplicitEnv(..), emptyImplicitEnv, rnGetUnique, rnGetUniques, newLocalNames, - lookupValue, lookupValueMaybe, lookupClassOp, + lookupValue, lookupConstr, lookupField, lookupClassOp, lookupTyCon, lookupClass, lookupTyConOrClass, extendSS2, extendSS, TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv, - lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs + lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs, + + fixIO ) where import Ubiq{-uitous-} @@ -35,12 +37,14 @@ import SST import HsSyn ( FixityDecl ) import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit, mkRnImplicitTyCon, mkRnImplicitClass, - isRnLocal, isRnWired, isRnTyCon, isRnClass, isRnClassOp, - RenamedFixityDecl(..) ) + isRnLocal, isRnWired, isRnTyCon, isRnClass, + isRnTyConOrClass, isRnConstr, isRnField, + isRnClassOp, RenamedFixityDecl(..) ) import RnUtils ( RnEnv(..), extendLocalRnEnv, - lookupRnEnv, lookupTcRnEnv, + lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv, unknownNameErr, badClassOpErr, qualNameErr, - dupNamesErr, shadowedNameWarn ) + dupNamesErr, shadowedNameWarn + ) import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) import CmdLineOpts ( opt_WarnNameShadowing ) @@ -51,6 +55,8 @@ import Name ( Module(..), RdrName(..), isQual, Name, mkLocalName, mkImplicitName, getOccName ) +import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) ) +import PrelMods ( pRELUDE ) import Pretty ( Pretty(..), PrettyRep ) import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) import UniqFM ( UniqFM, emptyUFM ) @@ -83,12 +89,14 @@ data RnMode s = RnSource (MutableVar s (Bag (RnName, RdrName))) -- Renaming source; returning occurences - | RnIface (MutableVar s ImplicitEnv) + | RnIface BuiltinNames BuiltinKeys + (MutableVar s ImplicitEnv) -- Renaming interface; creating and returning implicit names - -- One map for Values and one for TyCons/Classes. + -- ImplicitEnv: one map for Values and one for TyCons/Classes. type ImplicitEnv = (FiniteMap RdrName RnName, FiniteMap RdrName RnName) - +emptyImplicitEnv :: ImplicitEnv +emptyImplicitEnv = (emptyFM, emptyFM) -- With a builtin polymorphic type for _runSST the type for -- initTc should use RnM s r instead of RnM _RealWorld r @@ -103,14 +111,15 @@ initRn :: Bool -- True => Source; False => Iface initRn source mod env us do_rn = _runSST ( newMutVarSST emptyBag `thenSST` \ occ_var -> - newMutVarSST (emptyFM,emptyFM) `thenSST` \ imp_var -> + newMutVarSST emptyImplicitEnv `thenSST` \ imp_var -> newMutVarSST us `thenSST` \ us_var -> newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var -> let mode = if source then RnSource occ_var else - RnIface imp_var + case builtinNameInfo of { (wiredin_fm, key_fm, _) -> + RnIface wiredin_fm key_fm imp_var } rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var in @@ -154,6 +163,12 @@ mapAndUnzipRn f (x:xs) = f x `thenRn` \ (r1, r2) -> mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) -> returnRn (r1:rs1, r2:rs2) + +mapAndUnzip3Rn f [] = returnRn ([],[],[]) +mapAndUnzip3Rn f (x:xs) + = f x `thenRn` \ (r1, r2, r3) -> + mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) -> + returnRn (r1:rs1, r2:rs2, r3:rs3) \end{code} For errors and warnings ... @@ -187,6 +202,10 @@ addWarnIfRn False warn = returnRn () \begin{code} +getRnEnv :: RnMonad x s RnEnv +getRnEnv (RnDown _ _ _ _ env _ _) + = returnSST env + setExtraRn :: x -> RnMonad x s r -> RnMonad y s r setExtraRn x m (RnDown _ mod locn mode env us errs) = m (RnDown x mod locn mode env us errs) @@ -208,17 +227,17 @@ getSrcLocRn (RnDown _ _ locn _ _ _ _) = returnSST locn getSourceRn :: RnMonad x s Bool -getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True -getSourceRn (RnDown _ _ _ (RnIface _) _ _ _) = returnSST False +getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True +getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName)) getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _) = readMutVarSST occ_var -getOccurrenceUpRn (RnDown _ _ _ (RnIface _) _ _ _) +getOccurrenceUpRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = panic "getOccurrenceUpRn:RnIface" -getImplicitUpRn :: RnMonad x s (FiniteMap RdrName RnName, FiniteMap RdrName RnName) -getImplicitUpRn (RnDown _ _ _ (RnIface imp_var) _ _ _) +getImplicitUpRn :: RnMonad x s ImplicitEnv +getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _) = readMutVarSST imp_var getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _) = panic "getImplicitUpRn:RnIface" @@ -274,11 +293,11 @@ newLocalNames :: String -- Documentation string -> RnMonad x s [RnName] newLocalNames str names_w_loc - = mapRn (addErrRn . qualNameErr str) quals `thenRn_` - mapRn (addErrRn . dupNamesErr str) dups `thenRn_` + = mapRn (addErrRn . qualNameErr str) quals `thenRn_` + mapRn (addErrRn . dupNamesErr str) dups `thenRn_` mkLocalNames these where - quals = filter (isQual.fst) names_w_loc + quals = filter (isQual.fst) names_w_loc (these, dups) = removeDups cmp_fst names_w_loc cmp_fst (a,_) (b,_) = cmp a b \end{code} @@ -287,10 +306,10 @@ newLocalNames str names_w_loc mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName] mkLocalNames names_w_locs = rnGetUniques (length names_w_locs) `thenRn` \ uniqs -> - returnRn (zipWithEqual new_local uniqs names_w_locs) + returnRn (zipWithEqual "mkLocalNames" new_local uniqs names_w_locs) where new_local uniq (Unqual str, srcloc) - = mkRnName (mkLocalName uniq str srcloc) + = mkRnName (mkLocalName uniq str False{-emph names-} srcloc) \end{code} @@ -312,19 +331,28 @@ If not found create new implicit name, adding it to the implicit env. \begin{code} lookupValue :: RdrName -> RnMonad x s RnName +lookupConstr :: RdrName -> RnMonad x s RnName +lookupField :: RdrName -> RnMonad x s RnName lookupClassOp :: RnName -> RdrName -> RnMonad x s RnName lookupValue rdr - = lookup_val rdr (\ rn -> True) (unknownNameErr "value") + = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value") + +lookupConstr rdr + = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor") + +lookupField rdr + = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field") lookupClassOp cls rdr - = lookup_val rdr (isRnClassOp cls) (badClassOpErr cls) + = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls) +-- Note: the lookup checks are only performed when renaming source -lookup_val rdr check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _) - = case lookupRnEnv env rdr of +lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _) + = case lookup env rdr of Just name | check name -> succ name - | otherwise -> fail + | otherwise -> fail Nothing -> fail where @@ -335,29 +363,33 @@ lookup_val rdr check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _) returnSST name fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down -lookup_val rdr check do_err down@(RnDown _ _ locn (RnIface imp_var) env us_var _) - = case lookupRnEnv env rdr of - Just name | check name -> returnSST name - | otherwise -> failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down - Nothing -> lookup_or_create_implicit_val imp_var us_var rdr +lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _) + = case lookup env rdr of + Just name -> returnSST name + Nothing -> lookup_nonexisting_val b_names b_key imp_var us_var rdr + +lookup_nonexisting_val (b_names,_) b_key imp_var us_var rdr + = let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } + in case (lookupFM b_names str_mod) of + Nothing -> lookup_or_create_implicit_val b_key imp_var us_var rdr + Just xx -> returnSST xx -lookup_or_create_implicit_val imp_var us_var rdr - = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm)-> +lookup_or_create_implicit_val b_key imp_var us_var rdr + = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) -> case lookupFM implicit_val_fm rdr of Just implicit -> returnSST implicit Nothing -> - get_unique us_var `thenSST` \ uniq -> - let - implicit = mkRnImplicit (mkImplicitName uniq rdr) - new_val_fm = addToFM implicit_val_fm rdr implicit - in - writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_` - returnSST implicit - - -lookupValueMaybe :: RdrName -> RnMonad x s (Maybe RnName) -lookupValueMaybe rdr down@(RnDown _ _ _ (RnSource _) env _ _) - = returnSST (lookupRnEnv env rdr) + (let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } + in case (lookupFM b_key str_mod) of + Just (u,_) -> returnSST u + _ -> get_unique us_var + ) `thenSST` \ uniq -> + let + implicit = mkRnImplicit (mkImplicitName uniq rdr) + new_val_fm = addToFM implicit_val_fm rdr implicit + in + writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_` + returnSST implicit \end{code} @@ -372,7 +404,7 @@ lookupClass rdr = lookup_tc rdr isRnClass mkRnImplicitClass "class" lookupTyConOrClass rdr - = lookup_tc rdr (\ rn -> isRnTyCon rn || isRnClass rn) + = lookup_tc rdr isRnTyConOrClass (panic "lookupTC:mk_implicit") "class or type constructor" lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _) @@ -385,27 +417,37 @@ lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) returnSST name fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down -lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface imp_var) env us_var _) +lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _) = case lookupTcRnEnv env rdr of Just name | check name -> returnSST name | otherwise -> fail - Nothing -> lookup_or_create_implicit_tc check mk_implicit fail imp_var us_var rdr + Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var rdr where fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down -lookup_or_create_implicit_tc check mk_implicit fail imp_var us_var rdr - = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm)-> +lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var rdr + = let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } + in case (lookupFM b_names str_mod) of + Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr + Just xx -> returnSST xx + +lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr + = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) -> case lookupFM implicit_tc_fm rdr of Just implicit | check implicit -> returnSST implicit | otherwise -> fail Nothing -> - get_unique us_var `thenSST` \ uniq -> - let - implicit = mk_implicit (mkImplicitName uniq rdr) - new_tc_fm = addToFM implicit_tc_fm rdr implicit - in - writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_` - returnSST implicit + (let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } + in case (lookupFM b_key str_mod) of + Just (u,_) -> returnSST u + _ -> get_unique us_var + ) `thenSST` \ uniq -> + let + implicit = mk_implicit (mkImplicitName uniq rdr) + new_tc_fm = addToFM implicit_tc_fm rdr implicit + in + writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_` + returnSST implicit \end{code} @@ -493,3 +535,13 @@ lookupTyVarName env occ failButContinueRn (mkRnUnbound occ) (unknownNameErr "type variable" occ loc) \end{code} + + +\begin{code} +fixIO :: (a -> IO a) -> IO a +fixIO k s = let + result = k loop s + (Right loop, _) = result + in + result +\end{code}