Yet another wibble to checkHiBootIface; it's trickier than it looks!

[ghc-hetmet.git] / compiler / typecheck / TcRnDriver.lhs

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index f428853..fafb7c7 100644 (file)
--- 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
 
@@ -502,44 +504,61 @@ 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)
+                               ppr boot_exports)) ;
+
+               -- Check the exports of the boot module, one by one
+       ; mapM_ check_export boot_exports
+
+               -- Check instance declarations
        ; dfun_binds <- mapM check_inst boot_insts
+
+               -- 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 }) }
   where
-    check_export name  -- Name 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)
-      | isImplicitTyThing boot_thing = return ()
+    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 (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)
+      | isNothing mb_boot_thing = return ()
+
+       -- Check that the actual module also defines the thing, and 
+       -- then compare the definitions
       | Just real_thing <- lookupTypeEnv local_type_env name
-      = do { checkTc (name `elemNameSet` local_export_set)
-                    (missingBootThing boot_thing "exported by")
-
-          ; let boot_decl = tyThingToIfaceDecl boot_thing
+      = do { let boot_decl = tyThingToIfaceDecl (fromJust mb_boot_thing)
                 real_decl = tyThingToIfaceDecl real_thing
           ; checkTc (checkBootDecl boot_decl real_decl)
-                    (bootMisMatch boot_thing boot_decl real_decl) }
+                    (bootMisMatch real_thing boot_decl real_decl) }
                -- The easiest way to check compatibility is to convert to
                -- iface syntax, where we already have good comparison functions
 
       | otherwise
-      = addErrTc (missingBootThing boot_thing "defined in")
+      = addErrTc (missingBootThing name "defined in")
       where
-       boot_thing = lookupTypeEnv boot_type_env name
-                    `orElse` pprPanic "checkHiBootIface" (ppr name)
-
+       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 boot_inst
        = case [dfun | inst <- local_insts,