X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnHiFiles.lhs;h=ad4f8c1e453a4ad0161ed4632be794a0bee5ae88;hb=00fe57d46c18e83674cc17c77643164289abdef5;hp=ca381a37ba1bce113a419eaec7449c793f36713d;hpb=88f315a135bd00d2efa00d991bb9487929562d91;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index ca381a3..ad4f8c1 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -17,7 +17,7 @@ module RnHiFiles ( #include "HsVersions.h" -import CmdLineOpts ( DynFlag(..), opt_IgnoreIfacePragmas ) +import CmdLineOpts ( opt_IgnoreIfacePragmas ) import HscTypes ( ModuleLocation(..), ModIface(..), emptyModIface, VersionInfo(..), @@ -26,7 +26,7 @@ import HscTypes ( ModuleLocation(..), DeclsMap, GatedDecl, IfaceInsts, IfaceRules, AvailInfo, GenAvailInfo(..), Avails, Deprecations(..) ) -import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), +import HsSyn ( TyClDecl(..), InstDecl(..), HsType(..), ConDecl(..), FixitySig(..), RuleDecl(..), tyClDeclNames @@ -42,28 +42,24 @@ import ParseIface ( parseIface, IfaceStuff(..) ) import Name ( Name {-instance NamedThing-}, nameOccName, nameModule, isLocalName, nameIsLocalOrFrom, NamedThing(..), - mkNameEnv, extendNameEnv ) +import Name ( mkNameEnv, extendNameEnv ) import Module ( Module, moduleName, isModuleInThisPackage, ModuleName, WhereFrom(..), extendModuleEnv, mkVanillaModule ) import RdrName ( RdrName, rdrNameOcc ) -import NameSet import SrcLoc ( mkSrcLoc ) import Maybes ( maybeToBool, orElse ) import StringBuffer ( hGetStringBuffer ) import FastString ( mkFastString ) import ErrUtils ( Message ) import Finder ( findModule ) -import Util ( unJust ) import Lex import FiniteMap import Outputable import Bag - -import Monad ( when ) \end{code} @@ -112,8 +108,16 @@ tryLoadInterface doc_str mod_name from -- CHECK WHETHER WE HAVE IT ALREADY case lookupIfaceByModName hit pit mod_name of { - Just iface -> returnRn (iface, Nothing) ; -- Already loaded - Nothing -> + Just iface | case from of + ImportByUser -> not (mi_boot iface) + ImportByUserSource -> mi_boot iface + ImportBySystem -> True + -> returnRn (iface, Nothing) ; -- Already loaded + -- The not (mi_boot iface) test checks that the already-loaded + -- interface isn't a boot iface. This can conceivably happen, + -- if the version checking happened to load a boot interface + -- before we got to real imports. + other -> let mod_map = iImpModInfo ifaces @@ -175,7 +179,7 @@ tryLoadInterface doc_str mod_name from loadDecls mod (iDecls ifaces) (pi_decls iface) `thenRn` \ (decls_vers, new_decls) -> loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ (rule_vers, new_rules) -> - foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> + loadInstDecls mod (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) -> loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env -> loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env -> @@ -263,24 +267,6 @@ loadExports (vers, items) loadExport :: Module -> ExportItem -> RnM d (ModuleName, Avails) loadExport this_mod (mod, entities) - | mod == moduleName this_mod = returnRn (mod, []) - -- If the module exports anything defined in this module, just ignore it. - -- Reason: otherwise it looks as if there are two local definition sites - -- for the thing, and an error gets reported. Easiest thing is just to - -- filter them out up front. This situation only arises if a module - -- imports itself, or another module that imported it. (Necessarily, - -- this invoves a loop.) Consequence: if you say - -- module A where - -- import B( AType ) - -- type AType = ... - -- - -- module B( AType ) where - -- import {-# SOURCE #-} A( AType ) - -- - -- then you'll get a 'B does not export AType' message. A bit bogus - -- but it's a bogus thing to do! - - | otherwise = mapRn (load_entity mod) entities `thenRn` \ avails -> returnRn (mod, avails) where @@ -301,13 +287,10 @@ loadDecls :: Module -> DeclsMap -> [(Version, RdrNameTyClDecl)] -> RnM d (NameEnv Version, DeclsMap) -loadDecls mod decls_map decls - = foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls +loadDecls mod (decls_map, n_slurped) decls + = foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls `thenRn` \ (vers, decls_map') -> + returnRn (vers, (decls_map', n_slurped)) -loadDecl :: Module - -> (NameEnv Version, DeclsMap) - -> (Version, RdrNameTyClDecl) - -> RnM d (NameEnv Version, DeclsMap) loadDecl mod (version_map, decls_map) (version, decl) = getIfaceDeclBinders mod decl `thenRn` \ full_avail -> let @@ -339,13 +322,18 @@ loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc) -- Loading instance decls ----------------------------------------------------- -loadInstDecl :: Module - -> IfaceInsts - -> RdrNameInstDecl - -> RnM d IfaceInsts -loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) - = - -- Find out what type constructors and classes are "gates" for the +loadInstDecls :: Module + -> IfaceInsts + -> [RdrNameInstDecl] + -> RnM d IfaceInsts +loadInstDecls mod (insts, n_slurped) decls + = setModuleRn mod $ + foldlRn (loadInstDecl mod) insts decls `thenRn` \ insts' -> + returnRn (insts', n_slurped) + + +loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) + = -- Find out what type constructors and classes are "gates" for the -- instance declaration. If all these "gates" are slurped in then -- we should slurp the instance decl too. -- @@ -358,9 +346,8 @@ loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) munged_inst_ty = removeContext inst_ty free_names = extractHsTyRdrNames munged_inst_ty in - setModuleRn mod $ - mapRn lookupOrigName free_names `thenRn` \ gate_names -> - returnRn ((mkNameSet gate_names, (mod, InstD decl)) `consBag` insts) + mapRn lookupIfaceName free_names `thenRn` \ gate_names -> + returnRn ((gate_names, (mod, decl)) `consBag` insts) -- In interface files, the instance decls now look like @@ -381,20 +368,20 @@ removeFuns ty = ty loadRules :: Module -> IfaceRules -> (Version, [RdrNameRuleDecl]) -> RnM d (Version, IfaceRules) -loadRules mod rule_bag (version, rules) +loadRules mod (rule_bag, n_slurped) (version, rules) | null rules || opt_IgnoreIfacePragmas - = returnRn (version, rule_bag) + = returnRn (version, (rule_bag, n_slurped)) | otherwise = setModuleRn mod $ mapRn (loadRule mod) rules `thenRn` \ new_rules -> - returnRn (version, rule_bag `unionBags` listToBag new_rules) + returnRn (version, (rule_bag `unionBags` listToBag new_rules, n_slurped)) -loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl +loadRule :: Module -> RdrNameRuleDecl -> RnM d (GatedDecl RdrNameRuleDecl) -- "Gate" the rule simply by whether the rule variable is -- needed. We can refine this later. loadRule mod decl@(IfaceRule _ _ var _ _ src_loc) - = lookupOrigName var `thenRn` \ var_name -> - returnRn (unitNameSet var_name, (mod, RuleD decl)) + = lookupIfaceName var `thenRn` \ var_name -> + returnRn ([var_name], (mod, decl)) ----------------------------------------------------- @@ -408,7 +395,7 @@ loadDeprecs m (Just (Right prs)) = setModuleRn m $ foldlRn loadDeprec emptyNameEnv prs `thenRn` \ env -> returnRn (DeprecSome env) loadDeprec deprec_env (n, txt) - = lookupOrigName n `thenRn` \ name -> + = lookupIfaceName n `thenRn` \ name -> traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenRn_` returnRn (extendNameEnv deprec_env name (name,txt)) \end{code} @@ -488,16 +475,12 @@ findAndReadIface :: SDoc -> ModuleName findAndReadIface doc_str mod_name hi_boot_file = traceRn trace_msg `thenRn_` + ioToRnM (findModule mod_name) `thenRn` \ maybe_found -> - doptRn Opt_D_dump_rn_trace `thenRn` \ rn_trace -> case maybe_found of + Right (Just (wanted_mod,locn)) - -> ioToRnM_no_fail ( - readIface rn_trace - (unJust (ml_hi_file locn) "findAndReadIface" - ++ if hi_boot_file then "-boot" else "") - ) - `thenRn` \ read_result -> + -> readIface (mkHiPath hi_boot_file (ml_hi_file locn)) `thenRn` \ read_result -> case read_result of Left bad -> returnRn (Left bad) Right iface @@ -516,35 +499,42 @@ findAndReadIface doc_str mod_name hi_boot_file ptext SLIT("interface for"), ppr mod_name <> semi], nest 4 (ptext SLIT("reason:") <+> doc_str)] + +mkHiPath hi_boot_file (Just path) + | hi_boot_file = path ++ "-boot-5" + | otherwise = path \end{code} @readIface@ tries just the one file. \begin{code} -readIface :: Bool -> String -> IO (Either Message ParsedIface) +readIface :: String -> RnM d (Either Message ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -readIface tr file_path - = when tr (printErrs (ptext SLIT("readIFace") <+> text file_path)) - >> - ((hGetStringBuffer False file_path >>= \ contents -> - case parseIface contents - PState{ bol = 0#, atbol = 1#, +readIface file_path + = traceRn (ptext SLIT("readIFace") <+> text file_path) `thenRn_` + + ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result -> + case read_result of { + Left io_error -> bale_out (text (show io_error)) ; + Right contents -> + + case parseIface contents init_parser_state of + POk _ (PIface iface) -> returnRn (Right iface) + PFailed err -> bale_out err + parse_result -> bale_out empty + -- This last case can happen if the interface file is (say) empty + -- in which case the parser thinks it looks like an IdInfo or + -- something like that. Just an artefact of the fact that the + -- parser is used for several purposes at once. + } + where + init_parser_state = PState{ bol = 0#, atbol = 1#, context = [], glasgow_exts = 1#, - loc = mkSrcLoc (mkFastString file_path) 1 } of - POk _ (PIface iface) -> return (Right iface) - PFailed err -> bale_out err - parse_result -> bale_out empty - -- This last case can happen if the interface file is (say) empty - -- in which case the parser thinks it looks like an IdInfo or - -- something like that. Just an artefact of the fact that the - -- parser is used for several purposes at once. - ) - `catch` - (\ io_err -> bale_out (text (show io_err)))) - where - bale_out err = return (Left (badIfaceFile file_path err)) + loc = mkSrcLoc (mkFastString file_path) 1 } + + bale_out err = returnRn (Left (badIfaceFile file_path err)) \end{code}