More import tidying and fixing the stage 2 build
[ghc-hetmet.git] / compiler / typecheck / TcRnTypes.lhs
index 3c3ca95..fff5404 100644 (file)
@@ -1,4 +1,5 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP Project, Glasgow University, 1992-2002
 %
 \begin{code}
@@ -21,7 +22,6 @@ module TcRnTypes(
 
        -- Typechecker types
        TcTyThing(..), pprTcTyThingCategory, 
-       GadtRefinement,
 
        -- Template Haskell
        ThStage(..), topStage, topSpliceStage,
@@ -42,38 +42,34 @@ module TcRnTypes(
 
 #include "HsVersions.h"
 
-import HsSyn           ( PendingSplice, HsOverLit, LRuleDecl, LForeignDecl,
-                         ArithSeqInfo, DictBinds, LHsBinds, LImportDecl, HsGroup,
-                          IE )
-import HscTypes                ( FixityEnv,
-                         HscEnv, TypeEnv, TyThing, 
-                         GenAvailInfo(..), AvailInfo, HscSource(..),
-                         availName, IsBootInterface, Deprecations )
-import Packages                ( PackageId )
-import Type            ( Type, pprTyThingCategory )
-import TcType          ( TcTyVarSet, TcType, TcThetaType, SkolemInfo, TvSubst,
-                         TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes, pprSkolInfo )
-import InstEnv         ( Instance, InstEnv )
+import HsSyn hiding (LIE)
+import HscTypes
+import Packages
+import Type
+import TcType
+import InstEnv
+import FamInstEnv
 import IOEnv
-import RdrName         ( GlobalRdrEnv, LocalRdrEnv )
-import Name            ( Name )
+import RdrName
+import Name
 import NameEnv
-import NameSet         ( NameSet, unionNameSets, DefUses )
-import Var             ( Id, TyVar )
-import VarEnv          ( TidyEnv )
+import NameSet
+import Var
+import VarEnv
 import Module
 import UniqFM
-import SrcLoc          ( SrcSpan, SrcLoc, Located, srcSpanStart )
-import VarSet          ( IdSet )
-import ErrUtils                ( Messages, Message )
-import UniqFM           ( UniqFM )
-import UniqSupply      ( UniqSupply )
-import BasicTypes      ( IPName )
-import Util            ( thenCmp )
+import SrcLoc
+import VarSet
+import ErrUtils
+import UniqSupply
+import BasicTypes
+import Util
 import Bag
 import Outputable
-import Maybe           ( mapMaybe )
-import ListSetOps      ( unionLists )
+import ListSetOps
+
+import Data.Maybe
+import Data.List
 \end{code}
 
 
@@ -154,13 +150,16 @@ data TcGblEnv
                -- bound in this module when dealing with hi-boot recursions
                -- Updated at intervals (e.g. after dealing with types and classes)
        
-       tcg_inst_env :: InstEnv,        -- Instance envt for *home-package* modules
-                                       -- Includes the dfuns in tcg_insts
+       tcg_inst_env     :: InstEnv,    -- Instance envt for *home-package* 
+                                       -- modules; Includes the dfuns in 
+                                       -- tcg_insts
+       tcg_fam_inst_env :: FamInstEnv, -- Ditto for family instances
+
                -- Now a bunch of things about this module that are simply 
                -- accumulated, but never consulted until the end.  
                -- Nevertheless, it's convenient to accumulate them along 
                -- with the rest of the info from this module.
-       tcg_exports :: NameSet,         -- What is exported
+       tcg_exports :: [AvailInfo],     -- What is exported
        tcg_imports :: ImportAvails,    -- Information about what was imported 
                                        --    from where, including things bound
                                        --    in this module
@@ -220,11 +219,15 @@ data TcGblEnv
        tcg_rn_decls :: Maybe (HsGroup Name),   -- renamed decls, maybe
                -- Nothing <=> Don't retain renamed decls
 
-       tcg_binds   :: LHsBinds Id,             -- Value bindings in this module
-       tcg_deprecs :: Deprecations,            -- ...Deprecations 
-       tcg_insts   :: [Instance],              -- ...Instances
-       tcg_rules   :: [LRuleDecl Id],          -- ...Rules
-       tcg_fords   :: [LForeignDecl Id]        -- ...Foreign import & exports
+       tcg_binds     :: LHsBinds Id,       -- Value bindings in this module
+       tcg_deprecs   :: Deprecations,      -- ...Deprecations 
+       tcg_insts     :: [Instance],        -- ...Instances
+       tcg_fam_insts :: [FamInst],         -- ...Family instances
+       tcg_rules     :: [LRuleDecl Id],    -- ...Rules
+       tcg_fords     :: [LForeignDecl Id], -- ...Foreign import & exports
+
+       tcg_doc :: Maybe (HsDoc Name), -- Maybe Haddock documentation
+        tcg_hmi :: HaddockModInfo Name -- Haddock module information
     }
 \end{code}
 
@@ -324,7 +327,6 @@ data TcLclEnv               -- Changes as we move inside an expression
        tcl_lie   :: TcRef LIE          -- Place to accumulate type constraints
     }
 
-type GadtRefinement = TvSubst
 
 {- Note [Given Insts]
    ~~~~~~~~~~~~~~~~~~
@@ -419,9 +421,15 @@ escapeArrowScope
 data TcTyThing
   = AGlobal TyThing            -- Used only in the return type of a lookup
 
-  | ATcId   TcId               -- Ids defined in this module; may not be fully zonked
-           ThLevel 
-           Bool                -- True <=> apply the type refinement to me
+  | ATcId   {          -- Ids defined in this module; may not be fully zonked
+       tct_id :: TcId,         
+       tct_co :: Maybe HsWrapper,      -- Nothing <=>  Do not apply a GADT type refinement
+                                       --              I am wobbly, or have no free
+                                       --              type variables
+                                       -- Just co <=>  Apply any type refinement to me,
+                                       --              and record it in the coercion
+       tct_type  :: TcType,    -- Type of (coercion applied to id)
+       tct_level :: ThLevel }
 
   | ATyVar  Name TcType                -- The type to which the lexically scoped type vaiable
                                -- is currently refined. We only need the Name
@@ -432,8 +440,9 @@ data TcTyThing
 
 instance Outputable TcTyThing where    -- Debugging only
    ppr (AGlobal g)      = ppr g
-   ppr (ATcId g tl rig) = text "Identifier" <> 
-                         ifPprDebug (brackets (ppr g <> comma <> ppr tl <+> ppr rig))
+   ppr elt@(ATcId {})   = text "Identifier" <> 
+                         ifPprDebug (brackets (ppr (tct_id elt) <> dcolon <> ppr (tct_type elt) <> comma
+                                <+> ppr (tct_level elt) <+> ppr (tct_co elt)))
    ppr (ATyVar tv _)    = text "Type variable" <+> quotes (ppr tv)
    ppr (AThing k)       = text "AThing" <+> ppr k
 
@@ -469,20 +478,21 @@ It is used        * when processing the export list
 \begin{code}
 data ImportAvails 
    = ImportAvails {
-       imp_env :: ModuleNameEnv NameSet,
-               -- All the things imported, classified by 
+       imp_env :: ModuleNameEnv [AvailInfo],
+               -- All the things imported *unqualified*, classified by 
                -- the *module qualifier* for its import
                --   e.g.        import List as Foo
                -- would add a binding Foo |-> ...stuff from List...
                -- to imp_env.
                -- 
-               -- We need to classify them like this so that we can figure out 
-               -- "module M" export specifiers in an export list 
-               -- (see 1.4 Report Section 5.1.1).  Ultimately, we want to find 
-               -- everything that is unambiguously in scope as 'M.x'
-               -- and where plain 'x' is (perhaps ambiguously) in scope.
-               -- So the starting point is all things that are in scope as 'M.x',
-               -- which is what this field tells us.
+                -- This is exactly the list of things that will be exported
+                -- by a 'module M' specifier in the export list.
+               -- (see Haskell 98 Report Section 5.2).
+                --
+                -- Warning: there may be duplciates in this list,
+                -- duplicates are removed at the use site (rnExports).
+                -- We might consider turning this into a NameEnv at
+                -- some point.
 
        imp_mods :: ModuleEnv (Module, Bool, SrcSpan),
                -- Domain is all directly-imported modules
@@ -497,6 +507,11 @@ data ImportAvails
                --       the interface file; if we import somethign we
                --       need to recompile if the export version changes
                --   (b) to specify what child modules to initialise
+                --
+                -- We need a full ModuleEnv rather than a ModuleNameEnv
+                -- here, because we might be importing modules of the
+                -- same name from different packages. (currently not the case,
+                -- but might be in the future).
 
        imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface),
                -- Home-package modules needed by the module being compiled
@@ -513,8 +528,14 @@ data ImportAvails
                -- directly, or via other modules in this package, or via
                -- modules imported from other packages.
 
-       imp_orphs :: [Module]
+       imp_orphs :: [Module],
                -- Orphan modules below us in the import tree
+
+        imp_parent :: NameEnv AvailInfo
+                -- for the names in scope in this module, tells us
+                -- the relationship between parents and children
+                -- (eg. a TyCon is the parent of its DataCons, a
+                -- class is the parent of its methods, etc.).
       }
 
 mkModDeps :: [(ModuleName, IsBootInterface)]
@@ -528,20 +549,28 @@ emptyImportAvails = ImportAvails { imp_env        = emptyUFM,
                                   imp_mods     = emptyModuleEnv,
                                   imp_dep_mods = emptyUFM,
                                   imp_dep_pkgs = [],
-                                  imp_orphs    = [] }
+                                  imp_orphs    = [],
+                                   imp_parent   = emptyNameEnv }
 
 plusImportAvails ::  ImportAvails ->  ImportAvails ->  ImportAvails
 plusImportAvails
   (ImportAvails { imp_env = env1, imp_mods = mods1,
-                 imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, imp_orphs = orphs1 })
+                 imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, 
+                  imp_orphs = orphs1, imp_parent = parent1 })
   (ImportAvails { imp_env = env2, imp_mods = mods2,
-                 imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, imp_orphs = orphs2 })
-  = ImportAvails { imp_env      = plusUFM_C unionNameSets env1 env2, 
+                 imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
+                  imp_orphs = orphs2, imp_parent = parent2  })
+  = ImportAvails { imp_env      = plusUFM_C (++) env1 env2, 
                   imp_mods     = mods1  `plusModuleEnv` mods2, 
                   imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, 
                   imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
-                  imp_orphs    = orphs1 `unionLists` orphs2 }
+                  imp_orphs    = orphs1 `unionLists` orphs2,
+                   imp_parent   = plusNameEnv_C plus_avails parent1 parent2 }
   where
+    plus_avails (AvailTC tc subs1) (AvailTC _ subs2)
+                = AvailTC tc (nub (subs1 ++ subs2))
+    plus_avails avail _ = avail
+
     plus_mod_dep (m1, boot1) (m2, boot2) 
        = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
                -- Check mod-names match
@@ -790,6 +819,7 @@ data InstOrigin
   | RecordUpdOrigin
   | InstScOrigin       -- Typechecking superclasses of an instance declaration
   | DerivOrigin                -- Typechecking deriving
+  | StandAloneDerivOrigin -- Typechecking stand-alone deriving
   | DefaultOrigin      -- Typechecking a default decl
   | DoOrigin           -- Arising from a do expression
   | ProcOrigin         -- Arising from a proc expression
@@ -798,7 +828,8 @@ data InstOrigin
 \begin{code}
 pprInstLoc :: InstLoc -> SDoc
 pprInstLoc (InstLoc orig locn _)
-  = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
+  = sep [text "arising from" <+> pp_orig orig, 
+        text "at" <+> ppr locn]
   where
     pp_orig (OccurrenceOf name)  = hsep [ptext SLIT("use of"), quotes (ppr name)]
     pp_orig (IPOccOrigin name)   = hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)]
@@ -810,6 +841,7 @@ pprInstLoc (InstLoc orig locn _)
     pp_orig InstSigOrigin       = ptext SLIT("instantiating a type signature")
     pp_orig InstScOrigin        = ptext SLIT("the superclasses of an instance declaration")
     pp_orig DerivOrigin                 = ptext SLIT("the 'deriving' clause of a data type declaration")
+    pp_orig StandAloneDerivOrigin = ptext SLIT("a 'deriving' declaration")
     pp_orig DefaultOrigin       = ptext SLIT("a 'default' declaration")
     pp_orig DoOrigin            = ptext SLIT("a do statement")
     pp_orig ProcOrigin          = ptext SLIT("a proc expression")