X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnMonad.lhs;h=22cb653f79f91a87f365e6b728474c597150b5aa;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=eaaa862186bbfd1137a899126d7d15d2a2c6ce20;hpb=dabfa71f33eabc5a2d10959728f772aa016f1c84;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index eaaa862..22cb653 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -7,7 +7,7 @@ #include "HsVersions.h" module RnMonad ( - RnMonad(..), RnM(..), RnM_Fixes(..), RnDown, SST_R, + SYN_IE(RnMonad), SYN_IE(RnM), SYN_IE(RnM_Fixes), RnDown, SST_R, initRn, thenRn, thenRn_, andRn, returnRn, mapRn, mapAndUnzipRn, mapAndUnzip3Rn, @@ -16,7 +16,7 @@ module RnMonad ( setExtraRn, getExtraRn, getRnEnv, getModuleRn, pushSrcLocRn, getSrcLocRn, getSourceRn, getOccurrenceUpRn, - getImplicitUpRn, ImplicitEnv(..), emptyImplicitEnv, + getImplicitUpRn, SYN_IE(ImplicitEnv), emptyImplicitEnv, rnGetUnique, rnGetUniques, newLocalNames, @@ -24,13 +24,14 @@ module RnMonad ( lookupTyCon, lookupClass, lookupTyConOrClass, extendSS2, extendSS, - TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv, + SYN_IE(TyVarNamesEnv), mkTyVarNamesEnv, domTyVarNamesEnv, lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs, fixIO ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} +IMPORT_1_3(GHCbase(fixIO)) import SST @@ -40,26 +41,30 @@ import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit, isRnLocal, isRnWired, isRnTyCon, isRnClass, isRnTyConOrClass, isRnConstr, isRnField, isRnClassOp, RenamedFixityDecl(..) ) -import RnUtils ( RnEnv(..), extendLocalRnEnv, +import RnUtils ( SYN_IE(RnEnv), extendLocalRnEnv, lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv, - unknownNameErr, badClassOpErr, qualNameErr, - dupNamesErr, shadowedNameWarn + qualNameErr, dupNamesErr ) import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) import CmdLineOpts ( opt_WarnNameShadowing ) -import ErrUtils ( Error(..), Warning(..) ) -import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM ) +import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine, + SYN_IE(Error), SYN_IE(Warning) + ) +import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM{-, fmToList ToDo:rm-} ) import Maybes ( assocMaybe ) -import Name ( Module(..), RdrName(..), isQual, - Name, mkLocalName, mkImplicitName, - getOccName +import Name ( SYN_IE(Module), RdrName(..), isQual, + OrigName(..), Name, mkLocalName, mkImplicitName, + getOccName, pprNonSym ) -import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) ) -import Pretty ( Pretty(..), PrettyRep ) +import PrelInfo ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) ) +import PrelMods ( pRELUDE ) +--import PprStyle{-ToDo:rm-} +--import Outputable{-ToDo:rm-} +import Pretty import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) import UniqFM ( UniqFM, emptyUFM ) -import UniqSet ( UniqSet(..), mkUniqSet, minusUniqSet ) +import UniqSet ( SYN_IE(UniqSet), mkUniqSet, minusUniqSet ) import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply ) import Unique ( Unique ) import Util @@ -93,22 +98,27 @@ data RnMode s -- Renaming interface; creating and returning implicit names -- ImplicitEnv: one map for Values and one for TyCons/Classes. -type ImplicitEnv = (FiniteMap RdrName RnName, FiniteMap RdrName RnName) +type ImplicitEnv = (FiniteMap OrigName RnName, FiniteMap OrigName 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 +-- With a builtin polymorphic type for runSST the type for +-- initTc should use RnM s r instead of RnM RealWorld r +#if __GLASGOW_HASKELL__ >= 200 +# define REAL_WORLD GHCbuiltins.RealWorld +#else +# define REAL_WORLD _RealWorld +#endif initRn :: Bool -- True => Source; False => Iface -> Module -> RnEnv -> UniqSupply - -> RnM _RealWorld r + -> RnM REAL_WORLD r -> (r, Bag Error, Bag Warning) initRn source mod env us do_rn - = _runSST ( + = runSST ( newMutVarSST emptyBag `thenSST` \ occ_var -> newMutVarSST emptyImplicitEnv `thenSST` \ imp_var -> newMutVarSST us `thenSST` \ us_var -> @@ -117,8 +127,7 @@ initRn source mod env us do_rn mode = if source then RnSource occ_var else - case builtinNameInfo of { (wiredin_fm, key_fm, _) -> - RnIface wiredin_fm key_fm imp_var } + RnIface builtinNameMaps builtinKeysMap imp_var rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var in @@ -364,34 +373,31 @@ lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env 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 - = case rdr of - Qual _ _ -> -- builtin things *don't* have Qual names - lookup_or_create_implicit_val b_key imp_var us_var rdr - - Unqual n -> case (lookupFM b_names n) of - Nothing -> lookup_or_create_implicit_val b_key imp_var us_var rdr - Just xx -> returnSST xx - -lookup_or_create_implicit_val b_key imp_var us_var rdr + Just name -> returnSST name + Nothing -> case rdr of + Unqual n -> panic ("lookup_val:"++ _UNPK_ n) + Qual m n -> + lookup_nonexisting_val b_names b_key imp_var us_var (OrigName m n) + +lookup_nonexisting_val (b_names,_) b_key imp_var us_var orig + = case (lookupFM b_names orig) of + Just xx -> returnSST xx + Nothing -> lookup_or_create_implicit_val b_key imp_var us_var orig + +lookup_or_create_implicit_val b_key imp_var us_var orig = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) -> - case lookupFM implicit_val_fm rdr of + case (lookupFM implicit_val_fm orig) of Just implicit -> returnSST implicit Nothing -> - (case rdr of - Qual _ _ -> get_unique us_var - Unqual n -> case (lookupFM b_key n) of - Just (u,_) -> returnSST u - _ -> get_unique us_var - ) `thenSST` \ uniq -> + (case (lookupFM b_key orig) 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 + implicit = mkRnImplicit (mkImplicitName uniq orig) + new_val_fm = addToFM implicit_val_fm orig implicit in - writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_` + writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_` returnSST implicit \end{code} @@ -420,40 +426,35 @@ 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 b_names b_key imp_var) env us_var _) +lookup_tc rdr@(Qual m n) 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_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var rdr + Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var (OrigName m n) where fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down -lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var rdr - = case rdr of - Qual _ _ -> -- builtin things *don't* have Qual names - lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr +lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var orig--@(OrigName m n) + = --pprTrace "lookup:" (ppAboves [case str_mod of {(n,m)->ppCat [ppPStr n, ppPStr m]}, ppAboves [ ppCat [ppPStr n, ppPStr m] | ((n,m), _) <- fmToList b_names]]) $ + case (lookupFM b_names orig) of + Just xx -> returnSST xx + Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig - Unqual n -> case (lookupFM b_names n) 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 +lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) -> - case lookupFM implicit_tc_fm rdr of + case (lookupFM implicit_tc_fm orig) of Just implicit | check implicit -> returnSST implicit | otherwise -> fail Nothing -> - (case rdr of - Qual _ _ -> get_unique us_var - Unqual n -> case (lookupFM b_key n) of - Just (u,_) -> returnSST u - _ -> get_unique us_var - ) `thenSST` \ uniq -> + (case (lookupFM b_key orig) 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 + implicit = mk_implicit (mkImplicitName uniq orig) + new_tc_fm = addToFM implicit_tc_fm orig implicit in - writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_` + writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_` returnSST implicit \end{code} @@ -545,10 +546,36 @@ lookupTyVarName env occ \begin{code} +#if __GLASGOW_HASKELL__ >= 200 + -- can get it from GHCbase +#else fixIO :: (a -> IO a) -> IO a + fixIO k s = let result = k loop s (Right loop, _) = result in result +#endif +\end{code} + +********************************************************* +* * +\subsection{Errors used in RnMonad} +* * +********************************************************* + +\begin{code} +unknownNameErr descriptor name locn + = addShortErrLocLine locn $ \ sty -> + ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name] + +badClassOpErr clas op locn + = addErrLoc locn "" $ \ sty -> + ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `", + ppr sty clas, ppStr "'"] + +shadowedNameWarn locn shadow + = addShortWarnLocLine locn $ \ sty -> + ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow] \end{code}