Cross-module consistency check for family instances
[ghc-hetmet.git] / compiler / main / HscTypes.lhs
index 8b126e6..c5483b9 100644 (file)
@@ -1,5 +1,5 @@
-
-% (c) The University of Glasgow, 2000
+%
+% (c) The University of Glasgow, 2006
 %
 \section[HscTypes]{Types for the per-module compiler}
 
@@ -30,13 +30,13 @@ module HscTypes (
        icPrintUnqual, mkPrintUnqualified,
 
        ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
-       emptyIfaceDepCache, mkIfaceFamInstsCache, mkDetailsFamInstCache,
+       emptyIfaceDepCache,
 
        Deprecs(..), IfaceDeprecs,
 
        FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
 
-       implicitTyThings, 
+       implicitTyThings, isImplicitTyThing,
 
        TyThing(..), tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId,
        TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv,
@@ -47,7 +47,7 @@ module HscTypes (
        WhetherHasOrphans, IsBootInterface, Usage(..), 
        Dependencies(..), noDependencies,
        NameCache(..), OrigNameCache, OrigIParamCache,
-       Avails, availsToNameSet, availName, availNames,
+       Avails, availsToNameSet, availsToNameEnv, availName, availNames,
        GenAvailInfo(..), AvailInfo, RdrAvailInfo, 
        IfaceExport,
 
@@ -78,15 +78,14 @@ import OccName              ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv,
                          extendOccEnv )
 import Module
 import InstEnv         ( InstEnv, Instance )
-import FamInstEnv      ( FamInst, extractFamInsts )
+import FamInstEnv      ( FamInstEnv, FamInst )
 import Rules           ( RuleBase )
 import CoreSyn         ( CoreBind )
-import Id              ( Id )
+import Id              ( Id, isImplicitId )
 import Type            ( TyThing(..) )
 
 import Class           ( Class, classSelIds, classATs, classTyCon )
-import TyCon           ( TyCon, tyConSelIds, tyConDataCons, 
-                         newTyConCo_maybe, tyConFamilyCoercion_maybe )
+import TyCon
 import DataCon         ( DataCon, dataConImplicitIds )
 import PrelNames       ( gHC_PRIM )
 import Packages                ( PackageId )
@@ -94,10 +93,7 @@ import DynFlags              ( DynFlags(..), isOneShot, HscTarget (..) )
 import DriverPhases    ( HscSource(..), isHsBoot, hscSourceString, Phase )
 import BasicTypes      ( Version, initialVersion, IPName, 
                          Fixity, defaultFixity, DeprecTxt )
-
-import IfaceSyn                ( IfaceInst, IfaceFamInst, IfaceRule, 
-                         IfaceDecl(ifName), extractIfFamInsts )
-
+import IfaceSyn
 import FiniteMap       ( FiniteMap )
 import CoreSyn         ( CoreRule )
 import Maybes          ( orElse, expectJust )
@@ -107,10 +103,11 @@ import UniqFM             ( lookupUFM, eltsUFM, emptyUFM )
 import UniqSupply      ( UniqSupply )
 import FastString      ( FastString )
 
-import DATA_IOREF      ( IORef, readIORef )
 import StringBuffer    ( StringBuffer )
 import Maybes           ( catMaybes, seqMaybe )
-import Time            ( ClockTime )
+
+import System.Time     ( ClockTime )
+import Data.IORef      ( IORef, readIORef )
 \end{code}
 
 
@@ -370,6 +367,7 @@ data ModIface
         mi_mod_vers :: !Version,           -- Module version: changes when anything changes
 
         mi_orphan   :: !WhetherHasOrphans,  -- Whether this module has orphans
+        mi_finsts   :: !WhetherHasFamInst,  -- Whether module has family insts
        mi_boot     :: !IsBootInterface,    -- Read from an hi-boot file?
 
        mi_deps     :: Dependencies,
@@ -420,52 +418,42 @@ data ModIface
 
                -- Instance declarations and rules
        mi_insts     :: [IfaceInst],                    -- Sorted
-       mi_fam_insts :: [(IfaceFamInst, IfaceDecl)],     -- Cached value
-                                       -- ...from mi_decls (not in iface file)
+       mi_fam_insts :: [IfaceFamInst],                 -- Sorted
        mi_rules     :: [IfaceRule],                    -- Sorted
        mi_rule_vers :: !Version,       -- Version number for rules and 
-                                       -- instances combined
+                                       -- instances (for classes and families)
+                                       -- combined
 
                -- Cached environments for easy lookup
                -- These are computed (lazily) from other fields
                -- and are not put into the interface file
        mi_dep_fn  :: Name -> Maybe DeprecTxt,  -- Cached lookup for mi_deprecs
        mi_fix_fn  :: OccName -> Fixity,        -- Cached lookup for mi_fixities
-       mi_ver_fn  :: OccName -> Maybe Version  -- Cached lookup for mi_decls
+       mi_ver_fn  :: OccName -> Maybe (OccName, Version)
+                        -- Cached lookup for mi_decls
                        -- The Nothing in mi_ver_fn means that the thing
                        -- isn't in decls. It's useful to know that when
                        -- seeing if we are up to date wrt the old interface
+                        -- The 'OccName' is the parent of the name, if it has one.
      }
 
--- Pre-compute the set of type instances from the declaration list.
-mkIfaceFamInstsCache :: [IfaceDecl] -> [(IfaceFamInst, IfaceDecl)]
-mkIfaceFamInstsCache = extractIfFamInsts
-
 -- Should be able to construct ModDetails from mi_decls in ModIface
 data ModDetails
    = ModDetails {
-       -- The next three fields are created by the typechecker
-       md_exports   :: NameSet,
+       -- The next two fields are created by the typechecker
+       md_exports   :: [AvailInfo],
         md_types     :: !TypeEnv,
-        md_fam_insts :: ![FamInst],    -- Cached value extracted from md_types
-        md_insts     :: ![Instance],    -- Dfun-ids for the instances in this 
-                                       -- module
-
-        md_rules     :: ![CoreRule]    -- Domain may include Ids from other 
-                                       -- modules
-
+        md_insts     :: ![Instance],   -- Dfun-ids for the instances in this module
+        md_fam_insts :: ![FamInst],
+        md_rules     :: ![CoreRule]    -- Domain may include Ids from other modules
      }
 
 emptyModDetails = ModDetails { md_types = emptyTypeEnv,
-                              md_exports = emptyNameSet,
+                              md_exports = [],
                               md_insts     = [],
                               md_rules     = [],
                               md_fam_insts = [] }
 
--- Pre-compute the set of type instances from the type environment.
-mkDetailsFamInstCache :: TypeEnv -> [FamInst]
-mkDetailsFamInstCache = extractFamInsts . typeEnvElts
-
 -- A ModGuts is carried through the compiler, accumulating stuff as it goes
 -- There is only one ModGuts at any time, the one for the module
 -- being compiled right now.  Once it is compiled, a ModIface and 
@@ -473,23 +461,26 @@ mkDetailsFamInstCache = extractFamInsts . typeEnvElts
 
 data ModGuts
   = ModGuts {
-        mg_module   :: !Module,
-       mg_boot     :: IsBootInterface, -- Whether it's an hs-boot module
-       mg_exports  :: !NameSet,        -- What it exports
-       mg_deps     :: !Dependencies,   -- What is below it, directly or otherwise
-       mg_dir_imps :: ![Module],       -- Directly-imported modules; used to
-                                       --      generate initialisation code
-       mg_usages   :: ![Usage],        -- Version info for what it needed
-
-        mg_rdr_env  :: !GlobalRdrEnv,  -- Top-level lexical environment
-       mg_fix_env  :: !FixityEnv,      -- Fixity env, for things declared in this module
-       mg_deprecs  :: !Deprecations,   -- Deprecations declared in the module
-
-       mg_types    :: !TypeEnv,
-       mg_insts    :: ![Instance],     -- Instances 
-        mg_rules    :: ![CoreRule],    -- Rules from this module
-       mg_binds    :: ![CoreBind],     -- Bindings for this module
-       mg_foreign  :: !ForeignStubs
+        mg_module    :: !Module,
+       mg_boot      :: IsBootInterface, -- Whether it's an hs-boot module
+       mg_exports   :: ![AvailInfo],    -- What it exports
+       mg_deps      :: !Dependencies,   -- What is below it, directly or
+                                        --   otherwise 
+       mg_dir_imps  :: ![Module],       -- Directly-imported modules; used to
+                                        --     generate initialisation code
+       mg_usages    :: ![Usage],        -- Version info for what it needed
+
+        mg_rdr_env   :: !GlobalRdrEnv,  -- Top-level lexical environment
+       mg_fix_env   :: !FixityEnv,      -- Fixity env, for things declared in
+                                        --   this module 
+       mg_deprecs   :: !Deprecations,   -- Deprecations declared in the module
+
+       mg_types     :: !TypeEnv,
+       mg_insts     :: ![Instance],     -- Instances 
+       mg_fam_insts :: ![FamInst],      -- Instances 
+        mg_rules     :: ![CoreRule],    -- Rules from this module
+       mg_binds     :: ![CoreBind],     -- Bindings for this module
+       mg_foreign   :: !ForeignStubs
     }
 
 -- The ModGuts takes on several slightly different forms:
@@ -561,6 +552,7 @@ emptyModIface mod
   = ModIface { mi_module   = mod,
               mi_mod_vers = initialVersion,
               mi_orphan   = False,
+              mi_finsts   = False,
               mi_boot     = False,
               mi_deps     = noDependencies,
               mi_usages   = [],
@@ -673,6 +665,16 @@ implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++
        -- For data cons add the worker and wrapper (if any)
 implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc)
 
+-- | returns 'True' if there should be no interface-file declaration
+-- for this thing on its own: either it is built-in, or it is part
+-- of some other declaration, or it is generated implicitly by some
+-- other declaration.
+isImplicitTyThing :: TyThing -> Bool
+isImplicitTyThing (ADataCon _)  = True
+isImplicitTyThing (AnId     id) = isImplicitId id
+isImplicitTyThing (AClass   _)  = False
+isImplicitTyThing (ATyCon   tc) = isImplicitTyCon tc
+
        -- For newtypes and indexed data types, add the implicit coercion tycon
 implicitCoTyCon tc 
   = map ATyCon . catMaybes $ [newTyConCo_maybe tc, 
@@ -764,14 +766,19 @@ These types are defined here because they are mentioned in ModDetails,
 but they are mostly elaborated elsewhere
 
 \begin{code}
-mkIfaceVerCache :: [(Version,IfaceDecl)] -> OccName -> Maybe Version
+mkIfaceVerCache :: [(Version,IfaceDecl)]
+                -> (OccName -> Maybe (OccName, Version))
 mkIfaceVerCache pairs 
   = \occ -> lookupOccEnv env occ
   where
-    env = foldl add emptyOccEnv pairs
-    add env (v,d) = extendOccEnv env (ifName d) v
+    env = foldr add_decl emptyOccEnv pairs
+    add_decl (v,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d)
+      where
+          decl_name = ifName d
+          env1 = extendOccEnv env0 decl_name (decl_name, v)
+          add_imp bndr env = extendOccEnv env bndr (decl_name, v)
 
-emptyIfaceVerCache :: OccName -> Maybe Version
+emptyIfaceVerCache :: OccName -> Maybe (OccName, Version)
 emptyIfaceVerCache occ = Nothing
 
 ------------------ Deprecations -------------------------
@@ -830,9 +837,13 @@ data GenAvailInfo name     = Avail name     -- An ordinary identifier
 type IfaceExport = (Module, [GenAvailInfo OccName])
 
 availsToNameSet :: [AvailInfo] -> NameSet
-availsToNameSet avails = foldl add emptyNameSet avails
-                      where
-                        add set avail = addListToNameSet set (availNames avail)
+availsToNameSet avails = foldr add emptyNameSet avails
+      where add avail set = addListToNameSet set (availNames avail)
+
+availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo
+availsToNameEnv avails = foldr add emptyNameEnv avails
+     where add avail env = extendNameEnvList env
+                                (zip (availNames avail) (repeat avail))
 
 availName :: GenAvailInfo name -> name
 availName (Avail n)     = n
@@ -846,11 +857,8 @@ instance Outputable n => Outputable (GenAvailInfo n) where
    ppr = pprAvail
 
 pprAvail :: Outputable n => GenAvailInfo n -> SDoc
-pprAvail (AvailTC n ns) = ppr n <> case {- filter (/= n) -} ns of
-                                       []  -> empty
-                                       ns' -> braces (hsep (punctuate comma (map ppr ns')))
-
-pprAvail (Avail n) = ppr n
+pprAvail (Avail n)      = ppr n
+pprAvail (AvailTC n ns) = ppr n <> braces (hsep (punctuate comma (map ppr ns)))
 \end{code}
 
 \begin{code}
@@ -896,27 +904,38 @@ type WhetherHasOrphans   = Bool
        --      * a transformation rule in a module other than the one defining
        --              the function in the head of the rule.
 
+type WhetherHasFamInst = Bool       -- This module defines family instances?
+
 type IsBootInterface = Bool
 
 -- Dependency info about modules and packages below this one
 -- in the import hierarchy.  See TcRnTypes.ImportAvails for details.
+-- The orphan modules in `dep_orphs' do *not* include family instance orphans,
+-- as they are anyway included in `dep_finsts'.
 --
 -- Invariant: the dependencies of a module M never includes M
 -- Invariant: the lists are unordered, with no duplicates
 data Dependencies
-  = Deps { dep_mods  :: [(ModuleName,IsBootInterface)],        -- Home-package module dependencies
-          dep_pkgs  :: [PackageId],                    -- External package dependencies
-          dep_orphs :: [Module] }                      -- Orphan modules (whether home or external pkg)
+  = Deps { dep_mods   :: [(ModuleName,      -- Home-package module dependencies
+                          IsBootInterface)]
+        , dep_pkgs   :: [PackageId]        -- External package dependencies
+        , dep_orphs  :: [Module]           -- Orphan modules (whether home or
+                                           -- external pkg)
+         , dep_finsts :: [Module]          -- Modules that contain family
+                                           -- instances (whether home or
+                                           -- external pkg)
+         }
   deriving( Eq )
        -- Equality used only for old/new comparison in MkIface.addVersionInfo
 
 noDependencies :: Dependencies
-noDependencies = Deps [] [] []
+noDependencies = Deps [] [] [] []
          
 data Usage
   = Usage { usg_name     :: ModuleName,                        -- Name of the module
            usg_mod      :: Version,                    -- Module version
            usg_entities :: [(OccName,Version)],        -- Sorted by occurrence name
+                -- NB. usages are for parent names only, eg. tycon but not constructors.
            usg_exports  :: Maybe Version,              -- Export-list version, if we depend on it
            usg_rules    :: Version                     -- Orphan-rules version (for non-orphan
                                                        -- modules this will always be initialVersion)
@@ -948,9 +967,10 @@ data Usage
 %************************************************************************
 
 \begin{code}
-type PackageTypeEnv  = TypeEnv
-type PackageRuleBase = RuleBase
-type PackageInstEnv  = InstEnv
+type PackageTypeEnv    = TypeEnv
+type PackageRuleBase   = RuleBase
+type PackageInstEnv    = InstEnv
+type PackageFamInstEnv = FamInstEnv
 
 data ExternalPackageState
   = EPS {
@@ -971,8 +991,8 @@ data ExternalPackageState
                -- The ModuleIFaces for modules in external packages
                -- whose interfaces we have opened
                -- The declarations in these interface files are held in
-               -- eps_decls, eps_inst_env, eps_rules (below), not in the 
-               -- mi_decls fields of the iPIT.  
+               -- eps_decls, eps_inst_env, eps_fam_inst_env, eps_rules
+               -- (below), not in the mi_decls fields of the iPIT.  
                -- What _is_ in the iPIT is:
                --      * The Module 
                --      * Version info
@@ -980,11 +1000,16 @@ data ExternalPackageState
                --      * Fixities
                --      * Deprecations
 
-       eps_PTE :: !PackageTypeEnv,             -- Domain = external-package modules
+       eps_PTE :: !PackageTypeEnv,        -- Domain = external-package modules
+
+       eps_inst_env     :: !PackageInstEnv,   -- The total InstEnv accumulated
+                                              -- from all the external-package
+                                              -- modules 
+       eps_fam_inst_env :: !PackageFamInstEnv,-- Ditto FamInstEnv
+       eps_rule_base    :: !PackageRuleBase,  -- Ditto RuleEnv
 
-       eps_inst_env :: !PackageInstEnv,        -- The total InstEnv accumulated from
-                                               --   all the external-package modules
-       eps_rule_base :: !PackageRuleBase,      -- Ditto RuleEnv
+        eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- identifies family
+                                                      -- instances of each mod
 
        eps_stats :: !EpsStats
   }