Basic set up for global family instance environment

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

diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 3c3ca95..30c922d 100644 (file)
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -21,7 +21,6 @@ module TcRnTypes(
 
        -- Typechecker types
        TcTyThing(..), pprTcTyThingCategory, 
-       GadtRefinement,
 
        -- Template Haskell
        ThStage(..), topStage, topSpliceStage,
@@ -44,7 +43,7 @@ module TcRnTypes(
 
 import HsSyn           ( PendingSplice, HsOverLit, LRuleDecl, LForeignDecl,
                          ArithSeqInfo, DictBinds, LHsBinds, LImportDecl, HsGroup,
-                          IE )
+                          ExprCoFn, IE )
 import HscTypes                ( FixityEnv,
                          HscEnv, TypeEnv, TyThing, 
                          GenAvailInfo(..), AvailInfo, HscSource(..),
@@ -52,8 +51,10 @@ import HscTypes              ( FixityEnv,
 import Packages                ( PackageId )
 import Type            ( Type, pprTyThingCategory )
 import TcType          ( TcTyVarSet, TcType, TcThetaType, SkolemInfo, TvSubst,
-                         TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes, pprSkolInfo )
+                         TcPredType, TcKind, tcCmpPred, tcCmpType,
+                         tcCmpTypes, pprSkolInfo )
 import InstEnv         ( Instance, InstEnv )
+import FamInstEnv      ( FamInst, FamInstEnv )
 import IOEnv
 import RdrName         ( GlobalRdrEnv, LocalRdrEnv )
 import Name            ( Name )
@@ -154,8 +155,11 @@ 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 
@@ -324,7 +328,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 +422,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 ExprCoFn,       -- 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 +441,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
 
@@ -798,7 +808,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)]