[project @ 2005-04-16 22:47:23 by simonpj]

Significant clean-up of the handling of hi-boot files.
Previously, when compling A.hs, we loaded A.hi-boot, and
it went into the External Package Table.  It was strange
but it worked.  This tidy up stops it going anywhere;
it's just read in, and typechecked into a ModDetails.

All this was on the way to improving the handling of
instances in hs-boot files, something Chris Ryder wanted.
I think they work quite sensibly now.

If I've got all this right (have not had a chance to
fully test it) we can merge it into STABLE.

diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs
index d36dce4..d55b5e2 100644 (file)
--- a/ghc/compiler/iface/IfaceEnv.lhs
+++ b/ghc/compiler/iface/IfaceEnv.lhs
@@ -4,11 +4,13 @@
 module IfaceEnv (
        newGlobalBinder, newIPName, newImplicitBinder, 
        lookupIfaceTop, lookupIfaceExt,
 module IfaceEnv (
        newGlobalBinder, newIPName, newImplicitBinder, 
        lookupIfaceTop, lookupIfaceExt,

-       lookupOrig, lookupAvail, lookupIfaceTc,
+       lookupOrig, lookupIfaceTc,

        newIfaceName, newIfaceNames,
        extendIfaceIdEnv, extendIfaceTyVarEnv,
        tcIfaceLclId,     tcIfaceTyVar, 
 
        newIfaceName, newIfaceNames,
        extendIfaceIdEnv, extendIfaceTyVarEnv,
        tcIfaceLclId,     tcIfaceTyVar, 
 

+       lookupAvail, ifaceExportNames,
+

        -- Name-cache stuff
        allocateGlobalBinder, initNameCache, 
    ) where
        -- Name-cache stuff
        allocateGlobalBinder, initNameCache, 
    ) where

@@ -18,7 +20,8 @@ module IfaceEnv (
 import TcRnMonad
 import IfaceType       ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
 import TysWiredIn      ( tupleTyCon, tupleCon )
 import TcRnMonad
 import IfaceType       ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName )
 import TysWiredIn      ( tupleTyCon, tupleCon )

-import HscTypes                ( NameCache(..), HscEnv(..), GenAvailInfo(..), OrigNameCache )
+import HscTypes                ( NameCache(..), HscEnv(..), GenAvailInfo(..), 
+                         IfaceExport, OrigNameCache )

 import TyCon           ( TyCon, tyConName )
 import DataCon         ( dataConWorkId, dataConName )
 import Var             ( TyVar, Id, varName )
 import TyCon           ( TyCon, tyConName )
 import DataCon         ( dataConWorkId, dataConName )
 import Var             ( TyVar, Id, varName )

@@ -27,7 +30,7 @@ import Name           ( Name, nameUnique, nameModule,
                          getOccName, nameParent_maybe,
                          isWiredInName, mkIPName,
                          mkExternalName, mkInternalName )
                          getOccName, nameParent_maybe,
                          isWiredInName, mkIPName,
                          mkExternalName, mkInternalName )

-
+import NameSet         ( NameSet, emptyNameSet, addListToNameSet )

 import OccName         ( OccName, isTupleOcc_maybe, tcName, dataName,
                          lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
 import PrelNames       ( gHC_PRIM, pREL_TUP )
 import OccName         ( OccName, isTupleOcc_maybe, tcName, dataName,
                          lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
 import PrelNames       ( gHC_PRIM, pREL_TUP )

@@ -127,6 +130,14 @@ newImplicitBinder base_name mk_sys_occ
                    Just parent_name  -> parent_name
                    Nothing           -> base_name
 
                    Just parent_name  -> parent_name
                    Nothing           -> base_name
 

+ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl NameSet
+ifaceExportNames exports 
+  = foldlM do_one emptyNameSet exports
+  where
+    do_one acc (mod, exports)  = foldlM (do_avail mod) acc exports
+    do_avail mod acc avail = do { ns <- lookupAvail mod avail
+                               ; return (addListToNameSet acc ns) }
+

 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b [Name]
 -- Find all the names arising from an import
 -- Make sure the parent info is correct, even though we may not
 lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b [Name]
 -- Find all the names arising from an import
 -- Make sure the parent info is correct, even though we may not

diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs
index 20142bf..28c9770 100644 (file)
--- a/ghc/compiler/iface/LoadIface.lhs
+++ b/ghc/compiler/iface/LoadIface.lhs
@@ -6,8 +6,8 @@
 \begin{code}
 module LoadIface (
        loadHomeInterface, loadInterface, loadDecls,
 \begin{code}
 module LoadIface (
        loadHomeInterface, loadInterface, loadDecls,

-       loadSrcInterface, loadOrphanModules, loadHiBootInterface,
-       readIface,      -- Used when reading the module's old interface
+       loadSrcInterface, loadOrphanModules, 
+       findAndReadIface, readIface,    -- Used when reading the module's old interface

        predInstGates, ifaceInstGates, ifaceStats, discardDeclPrags,
        initExternalPackageState
    ) where
        predInstGates, ifaceInstGates, ifaceStats, discardDeclPrags,
        initExternalPackageState
    ) where

@@ -83,52 +83,16 @@ loadSrcInterface :: SDoc -> Module -> IsBootInterface -> RnM ModIface
 -- This is called for each 'import' declaration in the source code
 -- On a failure, fail in the monad with an error message
 
 -- This is called for each 'import' declaration in the source code
 -- On a failure, fail in the monad with an error message
 

-loadSrcInterface doc mod_name want_boot
-  = do         { mb_iface <- initIfaceTcRn $ loadInterface doc mod_name 
-                                          (ImportByUser want_boot)
+loadSrcInterface doc mod want_boot
+  = do         { mb_iface <- initIfaceTcRn $ 
+                     loadInterface doc mod (ImportByUser want_boot)

        ; case mb_iface of
        ; case mb_iface of

-           Failed err      -> failWithTc (elaborate err) 
+           Failed err      -> failWithTc (elaborate err)

            Succeeded iface -> return iface
        }
   where
     elaborate err = hang (ptext SLIT("Failed to load interface for") <+> 
            Succeeded iface -> return iface
        }
   where
     elaborate err = hang (ptext SLIT("Failed to load interface for") <+> 

-                        quotes (ppr mod_name) <> colon) 4 err
-
-loadHiBootInterface :: TcRn [Name]
--- Load the hi-boot iface for the module being compiled,
--- if it indeed exists in the transitive closure of imports
--- Return the list of names exported by the hi-boot file
-loadHiBootInterface
-  = do         { eps <- getEps
-       ; mod <- getModule
-
-       ; traceIf (text "loadHiBootInterface" <+> ppr mod)
-
-       -- We're read all the direct imports by now, so eps_is_boot will
-       -- record if any of our imports mention us by way of hi-boot file
-       ; case lookupModuleEnv (eps_is_boot eps) mod of {
-           Nothing             -> return [] ;  -- The typical case
-
-           Just (_, False) ->          -- Someone below us imported us!
-               -- This is a loop with no hi-boot in the way
-               failWithTc (moduleLoop mod) ;
-
-           Just (mod_nm, True) ->      -- There's a hi-boot interface below us
-               
-
-    do {       -- Load it (into the PTE), and return the exported names
-         iface <- loadSrcInterface (mk_doc mod_nm) mod_nm True
-       ; ns_s <-  sequenceM [ lookupAvail mod_nm avail
-                            | (mod,avails) <- mi_exports iface, 
-                              avail <- avails ]
-       ; return (concat ns_s)
-    }}}
-  where
-    mk_doc mod = ptext SLIT("Need the hi-boot interface for") <+> ppr mod
-                <+> ptext SLIT("to compare against the Real Thing")
-
-    moduleLoop mod = ptext SLIT("Circular imports: module") <+> quotes (ppr mod) 
-                    <+> ptext SLIT("depends on itself")
+                         quotes (ppr mod) <> colon) 4 err

 
 loadOrphanModules :: [Module] -> TcM ()
 loadOrphanModules mods
 
 loadOrphanModules :: [Module] -> TcM ()
 loadOrphanModules mods

@@ -551,7 +515,7 @@ findAndReadIface :: Bool            -- True <=> explicit user import
                 -> SDoc -> Module 
                 -> IsBootInterface     -- True  <=> Look for a .hi-boot file
                                        -- False <=> Look for .hi file
                 -> SDoc -> Module 
                 -> IsBootInterface     -- True  <=> Look for a .hi-boot file
                                        -- False <=> Look for .hi file

-                -> IfM lcl (MaybeErr Message (ModIface, FilePath))
+                -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath))

        -- Nothing <=> file not found, or unreadable, or illegible
        -- Just x  <=> successfully found and parsed 
 
        -- Nothing <=> file not found, or unreadable, or illegible
        -- Just x  <=> successfully found and parsed 
 

@@ -626,7 +590,7 @@ findHiFile hsc_env explicit mod_name hi_boot_file
 
 \begin{code}
 readIface :: Module -> String -> IsBootInterface 
 
 \begin{code}
 readIface :: Module -> String -> IsBootInterface 

-         -> IfM lcl (MaybeErr Message ModIface)
+         -> TcRnIf gbl lcl (MaybeErr Message ModIface)

        -- Failed err    <=> file not found, or unreadable, or illegible
        -- Succeeded iface <=> successfully found and parsed 
 
        -- Failed err    <=> file not found, or unreadable, or illegible
        -- Succeeded iface <=> successfully found and parsed 
 

diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs
index a2cfbed..195e99d 100644 (file)
--- a/ghc/compiler/iface/TcIface.lhs
+++ b/ghc/compiler/iface/TcIface.lhs
@@ -5,7 +5,8 @@
 
 \begin{code}
 module TcIface ( 
 
 \begin{code}
 module TcIface ( 

-       tcImportDecl, typecheckIface, tcIfaceDecl, tcIfaceGlobal,
+       tcImportDecl, tcHiBootIface, typecheckIface, 
+       tcIfaceDecl, tcIfaceGlobal, 

        loadImportedInsts, loadImportedRules,
        tcExtCoreBindings
  ) where
        loadImportedInsts, loadImportedRules,
        tcExtCoreBindings
  ) where

@@ -14,11 +15,11 @@ module TcIface (
 
 import IfaceSyn
 import LoadIface       ( loadHomeInterface, loadInterface, predInstGates,
 
 import IfaceSyn
 import LoadIface       ( loadHomeInterface, loadInterface, predInstGates,

-                         loadDecls )
+                         loadDecls, findAndReadIface )

 import IfaceEnv                ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, 
                          extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
 import IfaceEnv                ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, 
                          extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,

-                         tcIfaceTyVar, tcIfaceLclId,
-                         newIfaceName, newIfaceNames )
+                         tcIfaceTyVar, tcIfaceLclId, 
+                         newIfaceName, newIfaceNames, ifaceExportNames )

 import BuildTyCl       ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
                          mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
 import TcRnMonad
 import BuildTyCl       ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
                          mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
 import TcRnMonad

@@ -30,6 +31,7 @@ import TyCon          ( TyCon, tyConName, isSynTyCon )
 import HscTypes                ( ExternalPackageState(..), EpsStats(..), PackageInstEnv, 
                          HscEnv, TyThing(..), tyThingClass, tyThingTyCon, 
                          ModIface(..), ModDetails(..), ModGuts,
 import HscTypes                ( ExternalPackageState(..), EpsStats(..), PackageInstEnv, 
                          HscEnv, TyThing(..), tyThingClass, tyThingTyCon, 
                          ModIface(..), ModDetails(..), ModGuts,

+                         emptyModDetails,

                          extendTypeEnv, lookupTypeEnv, lookupType, typeEnvIds )
 import InstEnv         ( extendInstEnvList )
 import CoreSyn
                          extendTypeEnv, lookupTypeEnv, lookupType, typeEnvIds )
 import InstEnv         ( extendInstEnvList )
 import CoreSyn

@@ -55,7 +57,7 @@ import Name           ( Name, nameModule, nameIsLocalOrFrom,
                          isWiredInName, wiredInNameTyThing_maybe, nameParent )
 import NameEnv
 import OccName         ( OccName )
                          isWiredInName, wiredInNameTyThing_maybe, nameParent )
 import NameEnv
 import OccName         ( OccName )

-import Module          ( Module )
+import Module          ( Module, lookupModuleEnv )

 import UniqSupply      ( initUs_ )
 import Outputable      
 import ErrUtils                ( Message )
 import UniqSupply      ( initUs_ )
 import Outputable      
 import ErrUtils                ( Message )

@@ -167,11 +169,12 @@ knot.  Remember, the decls aren't necessarily in dependency order --
 and even if they were, the type decls might be mutually recursive.
 
 \begin{code}
 and even if they were, the type decls might be mutually recursive.
 
 \begin{code}

-typecheckIface :: HscEnv
-              -> ModIface      -- Get the decls from here
-              -> IO ModDetails
-typecheckIface hsc_env iface
-  = initIfaceTc hsc_env iface $ \ tc_env_var -> do
+typecheckIface :: ModIface     -- Get the decls from here
+              -> TcRnIf gbl lcl ModDetails
+typecheckIface iface
+  = initIfaceTc iface $ \ tc_env_var -> do
+       -- The tc_env_var is freshly allocated, private to 
+       -- type-checking this particular interface

        {       -- Get the right set of decls and rules.  If we are compiling without -O
                -- we discard pragmas before typechecking, so that we don't "see"
                -- information that we shouldn't.  From a versioning point of view
        {       -- Get the right set of decls and rules.  If we are compiling without -O
                -- we discard pragmas before typechecking, so that we don't "see"
                -- information that we shouldn't.  From a versioning point of view

@@ -193,8 +196,14 @@ typecheckIface hsc_env iface
        ; dfuns <- mapM tcIfaceInst dfuns
        ; rules <- mapM tcIfaceRule rules
 
        ; dfuns <- mapM tcIfaceInst dfuns
        ; rules <- mapM tcIfaceRule rules
 

+               -- Exports
+       ; exports <-  ifaceExportNames (mi_exports iface)
+

                -- Finished
                -- Finished

-       ; return (ModDetails { md_types = type_env, md_insts = dfuns, md_rules = rules }) 
+       ; return (ModDetails {  md_types = type_env, 
+                               md_insts = dfuns,
+                               md_rules = rules,
+                               md_exports = exports }) 

     }
 \end{code}
 
     }
 \end{code}
 

@@ -205,6 +214,53 @@ typecheckIface hsc_env iface
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

+\begin{code}
+tcHiBootIface :: Module -> TcRn ModDetails
+-- Load the hi-boot iface for the module being compiled,
+-- if it indeed exists in the transitive closure of imports
+-- Return the ModDetails, empty if no hi-boot iface
+tcHiBootIface mod
+  = do         { traceIf (text "loadHiBootInterface" <+> ppr mod)
+
+       -- We're read all the direct imports by now, so eps_is_boot will
+       -- record if any of our imports mention us by way of hi-boot file
+       ; eps <- getEps
+       ; case lookupModuleEnv (eps_is_boot eps) mod of {
+           Nothing -> return emptyModDetails ; -- The typical case
+
+           Just (_, False) -> failWithTc moduleLoop ;
+               -- Someone below us imported us!
+               -- This is a loop with no hi-boot in the way
+               
+           Just (mod, True) ->         -- There's a hi-boot interface below us
+               
+    do { read_result <- findAndReadIface 
+                               True    -- Explicit import? 
+                               need mod
+                               True    -- Hi-boot file
+
+       ; case read_result of
+               Failed err               -> failWithTc (elaborate err)
+               Succeeded (iface, _path) -> typecheckIface iface
+    }}}
+  where
+    need = ptext SLIT("Need the hi-boot interface for") <+> ppr mod
+                <+> ptext SLIT("to compare against the Real Thing")
+
+    moduleLoop = ptext SLIT("Circular imports: module") <+> quotes (ppr mod) 
+                    <+> ptext SLIT("depends on itself")
+
+    elaborate err = hang (ptext SLIT("Could not find hi-boot interface for") <+> 
+                         quotes (ppr mod) <> colon) 4 err
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+               Type and class declarations
+%*                                                                     *
+%************************************************************************
+

 When typechecking a data type decl, we *lazily* (via forkM) typecheck
 the constructor argument types.  This is in the hope that we may never
 poke on those argument types, and hence may never need to load the
 When typechecking a data type decl, we *lazily* (via forkM) typecheck
 the constructor argument types.  This is in the hope that we may never
 poke on those argument types, and hence may never need to load the

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 4d1fe47..404c7ed 100644 (file)
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -51,8 +51,8 @@ import Parser
 import Lexer           ( P(..), ParseResult(..), mkPState )
 import SrcLoc          ( mkSrcLoc )
 import TcRnDriver      ( tcRnModule, tcRnExtCore )
 import Lexer           ( P(..), ParseResult(..), mkPState )
 import SrcLoc          ( mkSrcLoc )
 import TcRnDriver      ( tcRnModule, tcRnExtCore )

-import TcRnTypes       ( TcGblEnv(..) )

 import TcIface         ( typecheckIface )
 import TcIface         ( typecheckIface )

+import TcRnMonad       ( initIfaceCheck, TcGblEnv(..) )

 import IfaceEnv                ( initNameCache )
 import LoadIface       ( ifaceStats, initExternalPackageState )
 import PrelInfo                ( wiredInThings, basicKnownKeyNames )
 import IfaceEnv                ( initNameCache )
 import LoadIface       ( ifaceStats, initExternalPackageState )
 import PrelInfo                ( wiredInThings, basicKnownKeyNames )

@@ -208,7 +208,8 @@ hscNoRecomp hsc_env msg_act mod_summary
                  "Skipping  " ++ showModMsg have_object mod_summary)
 
        ; new_details <- {-# SCC "tcRnIface" #-}
                  "Skipping  " ++ showModMsg have_object mod_summary)
 
        ; new_details <- {-# SCC "tcRnIface" #-}

-                    typecheckIface hsc_env old_iface ;
+                        initIfaceCheck hsc_env $
+                        typecheckIface old_iface ;

        ; dumpIfaceStats hsc_env
 
        ; return (HscNoRecomp new_details old_iface)
        ; dumpIfaceStats hsc_env
 
        ; return (HscNoRecomp new_details old_iface)

diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 8a8cc32..241863a 100644 (file)
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -7,7 +7,7 @@
 module RnNames (
        rnImports, importsFromLocalDecls, 
        reportUnusedNames, reportDeprecations, 
 module RnNames (
        rnImports, importsFromLocalDecls, 
        reportUnusedNames, reportDeprecations, 

-       mkModDeps, exportsToAvails, exportsFromAvail
+       mkModDeps, exportsFromAvail

     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"

@@ -18,7 +18,7 @@ import HsSyn          ( IE(..), ieName, ImportDecl(..), LImportDecl,
                          Sig(..), collectGroupBinders, tyClDeclNames 
                        )
 import RnEnv
                          Sig(..), collectGroupBinders, tyClDeclNames 
                        )
 import RnEnv

-import IfaceEnv                ( lookupAvail )
+import IfaceEnv                ( ifaceExportNames )

 import LoadIface       ( loadSrcInterface )
 import TcRnMonad
 
 import LoadIface       ( loadSrcInterface )
 import TcRnMonad
 

@@ -183,7 +183,7 @@ importsFromImportDecl this_mod
                                 is_loc = loc, is_as = qual_mod_name }
     in
        -- Get the total imports, and filter them according to the import list
                                 is_loc = loc, is_as = qual_mod_name }
     in
        -- Get the total imports, and filter them according to the import list

-    exportsToAvails filtered_exports           `thenM` \ total_avails ->
+    ifaceExportNames filtered_exports          `thenM` \ total_avails ->

     filterImports iface imp_spec
                  imp_details total_avails      `thenM` \ (avail_env, gbl_env) ->
 
     filterImports iface imp_spec
                  imp_details total_avails      `thenM` \ (avail_env, gbl_env) ->
 

@@ -246,14 +246,6 @@ importsFromImportDecl this_mod
 
     returnM (gbl_env, imports)
 
 
     returnM (gbl_env, imports)
 

-exportsToAvails :: [IfaceExport] -> TcRnIf gbl lcl NameSet
-exportsToAvails exports 
-  = foldlM do_one emptyNameSet exports
-  where
-    do_one acc (mod, exports)  = foldlM (do_avail mod) acc exports
-    do_avail mod acc avail = do { ns <- lookupAvail mod avail
-                               ; return (addListToNameSet acc ns) }
-

 warnRedundantSourceImport mod_name
   = ptext SLIT("Unnecessary {- SOURCE -} in the import of module")
           <+> quotes (ppr mod_name)
 warnRedundantSourceImport mod_name
   = ptext SLIT("Unnecessary {- SOURCE -} in the import of module")
           <+> quotes (ppr mod_name)

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index 9b2ce42..8caa51d 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -499,8 +499,8 @@ other modules
 \begin{code}
 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
 newDFunName clas (ty:_) loc
 \begin{code}
 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
 newDFunName clas (ty:_) loc

-  = newUnique                  `thenM` \ uniq ->
-    returnM (mkInternalName uniq (mkDFunOcc dfun_string) loc)
+  = do { uniq <- newUnique
+       ; return (mkInternalName uniq (mkDFunOcc dfun_string) loc) }

   where
        -- Any string that is somewhat unique will do
     dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
   where
        -- Any string that is somewhat unique will do
     dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)

diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index fbd13d8..045577b 100644 (file)
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -43,14 +43,14 @@ import Inst         ( showLIE )
 import InstEnv         ( extendInstEnvList )
 import TcBinds         ( tcTopBinds, tcHsBootSigs )
 import TcDefaults      ( tcDefaults )
 import InstEnv         ( extendInstEnvList )
 import TcBinds         ( tcTopBinds, tcHsBootSigs )
 import TcDefaults      ( tcDefaults )

-import TcEnv           ( tcExtendGlobalValEnv )
+import TcEnv           ( tcExtendGlobalValEnv, iDFunId )

 import TcRules         ( tcRules )
 import TcForeign       ( tcForeignImports, tcForeignExports )
 import TcInstDcls      ( tcInstDecls1, tcInstDecls2 )
 import TcRules         ( tcRules )
 import TcForeign       ( tcForeignImports, tcForeignExports )
 import TcInstDcls      ( tcInstDecls1, tcInstDecls2 )

-import TcIface         ( tcExtCoreBindings )
+import TcIface         ( tcExtCoreBindings, tcHiBootIface )

 import TcSimplify      ( tcSimplifyTop )
 import TcTyClsDecls    ( tcTyAndClassDecls )
 import TcSimplify      ( tcSimplifyTop )
 import TcTyClsDecls    ( tcTyAndClassDecls )

-import LoadIface       ( loadOrphanModules, loadHiBootInterface )
+import LoadIface       ( loadOrphanModules )

 import RnNames         ( importsFromLocalDecls, rnImports, exportsFromAvail,
                          reportUnusedNames, reportDeprecations )
 import RnEnv           ( lookupSrcOcc_maybe )
 import RnNames         ( importsFromLocalDecls, rnImports, exportsFromAvail,
                          reportUnusedNames, reportDeprecations )
 import RnEnv           ( lookupSrcOcc_maybe )

@@ -63,17 +63,19 @@ import Id           ( mkExportedLocalId, isLocalId, idName, idType )
 import Var             ( Var )
 import Module           ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv )
 import OccName         ( mkVarOcc )
 import Var             ( Var )
 import Module           ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv )
 import OccName         ( mkVarOcc )

-import Name            ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName )
+import Name            ( Name, NamedThing(..), isExternalName, getSrcLoc, 
+                         getOccName, isWiredInName )

 import NameSet
 import TyCon           ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
 import SrcLoc          ( srcLocSpan, Located(..), noLoc )
 import DriverPhases    ( HscSource(..), isHsBoot )
 import NameSet
 import TyCon           ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
 import SrcLoc          ( srcLocSpan, Located(..), noLoc )
 import DriverPhases    ( HscSource(..), isHsBoot )

-import HscTypes                ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
+import HscTypes                ( ModGuts(..), ModDetails(..), emptyModDetails,
+                         HscEnv(..), ExternalPackageState(..),

                          IsBootInterface, noDependencies, 
                          Deprecs( NoDeprecs ), plusDeprecs,
                          ForeignStubs(NoStubs), TyThing(..), 
                          IsBootInterface, noDependencies, 
                          Deprecs( NoDeprecs ), plusDeprecs,
                          ForeignStubs(NoStubs), TyThing(..), 

-                         TypeEnv, lookupTypeEnv, hptInstances, lookupType,
-                         extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, 
+                         TypeEnv, lookupTypeEnv, hptInstances, 
+                         extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts,

                          emptyFixityEnv
                        )
 import Outputable
                          emptyFixityEnv
                        )
 import Outputable

@@ -100,14 +102,13 @@ import RnTypes            ( rnLHsType )
 import Inst            ( tcGetInstEnvs )
 import InstEnv         ( DFunId, classInstances, instEnvElts )
 import RnExpr          ( rnStmts, rnLExpr )
 import Inst            ( tcGetInstEnvs )
 import InstEnv         ( DFunId, classInstances, instEnvElts )
 import RnExpr          ( rnStmts, rnLExpr )

-import RnNames         ( exportsToAvails )

 import LoadIface       ( loadSrcInterface, ifaceInstGates )
 import IfaceSyn                ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), 
                          IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
                          tyThingToIfaceDecl, dfunToIfaceInst )
 import IfaceType       ( IfaceTyCon(..), IfaceType, toIfaceType, 
                          interactiveExtNameFun, isLocalIfaceExtName )
 import LoadIface       ( loadSrcInterface, ifaceInstGates )
 import IfaceSyn                ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), 
                          IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
                          tyThingToIfaceDecl, dfunToIfaceInst )
 import IfaceType       ( IfaceTyCon(..), IfaceType, toIfaceType, 
                          interactiveExtNameFun, isLocalIfaceExtName )

-import IfaceEnv                ( lookupOrig )
+import IfaceEnv                ( lookupOrig, ifaceExportNames )

 import RnEnv           ( lookupOccRn, dataTcOccs, lookupFixityRn )
 import Id              ( Id, isImplicitId, setIdType, globalIdDetails )
 import MkId            ( unsafeCoerceId )
 import RnEnv           ( lookupOccRn, dataTcOccs, lookupFixityRn )
 import Id              ( Id, isImplicitId, setIdType, globalIdDetails )
 import MkId            ( unsafeCoerceId )

@@ -297,7 +298,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 
        -- Typecheck them all together so that
        -- any mutually recursive types are done right
 
        -- Typecheck them all together so that
        -- any mutually recursive types are done right

-   tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot names -}] rn_decls) ;
+   tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails rn_decls) ;

        -- Make the new type env available to stuff slurped from interface files
 
    setGblEnv tcg_env $ do {
        -- Make the new type env available to stuff slurped from interface files
 
    setGblEnv tcg_env $ do {

@@ -359,10 +360,11 @@ tcRnSrcDecls decls
                -- We do this now so that the boot_names can be passed
                -- to tcTyAndClassDecls, because the boot_names are 
                -- automatically considered to be loop breakers
                -- We do this now so that the boot_names can be passed
                -- to tcTyAndClassDecls, because the boot_names are 
                -- automatically considered to be loop breakers

-       boot_names <- loadHiBootInterface ;
+       mod <- getModule ;
+       boot_iface <- tcHiBootIface mod ;

 
                -- Do all the declarations
 
                -- Do all the declarations

-       (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_names decls) ;
+       (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_iface decls) ;

 
             -- tcSimplifyTop deals with constant or ambiguous InstIds.  
             -- How could there be ambiguous ones?  They can only arise if a
 
             -- tcSimplifyTop deals with constant or ambiguous InstIds.  
             -- How could there be ambiguous ones?  They can only arise if a

@@ -386,27 +388,29 @@ tcRnSrcDecls decls
        (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
                                                           rules fords ;
 
        (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
                                                           rules fords ;
 

-       let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
+       let { final_type_env = extendTypeEnvWithIds type_env bind_ids
+           ; tcg_env' = tcg_env { tcg_type_env = final_type_env,
+                                  tcg_binds = binds', tcg_rules = rules', 
+                                  tcg_fords = fords' } } ;

 
 

-       -- Compre the hi-boot iface (if any) with the real thing
-       checkHiBootIface final_type_env boot_names ;
+       -- Compare the hi-boot iface (if any) with the real thing
+       checkHiBootIface tcg_env' boot_iface ;

 
        -- Make the new type env available to stuff slurped from interface files
        writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
 
 
        -- 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_type_env = final_type_env,
-                         tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }) 
+       return tcg_env'

    }
 
    }
 

-tc_rn_src_decls :: [Name] -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
+tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)

 -- Loops around dealing with each top level inter-splice group 
 -- in turn, until it's dealt with the entire module
 -- Loops around dealing with each top level inter-splice group 
 -- in turn, until it's dealt with the entire module

-tc_rn_src_decls boot_names ds
+tc_rn_src_decls boot_details ds

  = do { let { (first_group, group_tail) = findSplice ds } ;
                -- If ds is [] we get ([], Nothing)
 
        -- Type check the decls up to, but not including, the first splice
  = do { let { (first_group, group_tail) = findSplice ds } ;
                -- If ds is [] we get ([], Nothing)
 
        -- Type check the decls up to, but not including, the first splice

-       tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_names first_group ;
+       tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_details first_group ;

 
        -- Bale out if errors; for example, error recovery when checking
        -- the RHS of 'main' can mean that 'main' is not in the envt for 
 
        -- Bale out if errors; for example, error recovery when checking
        -- the RHS of 'main' can mean that 'main' is not in the envt for 

@@ -437,7 +441,7 @@ tc_rn_src_decls boot_names ds
 
        -- Glue them on the front of the remaining decls and loop
        setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
 
        -- Glue them on the front of the remaining decls and loop
        setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $

-       tc_rn_src_decls boot_names (spliced_decls ++ rest_ds)
+       tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)

 #endif /* GHCI */
     }}}
 \end{code}
 #endif /* GHCI */
     }}}
 \end{code}

@@ -467,7 +471,7 @@ tcRnHsBootDecls decls
                -- Typecheck type/class decls
        ; traceTc (text "Tc2")
        ; let tycl_decls = hs_tyclds rn_group
                -- Typecheck type/class decls
        ; traceTc (text "Tc2")
        ; let tycl_decls = hs_tyclds rn_group

-       ; tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot_names -}] tycl_decls)
+       ; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls)

        ; setGblEnv tcg_env     $ do {
 
                -- Typecheck instance decls
        ; setGblEnv tcg_env     $ do {
 
                -- Typecheck instance decls

@@ -477,15 +481,21 @@ tcRnHsBootDecls decls
 
                -- Typecheck value declarations
        ; traceTc (text "Tc5") 
 
                -- Typecheck value declarations
        ; traceTc (text "Tc5") 

-       ; new_ids <- tcHsBootSigs (hs_valds rn_group)
+       ; val_ids <- tcHsBootSigs (hs_valds rn_group)

 
                -- Wrap up
                -- No simplification or zonking to do
        ; traceTc (text "Tc7a")
        ; gbl_env <- getGblEnv 
        
 
                -- Wrap up
                -- No simplification or zonking to do
        ; traceTc (text "Tc7a")
        ; gbl_env <- getGblEnv 
        

-       ; let { final_type_env = extendTypeEnvWithIds (tcg_type_env gbl_env) new_ids }
-       ; return (gbl_env { tcg_type_env = final_type_env }) 
+               -- Make the final type-env
+               -- Include the dfun_ids so that their type sigs get
+               -- are written into the interface file
+       ; let { type_env0 = tcg_type_env gbl_env
+             ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
+             ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids 
+             ; dfun_ids = map iDFunId inst_infos }
+       ; return (gbl_env { tcg_type_env = type_env2 }) 

    }}}}
 
 spliceInHsBootErr (SpliceDecl (L loc _), _)
    }}}}
 
 spliceInHsBootErr (SpliceDecl (L loc _), _)

@@ -499,33 +509,38 @@ the hi-boot stuff in the EPT.  We do so here, using the export list of
 the hi-boot interface as our checklist.
 
 \begin{code}
 the hi-boot interface as our checklist.
 
 \begin{code}

-checkHiBootIface :: TypeEnv -> [Name] -> TcM ()
+checkHiBootIface :: TcGblEnv -> ModDetails -> TcM ()

 -- Compare the hi-boot file for this module (if there is one)
 -- with the type environment we've just come up with
 -- In the common case where there is no hi-boot file, the list
 -- of boot_names is empty.
 -- Compare the hi-boot file for this module (if there is one)
 -- with the type environment we've just come up with
 -- In the common case where there is no hi-boot file, the list
 -- of boot_names is empty.

-checkHiBootIface env boot_names
-  = mapM_ (check_one env) boot_names
-
-----------------
-check_one local_env name
-  | isWiredInName name -- No checking for wired-in names.  In particular, 'error' 
-  = return ()          -- is handled by a rather gross hack (see comments in GHC.Err.hs-boot)
-  | otherwise  
-  = do { (eps,hpt)  <- getEpsAndHpt
-
-               -- Look up the hi-boot one; 
-               -- it should jolly well be there (else GHC bug)
-       ; case lookupType hpt (eps_PTE eps) name of {
-           Nothing -> pprPanic "checkHiBootIface" (ppr name) ;
-           Just boot_thing ->
-
-               -- Look it up in the local type env
-               -- It should be there, but it's a programmer error if not
-         case lookupTypeEnv local_env name of
-          Nothing         -> addErrTc (missingBootThing boot_thing)
-          Just real_thing -> check_thing boot_thing real_thing
-    } }
+checkHiBootIface
+       (TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env })
+       (ModDetails { md_insts = boot_insts, md_types = boot_type_env })
+  = do { mapM_ check_inst  boot_insts
+       ; mapM_ check_one (typeEnvElts boot_type_env) }
+  where
+    check_one boot_thing
+      | no_check name
+      = return ()      
+      | otherwise      
+      = case lookupTypeEnv local_type_env name of
+         Nothing         -> addErrTc (missingBootThing boot_thing)
+         Just real_thing -> check_thing boot_thing real_thing
+      where
+       name = getName boot_thing
+
+    no_check name = isWiredInName name -- No checking for wired-in names.  In particular,
+                                       -- 'error' is handled by a rather gross hack
+                                       -- (see comments in GHC.Err.hs-boot)
+                 || name `elem` dfun_names
+    dfun_names = map getName boot_insts
+
+    check_inst inst
+       | null [i | i <- local_insts, idType i `tcEqType` idType inst]
+       = addErrTc (instMisMatch inst)
+       | otherwise 
+       = return ()

 
 ----------------
 check_thing (ATyCon boot_tc) (ATyCon real_tc)
 
 ----------------
 check_thing (ATyCon boot_tc) (ATyCon real_tc)

@@ -558,6 +573,9 @@ missingBootThing thing
   = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
 bootMisMatch thing
   = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
   = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
 bootMisMatch thing
   = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")

+instMisMatch inst
+  = hang (ptext SLIT("instance") <+> ppr (idType inst))
+       2 (ptext SLIT("is defined in the hs-boot file, but not in the module"))

 \end{code}
 
 
 \end{code}
 
 

@@ -579,15 +597,15 @@ declarations.  It expects there to be an incoming TcGblEnv in the
 monad; it augments it and returns the new TcGblEnv.
 
 \begin{code}
 monad; it augments it and returns the new TcGblEnv.
 
 \begin{code}

-tcRnGroup :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
+tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)

        -- Returns the variables free in the decls, for unused-binding reporting
        -- Returns the variables free in the decls, for unused-binding reporting

-tcRnGroup boot_names decls
+tcRnGroup boot_details decls

  = do {                -- Rename the declarations
        (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
        setGblEnv tcg_env $ do {
 
                -- Typecheck the declarations
  = do {                -- Rename the declarations
        (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
        setGblEnv tcg_env $ do {
 
                -- Typecheck the declarations

-       tcTopSrcDecls boot_names rn_decls 
+       tcTopSrcDecls boot_details rn_decls 

   }}
 
 ------------------------------------------------
   }}
 
 ------------------------------------------------

@@ -613,8 +631,8 @@ rnTopSrcDecls group
    }}
 
 ------------------------------------------------
    }}
 
 ------------------------------------------------

-tcTopSrcDecls :: [Name] -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
-tcTopSrcDecls boot_names
+tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
+tcTopSrcDecls boot_details

        (HsGroup { hs_tyclds = tycl_decls, 
                   hs_instds = inst_decls,
                   hs_fords  = foreign_decls,
        (HsGroup { hs_tyclds = tycl_decls, 
                   hs_instds = inst_decls,
                   hs_fords  = foreign_decls,

@@ -625,7 +643,7 @@ tcTopSrcDecls boot_names
                -- The latter come in via tycl_decls
         traceTc (text "Tc2") ;
 
                -- The latter come in via tycl_decls
         traceTc (text "Tc2") ;
 

-       tcg_env <- checkNoErrs (tcTyAndClassDecls boot_names tycl_decls) ;
+       tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details tycl_decls) ;

        -- tcTyAndClassDecls recovers internally, but if anything gave rise to
        -- an error we'd better stop now, to avoid a cascade
        
        -- tcTyAndClassDecls recovers internally, but if anything gave rise to
        -- an error we'd better stop now, to avoid a cascade
        

@@ -1051,7 +1069,7 @@ getModuleExports mod
        ; loadOrphanModules (dep_orphs (mi_deps iface))
                        -- Load any orphan-module interfaces,
                        -- so their instances are visible
        ; loadOrphanModules (dep_orphs (mi_deps iface))
                        -- Load any orphan-module interfaces,
                        -- so their instances are visible

-       ; names <- exportsToAvails (mi_exports iface)
+       ; names <- ifaceExportNames (mi_exports iface)

        ; let { gres =  [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
                        | name <- nameSetToList names ] }
        ; returnM (mkGlobalRdrEnv gres) }
        ; let { gres =  [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
                        | name <- nameSetToList names ] }
        ; returnM (mkGlobalRdrEnv gres) }

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index 6ff9043..ac5e59a 100644 (file)
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -836,16 +836,16 @@ initIfaceCheck hsc_env do_this
        ; initTcRnIf 'i' hsc_env gbl_env () do_this
     }
 
        ; initTcRnIf 'i' hsc_env gbl_env () do_this
     }
 

-initIfaceTc :: HscEnv -> ModIface 
-           -> (TcRef TypeEnv -> IfL a) -> IO a
+initIfaceTc :: ModIface 
+           -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a

 -- Used when type-checking checking an up-to-date interface file
 -- No type envt from the current module, but we do know the module dependencies
 -- Used when type-checking checking an up-to-date interface file
 -- No type envt from the current module, but we do know the module dependencies

-initIfaceTc hsc_env iface do_this
- = do  { tc_env_var <- newIORef emptyTypeEnv
+initIfaceTc iface do_this
+ = do  { tc_env_var <- newMutVar emptyTypeEnv

        ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
              ; if_lenv = mkIfLclEnv mod doc
           }
        ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
              ; if_lenv = mkIfLclEnv mod doc
           }

-       ; initTcRnIf 'i' hsc_env gbl_env if_lenv (do_this tc_env_var)
+       ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)

     }
   where
     mod = mi_module iface
     }
   where
     mod = mi_module iface

diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index d872de5..08e89b5 100644 (file)
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -37,7 +37,7 @@ import TypeRep                ( Type(..), PredType(..), TyThing(..) ) -- For reification
 import Name            ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, 
                          mkInternalName, nameIsLocalOrFrom )
 import NameEnv         ( lookupNameEnv )
 import Name            ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, 
                          mkInternalName, nameIsLocalOrFrom )
 import NameEnv         ( lookupNameEnv )

-import HscTypes                ( lookupType, ExternalPackageState(..) )
+import HscTypes                ( lookupType, ExternalPackageState(..), emptyModDetails )

 import OccName
 import Var             ( Id, TyVar, idType )
 import Module          ( moduleUserString, mkModule )
 import OccName
 import Var             ( Id, TyVar, idType )
 import Module          ( moduleUserString, mkModule )

@@ -141,7 +141,7 @@ tc_bracket (TypBr typ)
        -- Result type is Type (= Q Typ)
 
 tc_bracket (DecBr decls)
        -- Result type is Type (= Q Typ)
 
 tc_bracket (DecBr decls)

-  = tcTopSrcDecls [{- no boot-names -}] decls          `thenM_`
+  = tcTopSrcDecls emptyModDetails decls                `thenM_`

        -- Typecheck the declarations, dicarding the result
        -- We'll get all that stuff later, when we splice it in
 
        -- Typecheck the declarations, dicarding the result
        -- We'll get all that stuff later, when we splice it in
 

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index b3b3de6..7186fa9 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -17,7 +17,7 @@ import HsSyn          ( TyClDecl(..),  HsConDetails(..), HsTyVarBndr(..),
                        )
 import HsTypes          ( HsBang(..), getBangStrictness )
 import BasicTypes      ( RecFlag(..), StrictnessMark(..) )
                        )
 import HsTypes          ( HsBang(..), getBangStrictness )
 import BasicTypes      ( RecFlag(..), StrictnessMark(..) )

-import HscTypes                ( implicitTyThings )
+import HscTypes                ( implicitTyThings, ModDetails )

 import BuildTyCl       ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon,
                          mkDataTyConRhs, mkNewTyConRhs )
 import TcRnMonad
 import BuildTyCl       ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon,
                          mkDataTyConRhs, mkNewTyConRhs )
 import TcRnMonad

@@ -109,15 +109,15 @@ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 
 \begin{code}
 @TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 
 \begin{code}

-tcTyAndClassDecls :: [Name] -> [LTyClDecl Name]
+tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]

                   -> TcM TcGblEnv      -- Input env extended by types and classes 
                                        -- and their implicit Ids,DataCons
                   -> TcM TcGblEnv      -- Input env extended by types and classes 
                                        -- and their implicit Ids,DataCons

-tcTyAndClassDecls boot_names decls
+tcTyAndClassDecls boot_details decls

   = do {       -- First check for cyclic type synonysm or classes
                -- See notes with checkCycleErrs
          checkCycleErrs decls
        ; mod <- getModule
   = do {       -- First check for cyclic type synonysm or classes
                -- See notes with checkCycleErrs
          checkCycleErrs decls
        ; mod <- getModule

-       ; traceTc (text "tcTyAndCl" <+> ppr mod <+> ppr boot_names)
+       ; traceTc (text "tcTyAndCl" <+> ppr mod)

        ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) ->
          do    { let { -- Calculate variances and rec-flag
                      ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls }
        ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) ->
          do    { let { -- Calculate variances and rec-flag
                      ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls }

@@ -135,7 +135,7 @@ tcTyAndClassDecls boot_names decls
                { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls
 
                ; let { calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss)
                { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls
 
                ; let { calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss)

-                     ; calc_rec  = calcRecFlags boot_names rec_alg_tyclss
+                     ; calc_rec  = calcRecFlags boot_details rec_alg_tyclss

                      ; tc_decl   = addLocM (tcTyClDecl calc_vrcs calc_rec) }
                        -- Type-check the type synonyms, and extend the envt
                ; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls
                      ; tc_decl   = addLocM (tcTyClDecl calc_vrcs calc_rec) }
                        -- Type-check the type synonyms, and extend the envt
                ; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls

diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 105bef9..590ac2c 100644 (file)
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -23,7 +23,7 @@ import TypeRep          ( Type(..), TyNote(..), PredType(..) )  -- friend
 import HsSyn           ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl )
 import RnHsSyn         ( extractHsTyNames )
 import Type            ( predTypeRep )
 import HsSyn           ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl )
 import RnHsSyn         ( extractHsTyNames )
 import Type            ( predTypeRep )

-import HscTypes                ( TyThing(..) )
+import HscTypes                ( TyThing(..), ModDetails(..) )

 import TyCon            ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
                           getSynTyConDefn, isSynTyCon, isAlgTyCon, 
                          tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs )
 import TyCon            ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
                           getSynTyConDefn, isSynTyCon, isAlgTyCon, 
                          tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs )

@@ -213,16 +213,16 @@ recursiveness, because we need only look at the type decls in the module being
 compiled, plus the outer structure of directly-mentioned types.
 
 \begin{code}
 compiled, plus the outer structure of directly-mentioned types.
 
 \begin{code}

-calcRecFlags :: [Name] -> [TyThing] -> (Name -> RecFlag)
+calcRecFlags :: ModDetails -> [TyThing] -> (Name -> RecFlag)

 -- The 'boot_names' are the things declared in M.hi-boot, if M is the current module.
 -- Any type constructors in boot_names are automatically considered loop breakers
 -- The 'boot_names' are the things declared in M.hi-boot, if M is the current module.
 -- Any type constructors in boot_names are automatically considered loop breakers

-calcRecFlags boot_names tyclss
+calcRecFlags boot_details tyclss

   = is_rec
   where
     is_rec n | n `elemNameSet` rec_names = Recursive
             | otherwise                 = NonRecursive
 
   = is_rec
   where
     is_rec n | n `elemNameSet` rec_names = Recursive
             | otherwise                 = NonRecursive
 

-    boot_name_set = mkNameSet boot_names
+    boot_name_set = md_exports boot_details

     rec_names = boot_name_set    `unionNameSets` 
                nt_loop_breakers  `unionNameSets`
                prod_loop_breakers
     rec_names = boot_name_set    `unionNameSets` 
                nt_loop_breakers  `unionNameSets`
                prod_loop_breakers