Make the LiberateCase transformation understand associated types

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

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 156b52f..eabd3bc 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -302,6 +302,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
                                mg_types     = final_type_env,
                                mg_insts     = tcg_insts tcg_env,
                                mg_fam_insts = tcg_fam_insts tcg_env,
+                               mg_fam_inst_env = tcg_fam_inst_env tcg_env,
                                mg_rules     = [],
                                mg_binds     = core_binds,
 
@@ -396,15 +397,16 @@ tc_rn_src_decls boot_details ds
 
        -- Deal with decls up to, but not including, the first splice
        (tcg_env, rn_decls) <- checkNoErrs $ rnTopSrcDecls first_group ;
-               -- checkNoErrs: don't typecheck if renaming failed
-       tc_envs <- setGblEnv tcg_env $ 
-                  tcTopSrcDecls boot_details rn_decls ;
+               -- checkNoErrs: stop if renaming fails
+
+       (tcg_env, tcl_env) <- setGblEnv tcg_env $ 
+                             tcTopSrcDecls boot_details rn_decls ;
 
        -- If there is no splice, we're nearly done
-       setEnvs tc_envs $ 
+       setEnvs (tcg_env, tcl_env) $ 
        case group_tail of {
           Nothing -> do { tcg_env <- checkMain ;       -- Check for `main'
-                          return (tcg_env, snd tc_envs) 
+                          return (tcg_env, tcl_env) 
                      } ;
 
        -- If there's a splice, we must carry on
@@ -1092,19 +1094,32 @@ tcRnType hsc_env ictxt rdr_type
 -- could not be found.
 getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo])
 getModuleExports hsc_env mod
-  = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod)
-
-tcGetModuleExports :: Module -> TcM [AvailInfo]
-tcGetModuleExports mod = do
-  let doc = ptext SLIT("context for compiling statements")
-  iface <- initIfaceTcRn $ loadSysInterface doc mod
-  loadOrphanModules (dep_orphs (mi_deps iface)) False 
-               -- Load any orphan-module interfaces,
-               -- so their instances are visible
-  loadOrphanModules (dep_finsts (mi_deps iface)) True
-               -- Load any family instance-module interfaces,
-               -- so all family instances are visible
-  ifaceExportNames (mi_exports iface)
+  = let
+      ic        = hsc_IC hsc_env
+      checkMods = ic_toplev_scope ic ++ ic_exports ic
+    in
+    initTc hsc_env HsSrcFile 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
+-- interactive context are consistent (these modules are in the second
+-- argument).
+tcGetModuleExports :: Module -> [Module] -> TcM [AvailInfo]
+tcGetModuleExports mod directlyImpMods
+  = do { let doc = ptext SLIT("context for compiling statements")
+       ; iface <- initIfaceTcRn $ loadSysInterface doc mod
+
+               -- Load any orphan-module and family instance-module
+               -- interfaces, so their instances are visible.
+       ; loadOrphanModules (dep_orphs (mi_deps iface)) False 
+       ; loadOrphanModules (dep_finsts (mi_deps iface)) True
+
+                -- Check that the family instances of all directly loaded
+                -- modules are consistent.
+       ; checkFamInstConsistency (dep_finsts (mi_deps iface)) directlyImpMods
+
+       ; ifaceExportNames (mi_exports iface)
+       }
 
 tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
 tcRnLookupRdrName hsc_env rdr_name