[project @ 2000-11-20 16:07:12 by simonpj]
[ghc-hetmet.git] / ghc / compiler / rename / RnHiFiles.lhs
index 7a2cd23..4c3b864 100644 (file)
@@ -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,10 +26,9 @@ import HscTypes              ( ModuleLocation(..),
                          DeclsMap, GatedDecl, IfaceInsts, IfaceRules,
                          AvailInfo, GenAvailInfo(..), Avails, Deprecations(..)
                         )
-import HsSyn           ( HsDecl(..), TyClDecl(..), InstDecl(..),
-                         HsType(..), ConDecl(..), 
-                         FixitySig(..), RuleDecl(..),
-                         tyClDeclNames
+import HsSyn           ( TyClDecl(..), InstDecl(..),
+                         HsType(..), FixitySig(..), RuleDecl(..),
+                         tyClDeclNames, tyClDeclSysNames
                        )
 import RdrHsSyn                ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl,
                          extractHsTyRdrNames 
@@ -50,20 +49,19 @@ import Module               ( Module,
                          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 Config
 
-import Monad           ( when )
+import Directory
 \end{code}
 
 
@@ -112,8 +110,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 +181,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 ->
@@ -283,13 +289,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
@@ -321,13 +324,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.
        -- 
@@ -340,9 +348,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 lookupIfaceName free_names   `thenRn` \ gate_names ->
-    returnRn ((gate_names, (mod, InstD decl)) `consBag` insts)
+    returnRn ((gate_names, (mod, decl)) `consBag` insts)
 
 
 -- In interface files, the instance decls now look like
@@ -363,20 +370,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)
   = lookupIfaceName var                `thenRn` \ var_name ->
-    returnRn ([var_name], (mod, RuleD decl))
+    returnRn ([var_name], (mod, decl))
 
 
 -----------------------------------------------------
@@ -415,45 +422,31 @@ getIfaceDeclBinders, getTyClDeclBinders
        -> RdrNameTyClDecl
        -> RnM d AvailInfo
 
-getIfaceDeclBinders mod tycl_decl
-  = getTyClDeclBinders    mod tycl_decl        `thenRn` \ avail ->
-    getSysTyClDeclBinders mod tycl_decl        `thenRn` \ extras ->
-    returnRn (addSysAvails avail extras)
-               -- Add the sys-binders to avail.  When we import the decl,
-               -- it's full_avail that will get added to the 'already-slurped' set (iSlurp)
-               -- If we miss out sys-binders, we'll read the decl multiple times!
-
+-----------------
 getTyClDeclBinders mod (IfaceSig var ty prags src_loc)
   = newTopBinder mod var src_loc                       `thenRn` \ var_name ->
     returnRn (Avail var_name)
 
 getTyClDeclBinders mod tycl_decl
-  = mapRn do_one (tyClDeclNames tycl_decl)     `thenRn` \ (main_name:sub_names) ->
+  = new_top_bndrs mod (tyClDeclNames tycl_decl)                `thenRn` \ (main_name:sub_names) ->
     returnRn (AvailTC main_name (main_name : sub_names))
-  where
-    do_one (name,loc) = newTopBinder mod name loc
-\end{code}
-
-@getDeclSysBinders@ gets the implicit binders introduced by a decl.
-A the moment that's just the tycon and datacon that come with a class decl.
-They aren't returned by @getDeclBinders@ because they aren't in scope;
-but they {\em should} be put into the @DeclsMap@ of this module.
-
-Note that this excludes the default-method names of a class decl,
-and the dict fun of an instance decl, because both of these have 
-bindings of their own elsewhere.
 
-\begin{code}
-getSysTyClDeclBinders mod (ClassDecl _ cname _ _ sigs _ names src_loc)
-  = sequenceRn [newTopBinder mod n src_loc | n <- names]
+-----------------
+getIfaceDeclBinders mod (IfaceSig var ty prags src_loc)
+  = newTopBinder mod var src_loc                       `thenRn` \ var_name ->
+    returnRn (Avail var_name)
 
-getSysTyClDeclBinders mod (TyData _ _ _ _ cons _ _ _ _ _)
-  = sequenceRn [newTopBinder mod wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
+getIfaceDeclBinders mod tycl_decl
+  = new_top_bndrs mod (tyClDeclNames tycl_decl)                `thenRn` \ (main_name:sub_names) ->
+    new_top_bndrs mod (tyClDeclSysNames tycl_decl)     `thenRn` \ sys_names ->
+    returnRn (AvailTC main_name (main_name : (sys_names ++ sub_names)))
 
-getSysTyClDeclBinders mod other_decl
-  = returnRn []
+-----------------
+new_top_bndrs mod names_w_locs
+  = sequenceRn [newTopBinder mod name loc | (name,loc) <- names_w_locs]
 \end{code}
 
+
 %*********************************************************
 %*                                                     *
 \subsection{Reading an interface file}
@@ -470,24 +463,21 @@ 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 ->
+        -> mkHiPath hi_boot_file locn `thenRn` \ file -> 
+          readIface file `thenRn` \ read_result ->
           case read_result of
-              Left bad -> returnRn (Left bad)
-              Right iface 
-                 -> let read_mod = pi_mod iface
-                   in warnCheckRn (wanted_mod == read_mod)
-                                  (hiModuleNameMismatchWarn wanted_mod read_mod) 
-                                       `thenRn_`
-                      returnRn (Right (wanted_mod, iface))
+                Left bad -> returnRn (Left bad)
+                Right iface 
+                   -> let read_mod = pi_mod iface
+                     in warnCheckRn (wanted_mod == read_mod)
+                                    (hiModuleNameMismatchWarn wanted_mod 
+                                       read_mod) `thenRn_`
+                        returnRn (Right (wanted_mod, iface))
        -- Can't find it
       other   -> traceRn (ptext SLIT("...not found"))  `thenRn_`
                 returnRn (Left (noIfaceErr mod_name hi_boot_file))
@@ -498,35 +488,48 @@ 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 locn
+  | hi_boot_file = 
+       ioToRnM_no_fail (doesFileExist hi_boot_ver_path) `thenRn` \ b ->
+       if b then returnRn hi_boot_ver_path
+            else returnRn hi_boot_path
+  | otherwise    = returnRn hi_path
+       where (Just hi_path)   = ml_hi_file locn
+             hi_boot_path     = hi_path ++ "-boot"
+             hi_boot_ver_path = hi_path ++ "-boot-" ++ cHscIfaceFileVersion
 \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}