IMP_Ubiq()
-import PreludeGlaST ( thenPrimIO, seqPrimIO, newVar, readVar, writeVar, MutableVar(..) )
+import PreludeGlaST ( thenPrimIO, newVar, readVar, writeVar, SYN_IE(MutableVar) )
+#if __GLASGOW_HASKELL__ >= 200
+# define ST_THEN `stThen`
+# define TRY_IO tryIO
+IMPORT_1_3(GHCio(stThen,tryIO))
+#else
+# define ST_THEN `thenPrimIO`
+# define TRY_IO try
+#endif
import HsSyn
import HsPragmas ( noGenPragmas )
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) )
import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
fmToList, delListFromFM, sizeFM, foldFM, unitFM,
- plusFM_C, addListToFM, keysFM{-ToDo:rm-}
+ plusFM_C, addListToFM{-, keysFM ToDo:rm-}, FiniteMap
)
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, MaybeErr(..) )
import Name ( origName, moduleOf, nameOf, qualToOrigName, OrigName(..),
isLexCon, RdrName(..), Name{-instance NamedThing-} )
-import PprStyle -- ToDo:rm
-import Outputable -- ToDo:rm
-import PrelInfo ( builtinNameInfo, SYN_IE(BuiltinNames) )
+--import PprStyle -- ToDo:rm
+--import Outputable -- ToDo:rm
+import PrelInfo ( builtinNameMaps, builtinKeysMap, builtinTcNamesMap, SYN_IE(BuiltinNames) )
import Pretty
-import Maybes ( MaybeErr(..) )
import UniqFM ( emptyUFM )
import UniqSupply ( splitUniqSupply )
import Util ( sortLt, removeDups, cmpPString, startsWith,
- panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
+ panic, pprPanic, assertPanic{-, pprTrace ToDo:rm-} )
\end{code}
\begin{code}
type ModuleToIfaceContents = FiniteMap Module ParsedIface
type ModuleToIfaceFilePath = FiniteMap Module FilePath
+#if __GLASGOW_HASKELL__ >= 200
+# define REAL_WORLD RealWorld
+#else
+# define REAL_WORLD _RealWorld
+#endif
+
data IfaceCache
= IfaceCache
Module -- the name of the module being compiled
BuiltinNames -- so we can avoid going after things
-- the compiler already knows about
- (MutableVar _RealWorld
+ (MutableVar REAL_WORLD
(ModuleToIfaceContents, -- interfaces for individual interface files
ModuleToIfaceContents, -- merged interfaces based on module name
-- used for extracting info about original names
ModuleToIfaceFilePath))
initIfaceCache mod hi_files
- = newVar (emptyFM,emptyFM,hi_files) `thenPrimIO` \ iface_var ->
- return (IfaceCache mod b_names iface_var)
- where
- b_names = case builtinNameInfo of (b_names,_,_) -> b_names
+ = newVar (emptyFM,emptyFM,hi_files) ST_THEN \ iface_var ->
+ return (IfaceCache mod builtinNameMaps iface_var)
\end{code}
*********************************************************
-> IO (MaybeErr ParsedIface Error)
cachedIface (IfaceCache _ _ iface_var) want_orig_iface item modname
- = readVar iface_var `thenPrimIO` \ (iface_fm, orig_fm, file_fm) ->
+ = readVar iface_var ST_THEN \ (iface_fm, orig_fm, file_fm) ->
case (lookupFM iface_fm modname) of
Just iface -> return (want_iface iface orig_fm)
iface_fm' = addToFM iface_fm modname iface
orig_fm' = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface
in
- writeVar iface_var (iface_fm', orig_fm', file_fm) `seqPrimIO`
+ writeVar iface_var (iface_fm', orig_fm', file_fm) ST_THEN \ _ ->
return (want_iface iface orig_fm')
where
want_iface iface orig_fm
----------
mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs1 prags1)
(ParsedIface mod2 (_, files2) _ _ _ _ _ _ fixes2 tdefs2 vdefs2 idefs2 prags2)
- = pprTrace "mergeIfaces:" (ppCat [ppStr "import", ppCat (map ppPStr (bagToList files2)),
- ppStr "merged with", ppPStr mod1]) $
+ = --pprTrace "mergeIfaces:" (ppCat [ppStr "import", ppCat (map ppPStr (bagToList files2)),
+ -- ppStr "merged with", ppPStr mod1]) $
ASSERT(mod1 == mod2)
ParsedIface mod1
(True, unionBags files2 files1)
(panic "mergeIface: decl version numbers")
(panic "mergeIface: exports")
(panic "mergeIface: instance modules")
- (plusFM_C (dup_merge "fixity" (ppr PprDebug . fixDeclName)) fixes1 fixes2)
- (plusFM_C (dup_merge "tycon/class" (ppr PprDebug . idecl_nm)) tdefs1 tdefs2)
- (plusFM_C (dup_merge "value" (ppr PprDebug . idecl_nm)) vdefs1 vdefs2)
+ (plusFM_C (dup_merge {-"fixity" (ppr PprDebug . fixDeclName)-}) fixes1 fixes2)
+ (plusFM_C (dup_merge {-"tycon/class" (ppr PprDebug . idecl_nm)-}) tdefs1 tdefs2)
+ (plusFM_C (dup_merge {-"value" (ppr PprDebug . idecl_nm)-}) vdefs1 vdefs2)
(unionBags idefs1 idefs2)
- (plusFM_C (dup_merge "pragma" ppStr) prags1 prags2)
+ (plusFM_C (dup_merge {-"pragma" ppStr-}) prags1 prags2)
where
- dup_merge str ppr_dup dup1 dup2
- = pprTrace "mergeIfaces:"
- (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl",
- ppr_dup dup1, ppr_dup dup2]) $
+ dup_merge {-str ppr_dup-} dup1 dup2
+ = --pprTrace "mergeIfaces:"
+ -- (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl",
+ -- ppr_dup dup1, ppr_dup dup2]) $
dup2
idecl_nm (TypeSig n _ _) = n
case rn of
WiredInId _ -> return_failed (ifaceLookupWiredErr "value" rn)
WiredInTyCon _ -> return_failed (ifaceLookupWiredErr "type constructor" rn)
- RnUnbound _ -> pprPanic "cachedDeclByType:" (ppr PprDebug rn)
+ RnUnbound _ -> panic "cachedDeclByType:" -- (ppr PprDebug rn)
RnSyn _ -> return_maybe_decl
RnData _ _ _ -> return_maybe_decl
readIface file modname item
= --hPutStr stderr (" reading "++file++" ("++ _UNPK_ item ++")") >>
- readFile file `thenPrimIO` \ read_result ->
+ TRY_IO (readFile file) >>= \ read_result ->
case read_result of
Left err -> return (Failed (cannaeReadErr file err))
Right contents -> --hPutStr stderr ".." >>
cachedDeclByType iface_cache n >>= \ maybe_ans ->
case maybe_ans of
CachingAvoided _ ->
- pprTrace "do_decls:caching avoided:" (ppr PprDebug n) $
+ --pprTrace "do_decls:caching avoided:" (ppr PprDebug n) $
do_decls ns down to_return
CachingFail err -> -- add the error, but keep going:
add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us)
= case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) ->
- (if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $
+ --(if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $
-- ASSERT(isEmptyBag def_dups)
let
de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ]
| AddedSig RenamedSig
rnIfaceDecl :: RdrIfaceDecl
- -> RnM_Fixes _RealWorld
+ -> RnM_Fixes REAL_WORLD
(AddedDecl, -- the resulting decl to add to the pot
([(RdrName,RnName)], [(RdrName,RnName)]),
-- new val/tycon-class names that have
cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
cacheInstModules iface_cache@(IfaceCache _ _ iface_var) imp_mods
- = readVar iface_var `thenPrimIO` \ (iface_fm, _, _) ->
+ = readVar iface_var ST_THEN \ (iface_fm, _, _) ->
let
imp_ifaces = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
(imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
-- Assert that instance modules given by direct imports contains
-- instance modules extracted from all visited modules
- readVar iface_var `thenPrimIO` \ (all_iface_fm, _, _) ->
+ readVar iface_var ST_THEN \ (all_iface_fm, _, _) ->
let
all_ifaces = eltsFM all_iface_fm
(all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces))))
= -- all the instance decls we might even want to consider
-- are in the ParsedIfaces that are in our cache
- readVar iface_var `thenPrimIO` \ (_, orig_iface_fm, _) ->
+ readVar iface_var ST_THEN \ (_, orig_iface_fm, _) ->
let
all_ifaces = eltsFM orig_iface_fm
all_insts = concat (map get_insts all_ifaces)
Just _ -> True
Nothing -> -- maybe it's builtin
let orig = qualToOrigName nm in
- case (lookupFM b_tc_names orig) of
+ case (lookupFM builtinTcNamesMap orig) of
Just _ -> True
- Nothing -> maybeToBool (lookupFM b_keys orig)
-
- (b_tc_names, b_keys) -- pretty UGLY ...
- = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys)
-{-
- ppr_insts insts
- = ppAboves (map ppr_inst insts)
- where
- ppr_inst (InstSig c t _ inst_decl)
- = ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl]
--}
+ Nothing -> maybeToBool (lookupFM builtinKeysMap orig)
\end{code}
\begin{code}
-rnIfaceInst :: (Module, RdrIfaceInst) -> RnM_Fixes _RealWorld RenamedInstDecl
+rnIfaceInst :: (Module, RdrIfaceInst) -> RnM_Fixes REAL_WORLD RenamedInstDecl
rnIfaceInst (imod, InstSig _ _ _ inst_decl) = rnInstDecl (inst_decl imod)
\end{code}
-- pprTrace "usageIf:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
-- pprTrace "usageIf:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
-- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
- readVar iface_var `thenPrimIO` \ (_, orig_iface_fm, _) ->
+ readVar iface_var ST_THEN \ (_, orig_iface_fm, _) ->
let
all_ifaces = eltsFM orig_iface_fm
-- all the interfaces we have looked at
= ppBesides [ppPStr SLIT("Why am I looking up a wired-in "), ppStr msg, ppChar ':', ppr sty n]
badIfaceLookupErr msg name decl sty
- = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")]
+ = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppStr " declaration, but got this: ???"]
ifaceIoErr io_msg rn sty
= ppBesides [io_msg sty, ppStr "; looking for: ", ppr sty rn]
projects / ghc-hetmet.git / blobdiff