X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=4e0f283cdd2cb757d5fd4744c49b39407e05a55d;hb=9ac57e65bb77638ff7d5e7148ee5c3d80b25cf7d;hp=a4a94edfa4c9563079cfd4bf95b735d3d0357456;hpb=172c59ac185635371db901542de83a9bd4fe76b6;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index a4a94ed..4e0f283 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -65,10 +65,12 @@ import Var
 import Module
 import UniqFM
 import Name
+import NameEnv
 import NameSet
 import TyCon
 import SrcLoc
 import HscTypes
+import ListSetOps
 import Outputable
 import Breakpoints
 
@@ -87,7 +89,6 @@ import TysWiredIn
 import IdInfo
 import {- Kind parts of -} Type
 import BasicTypes
-import Data.Maybe
 #endif
 
 import FastString
@@ -96,7 +97,6 @@ import Util
 import Bag
 
 import Control.Monad    ( unless )
-import Data.Maybe	( isJust )
 \end{code}
 
 
@@ -169,6 +169,11 @@ tcRnModule hsc_env hsc_src save_rn_syntax
 	-- Must be done after processing the exports
  	tcg_env <- checkHiBootIface tcg_env boot_iface ;
 
+	-- Make the new type env available to stuff slurped from interface files
+	-- Must do this after checkHiBootIface, because the latter might add new
+	-- bindings for boot_dfuns, which may be mentioned in imported unfoldings
+	writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
+
 		-- Rename the Haddock documentation 
 	tcg_env <- rnHaddock module_info maybe_doc tcg_env ;
 
@@ -373,9 +378,6 @@ tcRnSrcDecls boot_iface decls
 				   tcg_rules = rules', 
 				   tcg_fords = fords' } } ;
 
-	-- Make the new type env available to stuff slurped from interface files
-	writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
-
 	return (tcg_env' { tcg_binds = tcg_binds tcg_env' }) 
    }
 
@@ -502,26 +504,39 @@ checkHiBootIface
 
   | otherwise
   = do	{ traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts $$ 
-				ppr local_export_set $$ ppr boot_exports)) ;
-	; mapM_ check_export (concatMap availNames boot_exports)
-	; dfun_binds <- mapM check_inst boot_insts
+				ppr boot_exports)) ;
+
+		-- Check the exports of the boot module, one by one
+	; mapM_ check_export boot_exports
+
+		-- Check instance declarations
+	; mb_dfun_prs <- mapM check_inst boot_insts
+	; let tcg_env' = tcg_env { tcg_binds    = binds `unionBags` dfun_binds,
+				   tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns }
+	      dfun_prs   = catMaybes mb_dfun_prs
+	      boot_dfuns = map fst dfun_prs
+	      dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun)
+				     | (boot_dfun, dfun) <- dfun_prs ]
+
+		-- Check for no family instances
 	; unless (null boot_fam_insts) $
 	    panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
 		   "instances in boot files yet...")
             -- FIXME: Why?  The actual comparison is not hard, but what would
             --	      be the equivalent to the dfun bindings returned for class
             --	      instances?  We can't easily equate tycons...
-	; return (tcg_env { tcg_binds = binds `unionBags` unionManyBags dfun_binds }) }
+
+	; return tcg_env' }
   where
-    check_export name	-- Name is exported by the boot iface
+    check_export boot_avail	-- boot_avail is exported by the boot iface
       | name `elem` dfun_names = return ()	
       | isWiredInName name     = return ()	-- No checking for wired-in names.  In particular,
 						-- 'error' is handled by a rather gross hack
 						-- (see comments in GHC.Err.hs-boot)
 
 	-- Check that the actual module exports the same thing
-      | not (name `elemNameSet` local_export_set)
-      = addErrTc (missingBootThing name "exported by")
+      | not (null missing_names)
+      = addErrTc (missingBootThing (head missing_names) "exported by")
 
 	-- If the boot module does not *define* the thing, we are done
 	-- (it simply re-exports it, and names match, so nothing further to do)
@@ -540,19 +555,25 @@ checkHiBootIface
       | otherwise
       = addErrTc (missingBootThing name "defined in")
       where
+	name          = availName boot_avail
 	mb_boot_thing = lookupTypeEnv boot_type_env name
+	missing_names = case lookupNameEnv local_export_env name of
+			  Nothing    -> [name]
+			  Just avail -> availNames boot_avail `minusList` availNames avail
 		 
     dfun_names = map getName boot_insts
 
-    local_export_set :: NameSet
-    local_export_set = availsToNameSet local_exports
+    local_export_env :: NameEnv AvailInfo
+    local_export_env = availsToNameEnv local_exports
 
+    check_inst :: Instance -> TcM (Maybe (Id, Id))
+	-- Returns a pair of the boot dfun in terms of the equivalent real dfun
     check_inst boot_inst
 	= case [dfun | inst <- local_insts, 
 		       let dfun = instanceDFunId inst,
 		       idType dfun `tcEqType` boot_inst_ty ] of
-	    [] -> do { addErrTc (instMisMatch boot_inst); return emptyBag }
-	    (dfun:_) -> return (unitBag $ noLoc $ VarBind local_boot_dfun (nlHsVar dfun))
+	    [] -> do { addErrTc (instMisMatch boot_inst); return Nothing }
+	    (dfun:_) -> return (Just (local_boot_dfun, dfun))
 	where
 	  boot_dfun = instanceDFunId boot_inst
 	  boot_inst_ty = idType boot_dfun
@@ -1115,7 +1136,7 @@ getModuleExports hsc_env mod
       ic        = hsc_IC hsc_env
       checkMods = ic_toplev_scope ic ++ ic_exports ic
     in
-    initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod checkMods)
+    initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods)
 
 -- Get the export avail info and also load all orphan and family-instance
 -- modules.  Finally, check that the family instances of all modules in the