#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,
setExtraRn, getExtraRn, getRnEnv,
getModuleRn, pushSrcLocRn, getSrcLocRn,
getSourceRn, getOccurrenceUpRn,
- getImplicitUpRn, ImplicitEnv(..), emptyImplicitEnv,
+ getImplicitUpRn, SYN_IE(ImplicitEnv), emptyImplicitEnv,
rnGetUnique, rnGetUniques,
newLocalNames,
lookupTyCon, lookupClass, lookupTyConOrClass,
extendSS2, extendSS,
- TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
+ SYN_IE(TyVarNamesEnv), mkTyVarNamesEnv, domTyVarNamesEnv,
lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
fixIO
) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(GHCbase(fixIO))
import SST
isRnLocal, isRnWired, isRnTyCon, isRnClass,
isRnTyConOrClass, isRnConstr, isRnField,
isRnClassOp, RenamedFixityDecl(..) )
-import RnUtils ( RnEnv(..), extendLocalRnEnv,
+import RnUtils ( SYN_IE(RnEnv), extendLocalRnEnv,
lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
qualNameErr, dupNamesErr
)
import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
import CmdLineOpts ( opt_WarnNameShadowing )
import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
- Error(..), Warning(..)
+ SYN_IE(Error), SYN_IE(Warning)
)
-import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, fmToList{-ToDo:rm-} )
+import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM{-, fmToList ToDo:rm-} )
import Maybes ( assocMaybe )
-import Name ( Module(..), RdrName(..), isQual,
- Name, mkLocalName, mkImplicitName,
+import Name ( SYN_IE(Module), RdrName(..), isQual,
+ OrigName(..), Name, mkLocalName, mkImplicitName,
getOccName, pprNonSym
)
-import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
+import PrelInfo ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
import PrelMods ( pRELUDE )
-import PprStyle{-ToDo:rm-}
-import Outputable{-ToDo:rm-}
-import Pretty--ToDo:rm ( Pretty(..), PrettyRep )
+--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
-- 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 ->
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
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
+ 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 rdr
+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 ->
- (let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
- in case (lookupFM b_key str_mod) of
+ (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_`
returnSST implicit
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
- = let
- str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
- in
- --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 str_mod) of
- Nothing -> 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
-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 ->
- (let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
- in case (lookupFM b_key str_mod) of
+ (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_`
returnSST implicit
\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}
*********************************************************