Major refactoring of CoAxioms
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 3 Jan 2012 10:35:08 +0000 (10:35 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 3 Jan 2012 10:35:08 +0000 (10:35 +0000)
This patch should have no user-visible effect.  It implements a
significant internal refactoring of the way that FC axioms are
handled.  The ultimate goal is to put us in a position to implement
"pattern-matching axioms".  But the changes here are only does
refactoring; there is no change in functionality.

Specifically:

 * We now treat data/type family instance declarations very,
   very similarly to types class instance declarations:

   - Renamed InstEnv.Instance as InstEnv.ClsInst, for symmetry with
     FamInstEnv.FamInst.  This change does affect the GHC API, but
     for the better I think.

   - Previously, each family type/data instance declaration gave rise
     to a *TyCon*; typechecking a type/data instance decl produced
     that TyCon.  Now, each type/data instance gives rise to
     a *FamInst*, by direct analogy with each class instance
     declaration giving rise to a ClsInst.

   - Just as each ClsInst contains its evidence, a DFunId, so each FamInst
     contains its evidence, a CoAxiom.  See Note [FamInsts and CoAxioms]
     in FamInstEnv.  The CoAxiom is a System-FC thing, and can relate any
     two types, whereas the FamInst relates directly to the Haskell source
     language construct, and always has a function (F tys) on the LHS.

   - Just as a DFunId has its own declaration in an interface file, so now
     do CoAxioms (see IfaceSyn.IfaceAxiom).

   These changes give rise to almost all the refactoring.

 * We used to have a hack whereby a type family instance produced a dummy
   type synonym, thus
      type instance F Int = Bool -> Bool
   translated to
      axiom FInt :: F Int ~ R:FInt
      type R:FInt = Bool -> Bool
   This was always a hack, and now it's gone.  Instead the type instance
   declaration produces a FamInst, whose axiom has kind
      axiom FInt :: F Int ~ Bool -> Bool
   just as you'd expect.

 * Newtypes are done just as before; they generate a CoAxiom. These
   CoAxioms are "implicit" (do not generate an IfaceAxiom declaration),
   unlike the ones coming from family instance declarations.  See
   Note [Implicit axioms] in TyCon

On the whole the code gets significantly nicer.  There were consequential
tidy-ups in the vectoriser, but I think I got them right.

49 files changed:
compiler/basicTypes/MkId.lhs
compiler/basicTypes/OccName.lhs
compiler/coreSyn/CoreSyn.lhs
compiler/hsSyn/HsDecls.lhs
compiler/iface/BinIface.hs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/LoadIface.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/iface/TcIface.lhs-boot
compiler/main/GHC.hs
compiler/main/HscMain.hs
compiler/main/HscTypes.lhs
compiler/main/InteractiveEval.hs
compiler/main/TidyPgm.lhs
compiler/rename/RnEnv.lhs
compiler/typecheck/FamInst.lhs
compiler/typecheck/Inst.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcGenDeriv.lhs
compiler/typecheck/TcGenGenerics.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcInteract.lhs
compiler/typecheck/TcMType.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcSMonad.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/types/Coercion.lhs
compiler/types/FamInstEnv.lhs
compiler/types/FunDeps.lhs
compiler/types/InstEnv.lhs
compiler/types/Kind.lhs
compiler/types/TyCon.lhs
compiler/vectorise/Vectorise/Generic/PADict.hs
compiler/vectorise/Vectorise/Generic/PAMethods.hs
compiler/vectorise/Vectorise/Generic/PData.hs
compiler/vectorise/Vectorise/Monad/InstEnv.hs
compiler/vectorise/Vectorise/Monad/Naming.hs
compiler/vectorise/Vectorise/Type/Env.hs
compiler/vectorise/Vectorise/Type/TyConDecl.hs
compiler/vectorise/Vectorise/Utils/Base.hs
compiler/vectorise/Vectorise/Utils/PADict.hs
ghc/InteractiveUI.hs

index a40d46f..60f4cf1 100644 (file)
@@ -26,6 +26,7 @@ module MkId (
 
         mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
         wrapFamInstBody, unwrapFamInstScrut,
+        wrapTypeFamInstBody, unwrapTypeFamInstScrut,
         mkUnpackCase, mkProductBox,
 
         -- And some particular Ids; see below for why they are wired in
@@ -227,7 +228,7 @@ mkDataConIds wrap_name wkr_name data_con
   = DCIds Nothing nt_work_id                 
 
   | any isBanged all_strict_marks      -- Algebraic, needs wrapper
-    || not (null eq_spec)              -- NB: LoadIface.ifaceDeclSubBndrs
+    || not (null eq_spec)              -- NB: LoadIface.ifaceDeclImplicitBndrs
     || isFamInstTyCon tycon            --     depends on this test
   = DCIds (Just alg_wrap_id) wrk_id
 
@@ -709,12 +710,22 @@ wrapFamInstBody tycon args body
   | otherwise
   = body
 
+-- Same as `wrapFamInstBody`, but for type family instances, which are
+-- represented by a `CoAxiom`, and not a `TyCon`
+wrapTypeFamInstBody :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr
+wrapTypeFamInstBody axiom args body
+  = mkCast body (mkSymCo (mkAxInstCo axiom args))
+
 unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapFamInstScrut tycon args scrut
   | Just co_con <- tyConFamilyCoercion_maybe tycon
   = mkCast scrut (mkAxInstCo co_con args)
   | otherwise
   = scrut
+
+unwrapTypeFamInstScrut :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr
+unwrapTypeFamInstScrut axiom args scrut
+  = mkCast scrut (mkAxInstCo axiom args)
 \end{code}
 
 
index 9f8f32d..ff1f71d 100644 (file)
@@ -209,7 +209,7 @@ pprNameSpaceBrief TcClsName = ptext (sLit "tc")
 
 -- demoteNameSpace lowers the NameSpace if possible.  We can not know
 -- in advance, since a TvName can appear in an HsTyVar.
--- see Note [Demotion]
+-- See Note [Demotion] in RnEnv
 demoteNameSpace :: NameSpace -> Maybe NameSpace
 demoteNameSpace VarName = Nothing
 demoteNameSpace DataName = Nothing
@@ -217,24 +217,6 @@ demoteNameSpace TvName = Nothing
 demoteNameSpace TcClsName = Just DataName
 \end{code}
 
-Note [Demotion]
-~~~~~~~~~~~~~~~
-
-When the user writes:
-  data Nat = Zero | Succ Nat
-  foo :: f Zero -> Int
-
-'Zero' in the type signature of 'foo' is parsed as:
-  HsTyVar ("Zero", TcClsName)
-
-When the renamer hits this occurence of 'Zero' it's going to realise
-that it's not in scope. But because it is renaming a type, it knows
-that 'Zero' might be a promoted data constructor, so it will demote
-its namespace to DataName and do a second lookup.
-
-The final result (after the renamer) will be:
-  HsTyVar ("Zero", DataName)
-
 
 %************************************************************************
 %*                                                                     *
@@ -371,7 +353,7 @@ sequentially starting at 0.
 
 So we can make a Unique using
        mkUnique ns key  :: Unique
-where 'ns' is a Char reprsenting the name space.  This in turn makes it
+where 'ns' is a Char representing the name space.  This in turn makes it
 easy to build an OccEnv.
 
 \begin{code}
index 310a05e..a41302d 100644 (file)
@@ -447,12 +447,12 @@ data CoreRule
        ru_act  :: Activation,          -- ^ When the rule is active
 
        -- Rough-matching stuff
-       -- see comments with InstEnv.Instance( is_cls, is_rough )
+       -- see comments with InstEnv.ClsInst( is_cls, is_rough )
        ru_fn    :: Name,               -- ^ Name of the 'Id.Id' at the head of this rule
        ru_rough :: [Maybe Name],       -- ^ Name at the head of each argument to the left hand side
        
        -- Proper-matching stuff
-       -- see comments with InstEnv.Instance( is_tvs, is_tys )
+       -- see comments with InstEnv.ClsInst( is_tvs, is_tys )
        ru_bndrs :: [CoreBndr],         -- ^ Variables quantified over
        ru_args  :: [CoreExpr],         -- ^ Left hand side arguments
        
index 772a3eb..f8e6bc0 100644 (file)
@@ -1096,7 +1096,7 @@ data VectDecl name
   | HsVectInstIn                -- pre type-checking (always SCALAR)
       (LHsType name)
   | HsVectInstOut               -- post type-checking (always SCALAR)
-      Instance
+      ClsInst
   deriving (Data, Typeable)
 
 lvectDeclName :: NamedThing name => LVectDecl name -> Name
index 792421d..c701013 100644 (file)
@@ -1391,13 +1391,12 @@ instance Binary IfaceDecl where
         put_ bh a6
         put_ bh a7
 
-    put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
+    put_ bh (IfaceSyn a1 a2 a3 a4) = do
         putByte bh 3
         put_ bh (occNameFS a1)
         put_ bh a2
         put_ bh a3
         put_ bh a4
-        put_ bh a5
 
     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
         putByte bh 4
@@ -1408,6 +1407,13 @@ instance Binary IfaceDecl where
         put_ bh a5
         put_ bh a6
         put_ bh a7
+        
+    put_ bh (IfaceAxiom a1 a2 a3 a4) = do
+        putByte bh 5
+        put_ bh (occNameFS a1)
+        put_ bh a2
+        put_ bh a3
+        put_ bh a4
 
     get bh = do
         h <- getByte bh
@@ -1432,10 +1438,9 @@ instance Binary IfaceDecl where
                     a2 <- get bh
                     a3 <- get bh
                     a4 <- get bh
-                    a5 <- get bh
                     occ <- return $! mkOccNameFS tcName a1
-                    return (IfaceSyn occ a2 a3 a4 a5)
-            _ -> do a1 <- get bh
+                    return (IfaceSyn occ a2 a3 a4)
+            4 -> do a1 <- get bh
                     a2 <- get bh
                     a3 <- get bh
                     a4 <- get bh
@@ -1444,9 +1449,15 @@ instance Binary IfaceDecl where
                     a7 <- get bh
                     occ <- return $! mkOccNameFS clsName a2
                     return (IfaceClass a1 occ a3 a4 a5 a6 a7)
+            _ -> do a1 <- get bh
+                    a2 <- get bh
+                    a3 <- get bh
+                    a4 <- get bh
+                    occ <- return $! mkOccNameFS tcName a1
+                    return (IfaceAxiom occ a2 a3 a4)
 
-instance Binary IfaceInst where
-    put_ bh (IfaceInst cls tys dfun flag orph) = do
+instance Binary IfaceClsInst where
+    put_ bh (IfaceClsInst cls tys dfun flag orph) = do
         put_ bh cls
         put_ bh tys
         put_ bh dfun
@@ -1458,18 +1469,20 @@ instance Binary IfaceInst where
         dfun <- get bh
         flag <- get bh
         orph <- get bh
-        return (IfaceInst cls tys dfun flag orph)
+        return (IfaceClsInst cls tys dfun flag orph)
 
 instance Binary IfaceFamInst where
-    put_ bh (IfaceFamInst fam tys tycon) = do
+    put_ bh (IfaceFamInst fam tys name orph) = do
         put_ bh fam
         put_ bh tys
-        put_ bh tycon
+        put_ bh name
+        put_ bh orph
     get bh = do
-        fam   <- get bh
-        tys   <- get bh
-        tycon <- get bh
-        return (IfaceFamInst fam tys tycon)
+        fam      <- get bh
+        tys      <- get bh
+        name     <- get bh
+        orph     <- get bh
+        return (IfaceFamInst fam tys name orph)
 
 instance Binary OverlapFlag where
     put_ bh (NoOverlap  b) = putByte bh 0 >> put_ bh b
@@ -1486,14 +1499,14 @@ instance Binary OverlapFlag where
 
 instance Binary IfaceConDecls where
     put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
-    put_ bh IfOpenDataTyCon     = putByte bh 1
+    put_ bh IfDataFamTyCon     = putByte bh 1
     put_ bh (IfDataTyCon cs)    = putByte bh 2 >> put_ bh cs
     put_ bh (IfNewTyCon c)      = putByte bh 3 >> put_ bh c
     get bh = do
         h <- getByte bh
         case h of
             0 -> get bh >>= (return . IfAbstractTyCon)
-            1 -> return IfOpenDataTyCon
+            1 -> return IfDataFamTyCon
             2 -> get bh >>= (return . IfDataTyCon)
             _ -> get bh >>= (return . IfNewTyCon)
 
index 612b098..1ffabb4 100644 (file)
 -- for details
 
 module BuildTyCl (
-       buildSynTyCon, 
+        buildSynTyCon,
         buildAlgTyCon, 
         buildDataCon,
         buildPromotedDataTyCon,
         TcMethInfo, buildClass,
-       distinctAbstractTyConRhs, totallyAbstractTyConRhs,
-       mkNewTyConRhs, mkDataTyConRhs, 
+        distinctAbstractTyConRhs, totallyAbstractTyConRhs,
+        mkNewTyConRhs, mkDataTyConRhs, 
         newImplicitBinder
     ) where
 
@@ -49,69 +49,28 @@ import Unique           ( getUnique )
 ------------------------------------------------------
 buildSynTyCon :: Name -> [TyVar] 
               -> SynTyConRhs
-             -> Kind                   -- ^ Kind of the RHS
-             -> TyConParent
-             -> Maybe (TyCon, [Type])    -- ^ family instance if applicable
+              -> Kind                   -- ^ Kind of the RHS
+              -> TyConParent
               -> TcRnIf m n TyCon
-buildSynTyCon tc_name tvs rhs rhs_kind parent mb_family 
-  | Just fam_inst_info <- mb_family
-  = ASSERT( isNoParent parent )
-    fixM $ \ tycon_rec -> do 
-    { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec 
-    ; return (mkSynTyCon tc_name kind tvs rhs fam_parent) }
-
-  | otherwise
+buildSynTyCon tc_name tvs rhs rhs_kind parent 
   = return (mkSynTyCon tc_name kind tvs rhs parent)
   where kind = mkPiKinds tvs rhs_kind
 
 ------------------------------------------------------
-buildAlgTyCon :: Name -> [TyVar]        -- ^ Kind variables adn type variables
-             -> ThetaType              -- ^ Stupid theta
+buildAlgTyCon :: Name 
+              -> [TyVar]               -- ^ Kind variables and type variables
+             -> ThetaType             -- ^ Stupid theta
              -> AlgTyConRhs
              -> RecFlag
-             -> Bool                   -- ^ True <=> was declared in GADT syntax
+             -> Bool                  -- ^ True <=> was declared in GADT syntax
               -> TyConParent
-             -> Maybe (TyCon, [Type])  -- ^ family instance if applicable
-             -> TcRnIf m n TyCon
-
-buildAlgTyCon tc_name ktvs stupid_theta rhs is_rec gadt_syn
-             parent mb_family
-  | Just fam_inst_info <- mb_family
-  = -- We need to tie a knot as the coercion of a data instance depends
-     -- on the instance representation tycon and vice versa.
-    ASSERT( isNoParent parent )
-    fixM $ \ tycon_rec -> do 
-    { fam_parent <- mkFamInstParentInfo tc_name ktvs fam_inst_info tycon_rec
-    ; return (mkAlgTyCon tc_name kind ktvs stupid_theta rhs
-                        fam_parent is_rec gadt_syn) }
-
-  | otherwise
-  = return (mkAlgTyCon tc_name kind ktvs stupid_theta rhs
-                      parent is_rec gadt_syn)
-  where kind = mkPiKinds ktvs liftedTypeKind
-
--- | If a family tycon with instance types is given, the current tycon is an
--- instance of that family and we need to
---
--- (1) create a coercion that identifies the family instance type and the
---     representation type from Step (1); ie, it is of the form 
---        `Co tvs :: F ts ~ R tvs', where `Co' is the name of the coercion,
---        `F' the family tycon and `R' the (derived) representation tycon,
---        and
--- (2) produce a `TyConParent' value containing the parent and coercion
---     information.
---
-mkFamInstParentInfo :: Name -> [TyVar] 
-                   -> (TyCon, [Type]) 
-                   -> TyCon 
-                   -> TcRnIf m n TyConParent
-mkFamInstParentInfo tc_name tvs (family, instTys) rep_tycon
-  = do { -- Create the coercion
-       ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
-       ; let co_tycon = mkFamInstCo co_tycon_name tvs
-                                    family instTys rep_tycon
-       ; return $ FamInstTyCon family instTys co_tycon }
-    
+             -> TyCon
+
+buildAlgTyCon tc_name ktvs stupid_theta rhs is_rec gadt_syn parent
+  = mkAlgTyCon tc_name kind ktvs stupid_theta rhs parent is_rec gadt_syn
+  where 
+    kind = mkPiKinds ktvs liftedTypeKind
+
 ------------------------------------------------------
 distinctAbstractTyConRhs, totallyAbstractTyConRhs :: AlgTyConRhs
 distinctAbstractTyConRhs = AbstractTyCon True
index 6f59e38..fd8b361 100644 (file)
@@ -20,13 +20,13 @@ module IfaceSyn (
         IfaceBinding(..), IfaceConAlt(..),
         IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
         IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
-        IfaceInst(..), IfaceFamInst(..), IfaceTickish(..),
+        IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
 
         -- Misc
-        ifaceDeclSubBndrs, visibleIfConDecls,
+        ifaceDeclImplicitBndrs, visibleIfConDecls,
 
         -- Free Names
-        freeNamesIfDecl, freeNamesIfRule,
+        freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
 
         -- Pretty printing
         pprIfaceExpr, pprIfaceDeclHead
@@ -70,26 +70,19 @@ data IfaceDecl
   | IfaceData { ifName       :: OccName,        -- Type constructor
                 ifTyVars     :: [IfaceTvBndr],  -- Type variables
                 ifCtxt       :: IfaceContext,   -- The "stupid theta"
-                ifCons       :: IfaceConDecls,  -- Includes new/data info
+                ifCons       :: IfaceConDecls,  -- Includes new/data/data family info
                 ifRec        :: RecFlag,        -- Recursive or not?
                 ifGadtSyntax :: Bool,           -- True <=> declared using
                                                 -- GADT syntax
-                ifFamInst    :: Maybe (IfaceTyCon, [IfaceType])
-                                                -- Just <=> instance of family
-                                                -- Invariant:
-                                                --   ifCons /= IfOpenDataTyCon
-                                                --   for family instances
+                ifAxiom      :: Maybe IfExtName -- The axiom, for a newtype, 
+                                                -- or data/newtype family instance
     }
 
   | IfaceSyn  { ifName    :: OccName,           -- Type constructor
                 ifTyVars  :: [IfaceTvBndr],     -- Type variables
                 ifSynKind :: IfaceKind,         -- Kind of the *rhs* (not of the tycon)
-                ifSynRhs  :: Maybe IfaceType,   -- Just rhs for an ordinary synonyn
-                                                -- Nothing for an open family
-                ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
-                                                -- Just <=> instance of family
-                                                -- Invariant: ifOpenSyn == False
-                                                --   for family instances
+                ifSynRhs  :: Maybe IfaceType    -- Just rhs for an ordinary synonyn
+                                                -- Nothing for an type family declaration
     }
 
   | IfaceClass { ifCtxt    :: IfaceContext,     -- Context...
@@ -102,6 +95,11 @@ data IfaceDecl
                                                 --   with the class recursive?
     }
 
+  | IfaceAxiom { ifName   :: OccName       -- Axiom name
+               , ifTyVars :: [IfaceTvBndr] -- Axiom tyvars
+               , ifLHS    :: IfaceType     -- Axiom LHS
+               , ifRHS    :: IfaceType }   -- and RHS
+
   | IfaceForeign { ifName :: OccName,           -- Needs expanding when we move
                                                 -- beyond .NET
                    ifExtName :: Maybe FastString }
@@ -123,13 +121,13 @@ data IfaceATDefault = IfaceATD [IfaceTvBndr] [IfaceType] IfaceType
 
 data IfaceConDecls
   = IfAbstractTyCon Bool        -- c.f TyCon.AbstractTyCon
-  | IfOpenDataTyCon             -- Open data family
-  | IfDataTyCon [IfaceConDecl]  -- data type decls
-  | IfNewTyCon  IfaceConDecl    -- newtype decls
+  | IfDataFamTyCon              -- Data family
+  | IfDataTyCon [IfaceConDecl]  -- Data type decls
+  | IfNewTyCon  IfaceConDecl    -- Newtype decls
 
 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
 visibleIfConDecls (IfAbstractTyCon {}) = []
-visibleIfConDecls IfOpenDataTyCon      = []
+visibleIfConDecls IfDataFamTyCon      = []
 visibleIfConDecls (IfDataTyCon cs)     = cs
 visibleIfConDecls (IfNewTyCon c)       = [c]
 
@@ -147,12 +145,12 @@ data IfaceConDecl
         ifConStricts :: [HsBang]}               -- Empty (meaning all lazy),
                                                 -- or 1-1 corresp with arg tys
 
-data IfaceInst
-  = IfaceInst { ifInstCls  :: IfExtName,                -- See comments with
-                ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of Instance
-                ifDFun     :: IfExtName,                -- The dfun
-                ifOFlag    :: OverlapFlag,              -- Overlap flag
-                ifInstOrph :: Maybe OccName }           -- See Note [Orphans]
+data IfaceClsInst
+  = IfaceClsInst { ifInstCls  :: IfExtName,                -- See comments with
+                   ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of ClsInst
+                   ifDFun     :: IfExtName,                -- The dfun
+                   ifOFlag    :: OverlapFlag,              -- Overlap flag
+                   ifInstOrph :: Maybe OccName }           -- See Note [Orphans]
         -- There's always a separate IfaceDecl for the DFun, which gives
         -- its IdInfo with its full type and version number.
         -- The instance declarations taken together have a version number,
@@ -161,9 +159,10 @@ data IfaceInst
         -- and if the head does not change it won't be used if it wasn't before
 
 data IfaceFamInst
-  = IfaceFamInst { ifFamInstFam   :: IfExtName                -- Family tycon
+  = IfaceFamInst { ifFamInstFam   :: IfExtName           -- Family name
                  , ifFamInstTys   :: [Maybe IfaceTyCon]  -- Rough match types
-                 , ifFamInstTyCon :: IfaceTyCon          -- Instance decl
+                 , ifFamInstAxiom :: IfExtName           -- The axiom
+                 , ifFamInstOrph  :: Maybe OccName       -- Just like IfaceClsInst
                  }
 
 data IfaceRule
@@ -175,7 +174,7 @@ data IfaceRule
         ifRuleArgs   :: [IfaceExpr],    -- Args of LHS
         ifRuleRhs    :: IfaceExpr,
         ifRuleAuto   :: Bool,
-        ifRuleOrph   :: Maybe OccName   -- Just like IfaceInst
+        ifRuleOrph   :: Maybe OccName   -- Just like IfaceClsInst
     }
 
 data IfaceAnnotation
@@ -375,38 +374,34 @@ See [http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationA
 -- -----------------------------------------------------------------------------
 -- Utils on IfaceSyn
 
-ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
+ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
 --  *Excludes* the 'main' name, but *includes* the implicitly-bound names
 -- Deeply revolting, because it has to predict what gets bound,
 -- especially the question of whether there's a wrapper for a datacon
+-- See Note [Implicit TyThings] in HscTypes
 
 -- N.B. the set of names returned here *must* match the set of
 -- TyThings returned by HscTypes.implicitTyThings, in the sense that
 -- TyThing.getOccName should define a bijection between the two lists.
 -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
 -- The order of the list does not matter.
-ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon {}}  = []
+ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}}  = []
 
 -- Newtype
-ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
+ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ,
                               ifCons = IfNewTyCon (
-                                        IfCon { ifConOcc = con_occ }),
-                              ifFamInst = famInst})
-  =   -- implicit coerion and (possibly) family instance coercion
-    (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++
+                                        IfCon { ifConOcc = con_occ })})
+  =   -- implicit newtype coercion
+    (mkNewTyCoOcc tc_occ) : -- JPM: newtype coercions shouldn't be implicit
       -- data constructor and worker (newtypes don't have a wrapper)
     [con_occ, mkDataConWorkerOcc con_occ]
 
 
-ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
-                              ifCons = IfDataTyCon cons,
-                              ifFamInst = famInst})
-  =   -- (possibly) family instance coercion;
-      -- there is no implicit coercion for non-newtypes
-    famInstCo famInst tc_occ
-      -- for each data constructor in order,
-      --    data constructor, worker, and (possibly) wrapper
-    ++ concatMap dc_occs cons
+ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ,
+                              ifCons = IfDataTyCon cons })
+  = -- for each data constructor in order,
+    --    data constructor, worker, and (possibly) wrapper
+    concatMap dc_occs cons
   where
     dc_occs con_decl
         | has_wrapper = [con_occ, work_occ, wrap_occ]
@@ -418,7 +413,7 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
           has_wrapper = ifConWrapper con_decl     -- This is the reason for
                                                   -- having the ifConWrapper field!
 
-ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
+ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
                                ifSigs = sigs, ifATs = ats })
   = --   (possibly) newtype coercion
     co_occs ++
@@ -441,16 +436,7 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
     dc_occ = mkClassDataConOcc cls_tc_occ
     is_newtype = n_sigs + n_ctxt == 1 -- Sigh
 
-ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ,
-                             ifFamInst = famInst})
-  = famInstCo famInst tc_occ
-
-ifaceDeclSubBndrs _ = []
-
--- coercion for data/newtype family instances
-famInstCo :: Maybe (IfaceTyCon, [IfaceType]) -> OccName -> [OccName]
-famInstCo Nothing  _       = []
-famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]
+ifaceDeclImplicitBndrs _ = []
 
 ----------------------------- Printing IfaceDecl ------------------------------
 
@@ -468,10 +454,9 @@ pprIfaceDecl (IfaceForeign {ifName = tycon})
   = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon]
 
 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
-                        ifSynRhs = Just mono_ty,
-                        ifFamInst = mbFamInst})
+                        ifSynRhs = Just mono_ty})
   = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
-       4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
+       4 (vcat [equals <+> ppr mono_ty])
 
 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
                         ifSynRhs = Nothing, ifSynKind = kind })
@@ -480,14 +465,14 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
 
 pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context,
                          ifTyVars = tyvars, ifCons = condecls,
-                         ifRec = isrec, ifFamInst = mbFamInst})
+                         ifRec = isrec, ifAxiom = mbAxiom})
   = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
        4 (vcat [pprRec isrec, pp_condecls tycon condecls,
-                pprFamily mbFamInst])
+                pprAxiom mbAxiom])
   where
     pp_nd = case condecls of
                 IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis)
-                IfOpenDataTyCon     -> ptext (sLit "data family")
+                IfDataFamTyCon     -> ptext (sLit "data family")
                 IfDataTyCon _       -> ptext (sLit "data")
                 IfNewTyCon _        -> ptext (sLit "newtype")
 
@@ -499,12 +484,17 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
                 sep (map ppr ats),
                 sep (map ppr sigs)])
 
+pprIfaceDecl (IfaceAxiom {ifName = name, ifTyVars = tyvars,
+                          ifLHS = lhs, ifRHS = rhs})
+  = hang (ptext (sLit "axiom") <+> ppr name <+> ppr tyvars)
+       2 (dcolon <+> ppr lhs <+> text "~#" <+> ppr rhs)
+
 pprRec :: RecFlag -> SDoc
 pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec
 
-pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc
-pprFamily Nothing        = ptext (sLit "FamilyInstance: none")
-pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst
+pprAxiom :: Maybe Name -> SDoc
+pprAxiom Nothing   = ptext (sLit "FamilyInstance: none")
+pprAxiom (Just ax) = ptext (sLit "FamilyInstance:") <+> ppr ax
 
 instance Outputable IfaceClassOp where
    ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
@@ -522,7 +512,7 @@ pprIfaceDeclHead context thing tyvars
 
 pp_condecls :: OccName -> IfaceConDecls -> SDoc
 pp_condecls _  (IfAbstractTyCon {}) = empty
-pp_condecls _  IfOpenDataTyCon      = empty
+pp_condecls _  IfDataFamTyCon      = empty
 pp_condecls tc (IfNewTyCon c)   = equals <+> pprIfaceConDecl tc c
 pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
                                                             (map (pprIfaceConDecl tc) cs))
@@ -571,8 +561,8 @@ instance Outputable IfaceRule where
                         ptext (sLit "=") <+> ppr rhs])
       ]
 
-instance Outputable IfaceInst where
-  ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
+instance Outputable IfaceClsInst where
+  ppr (IfaceClsInst {ifDFun = dfun_id, ifOFlag = flag,
                   ifInstCls = cls, ifInstTys = mb_tcs})
     = hang (ptext (sLit "instance") <+> ppr flag
                 <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
@@ -580,10 +570,10 @@ instance Outputable IfaceInst where
 
 instance Outputable IfaceFamInst where
   ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
-                     ifFamInstTyCon = tycon_id})
+                     ifFamInstAxiom = tycon_ax})
     = hang (ptext (sLit "family instance") <+>
             ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
-         2 (equals <+> ppr tycon_id)
+         2 (equals <+> ppr tycon_ax)
 
 ppr_rough :: Maybe IfaceTyCon -> SDoc
 ppr_rough Nothing   = dot
@@ -741,13 +731,12 @@ freeNamesIfDecl IfaceForeign{} =
   emptyNameSet
 freeNamesIfDecl d@IfaceData{} =
   freeNamesIfTvBndrs (ifTyVars d) &&&
-  freeNamesIfTcFam (ifFamInst d) &&&
+  maybe emptyNameSet unitNameSet (ifAxiom d) &&&
   freeNamesIfContext (ifCtxt d) &&&
   freeNamesIfConDecls (ifCons d)
 freeNamesIfDecl d@IfaceSyn{} =
   freeNamesIfTvBndrs (ifTyVars d) &&&
   freeNamesIfSynRhs (ifSynRhs d) &&&
-  freeNamesIfTcFam (ifFamInst d) &&&
   freeNamesIfKind (ifSynKind d) -- IA0_NOTE: because of promotion, we
                                 -- return names in the kind signature
 freeNamesIfDecl d@IfaceClass{} =
@@ -755,6 +744,10 @@ freeNamesIfDecl d@IfaceClass{} =
   freeNamesIfContext (ifCtxt d) &&&
   fnList freeNamesIfAT     (ifATs d) &&&
   fnList freeNamesIfClsSig (ifSigs d)
+freeNamesIfDecl d@IfaceAxiom{} =
+  freeNamesIfTvBndrs (ifTyVars d) &&&
+  freeNamesIfType (ifLHS d) &&&
+  freeNamesIfType (ifRHS d)
 
 freeNamesIfIdDetails :: IfaceIdDetails -> NameSet
 freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc
@@ -765,12 +758,6 @@ freeNamesIfSynRhs :: Maybe IfaceType -> NameSet
 freeNamesIfSynRhs (Just ty) = freeNamesIfType ty
 freeNamesIfSynRhs Nothing   = emptyNameSet
 
-freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet
-freeNamesIfTcFam (Just (tc,tys)) =
-  freeNamesIfTc tc &&& fnList freeNamesIfType tys
-freeNamesIfTcFam Nothing =
-  emptyNameSet
-
 freeNamesIfContext :: IfaceContext -> NameSet
 freeNamesIfContext = fnList freeNamesIfType
 
@@ -902,6 +889,12 @@ freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
     fnList freeNamesIfBndr bs &&&
     fnList freeNamesIfExpr es &&&
     freeNamesIfExpr rhs
+    
+freeNamesIfFamInst :: IfaceFamInst -> NameSet
+freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName
+                                 , ifFamInstAxiom = axName })
+  = unitNameSet famName &&&
+    unitNameSet axName
 
 -- helpers
 (&&&) :: NameSet -> NameSet -> NameSet
index 7df2f49..ec1205f 100644 (file)
@@ -236,7 +236,7 @@ loadInterface doc_str mod from
         --
         -- The main thing is to add the ModIface to the PIT, but
         -- we also take the
-        --      IfaceDecls, IfaceInst, IfaceFamInst, IfaceRules, IfaceVectInfo
+        --      IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules, IfaceVectInfo
         -- out of the ModIface and put them into the big EPS pools
 
         -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined
@@ -372,7 +372,7 @@ loadDecl ignore_prags mod (_version, decl)
                 -- the names associated with the decl
           main_name      <- lookupOrig mod (ifName decl)
 --        ; traceIf (text "Loading decl for " <> ppr main_name)
-        ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclSubBndrs decl)
+        ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl)
 
         -- Typecheck the thing, lazily
         -- NB. Firstly, the laziness is there in case we never need the
@@ -402,7 +402,7 @@ loadDecl ignore_prags mod (_version, decl)
         -- (where the "MkT" is the *Name* associated with MkT, etc.)
         --
         -- We do this by mapping the implict_names to the associated
-        -- TyThings.  By the invariant on ifaceDeclSubBndrs and
+        -- TyThings.  By the invariant on ifaceDeclImplicitBndrs and
         -- implicitTyThings, we can use getOccName on the implicit
         -- TyThings to make this association: each Name's OccName should
         -- be the OccName of exactly one implictTyThing.  So the key is
index 2125181..4e8c96b 100644 (file)
@@ -68,6 +68,7 @@ import CoreFVs
 import Class
 import Kind
 import TyCon
+import Coercion         ( coAxiomSplitLHS )
 import DataCon
 import Type
 import TcType
@@ -261,8 +262,9 @@ mkIface_ hsc_env maybe_old_fingerprint
                 ; iface_insts = map instanceToIfaceInst insts
                 ; iface_fam_insts = map famInstToIfaceFamInst fam_insts
                 ; iface_vect_info = flattenVectInfo vect_info
-                -- Check if we are in Safe Inference mode but we failed to pass
-                -- the muster
+
+                -- Check if we are in Safe Inference mode 
+                -- but we failed to pass the muster
                 ; safeMode    = if safeInferOn dflags && not safeInf
                                     then Sf_None
                                     else safeHaskell dflags
@@ -361,7 +363,7 @@ mkIface_ hsc_env maybe_old_fingerprint
      deliberatelyOmitted :: String -> a
      deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
 
-     ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
+     ifFamInstTcName = ifFamInstFam
 
      flattenVectInfo (VectInfo { vectInfoVar          = vVar
                                , vectInfoTyCon        = vTyCon
@@ -430,7 +432,8 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
         -- see IfaceDeclABI below.
        declABI :: IfaceDecl -> IfaceDeclABI 
        declABI decl = (this_mod, decl, extras)
-        where extras = declExtras fix_fn non_orph_rules non_orph_insts decl
+        where extras = declExtras fix_fn non_orph_rules non_orph_insts
+                                  non_orph_fis decl
 
        edges :: [(IfaceDeclABI, Unique, [Unique])]
        edges = [ (abi, getUnique (ifName decl), out)
@@ -451,7 +454,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
        parent_map :: OccEnv OccName
        parent_map = foldr extend emptyOccEnv new_decls
           where extend d env = 
-                  extendOccEnvList env [ (b,n) | b <- ifaceDeclSubBndrs d ]
+                  extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]
                   where n = ifName d
 
         -- strongly-connected groups of declarations, in dependency order
@@ -473,8 +476,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
           | otherwise
           = ASSERT2( isExternalName name, ppr name )
             let hash | nameModule name /= this_mod =  global_hash_fn name
-                     | otherwise = 
-                        snd (lookupOccEnv local_env (getOccName name)
+                     | otherwise = snd (lookupOccEnv local_env (getOccName name)
                            `orElse` pprPanic "urk! lookup local fingerprint" 
                                        (ppr name)) -- (undefined,fingerprint0))
                 -- This panic indicates that we got the dependency
@@ -484,8 +486,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
                 -- pprTraces below, run the compile again, and inspect
                 -- the output and the generated .hi file with
                 -- --show-iface.
-            in 
-            put_ bh hash
+            in put_ bh hash
 
         -- take a strongly-connected group of declarations and compute
         -- its fingerprint.
@@ -530,7 +531,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
                        -> IO (OccEnv (OccName,Fingerprint))
        extend_hash_env env0 (hash,d) = do
           let
-            sub_bndrs = ifaceDeclSubBndrs d
+            sub_bndrs = ifaceDeclImplicitBndrs d
             fp_sub_bndr occ = computeFingerprint putNameLiterally (hash,occ)
           --
           sub_fps <- mapM fp_sub_bndr sub_bndrs
@@ -561,7 +562,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
    dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
 
    orphan_hash <- computeFingerprint (mk_put_name local_env)
-                      (map ifDFun orph_insts, orph_rules, fam_insts)
+                      (map ifDFun orph_insts, orph_rules, orph_fis)
 
    -- the export list hash doesn't depend on the fingerprints of
    -- the Names it mentions, only the Names themselves, hence putNameLiterally.
@@ -619,7 +620,9 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
                 mi_exp_hash    = export_hash,
                 mi_orphan_hash = orphan_hash,
                 mi_flag_hash   = flag_hash,
-                mi_orphan      = not (null orph_rules && null orph_insts
+                mi_orphan      = not (   null orph_rules
+                                      && null orph_insts
+                                      && null orph_fis
                                       && null (ifaceVectInfoVar (mi_vect_info iface0))),
                 mi_finsts      = not . null $ mi_fam_insts iface0,
                 mi_decls       = sorted_decls,
@@ -631,12 +634,9 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
     this_mod = mi_module iface0
     dflags = hsc_dflags hsc_env
     this_pkg = thisPackage dflags
-    (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0)
-    (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0)
-        -- See Note [Orphans] in IfaceSyn
-        -- ToDo: shouldn't we be splitting fam_insts into orphans and
-        -- non-orphans?
-    fam_insts = mi_fam_insts iface0
+    (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    (mi_insts iface0)
+    (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    (mi_rules iface0)
+    (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)
     fix_fn = mi_fix_fn iface0
 
 
@@ -700,7 +700,7 @@ data IfaceDeclExtras
 
   | IfaceDataExtras  
        Fixity                   -- Fixity of the tycon itself
-       [IfaceInstABI]           -- Local instances of this tycon
+       [IfaceInstABI]           -- Local class and family instances of this tycon
                                 -- See Note [Orphans] in IfaceSyn
        [(Fixity,[IfaceRule])]   -- For each construcotr, fixity and RULES
 
@@ -711,10 +711,16 @@ data IfaceDeclExtras
                                 -- See Note [Orphans] in IfaceSyn
        [(Fixity,[IfaceRule])]   -- For each class method, fixity and RULES
 
-  | IfaceSynExtras   Fixity
+  | IfaceSynExtras   Fixity [IfaceInstABI]
 
   | IfaceOtherDeclExtras
 
+-- When hashing a class or family instance, we hash only the 
+-- DFunId or CoAxiom, because that depends on all the 
+-- information about the instance.
+--
+type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance
+
 abiDecl :: IfaceDeclABI -> IfaceDecl
 abiDecl (_, decl, _) = decl
 
@@ -733,8 +739,8 @@ freeNamesDeclExtras (IfaceDataExtras  _ insts subs)
   = unionManyNameSets (mkNameSet insts : map freeNamesSub subs)
 freeNamesDeclExtras (IfaceClassExtras _ insts subs)
   = unionManyNameSets (mkNameSet insts : map freeNamesSub subs)
-freeNamesDeclExtras (IfaceSynExtras _)
-  = emptyNameSet
+freeNamesDeclExtras (IfaceSynExtras _ insts)
+  = mkNameSet insts
 freeNamesDeclExtras IfaceOtherDeclExtras
   = emptyNameSet
 
@@ -744,9 +750,9 @@ freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules)
 instance Outputable IfaceDeclExtras where
   ppr IfaceOtherDeclExtras       = empty
   ppr (IfaceIdExtras  fix rules) = ppr_id_extras fix rules
-  ppr (IfaceSynExtras fix)       = ppr fix
-  ppr (IfaceDataExtras fix insts stuff)  = vcat [ppr fix, ppr_insts insts,
-                                                 ppr_id_extras_s stuff]
+  ppr (IfaceSynExtras fix finsts) = vcat [ppr fix, ppr finsts]
+  ppr (IfaceDataExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts,
+                                                ppr_id_extras_s stuff]
   ppr (IfaceClassExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts,
                                                  ppr_id_extras_s stuff]
 
@@ -768,24 +774,26 @@ instance Binary IfaceDeclExtras where
    putByte bh 2; put_ bh fix; put_ bh insts; put_ bh cons
   put_ bh (IfaceClassExtras fix insts methods) = do
    putByte bh 3; put_ bh fix; put_ bh insts; put_ bh methods
-  put_ bh (IfaceSynExtras fix) = do
-   putByte bh 4; put_ bh fix
+  put_ bh (IfaceSynExtras fix finsts) = do
+   putByte bh 4; put_ bh fix; put_ bh finsts
   put_ bh IfaceOtherDeclExtras = do
    putByte bh 5
 
 declExtras :: (OccName -> Fixity)
            -> OccEnv [IfaceRule]
-           -> OccEnv [IfaceInst]
+           -> OccEnv [IfaceClsInst]
+           -> OccEnv [IfaceFamInst]
            -> IfaceDecl
            -> IfaceDeclExtras
 
-declExtras fix_fn rule_env inst_env decl
+declExtras fix_fn rule_env inst_env fi_env decl
   = case decl of
       IfaceId{} -> IfaceIdExtras (fix_fn n) 
                         (lookupOccEnvL rule_env n)
       IfaceData{ifCons=cons} -> 
                      IfaceDataExtras (fix_fn n)
-                        (map ifDFun $ lookupOccEnvL inst_env n)
+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++
+                         map ifDFun         (lookupOccEnvL inst_env n))
                         (map (id_extras . ifConOcc) (visibleIfConDecls cons))
       IfaceClass{ifSigs=sigs, ifATs=ats} -> 
                      IfaceClassExtras (fix_fn n)
@@ -794,18 +802,14 @@ declExtras fix_fn rule_env inst_env decl
                            -- Include instances of the associated types
                            -- as well as instances of the class (Trac #5147)
                         [id_extras op | IfaceClassOp op _ _ <- sigs]
-      IfaceSyn{} -> IfaceSynExtras (fix_fn n)
+      IfaceSyn{} -> IfaceSynExtras (fix_fn n) 
+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n))
       _other -> IfaceOtherDeclExtras
   where
         n = ifName decl
         id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
         at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (ifName decl)
 
---
--- When hashing an instance, we hash only the DFunId, because that
--- depends on all the information about the instance.
---
-type IfaceInstABI = IfExtName
 
 lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
 lookupOccEnvL env k = lookupOccEnv env k `orElse` []
@@ -837,7 +841,7 @@ oldMD5 dflags bh = do
         return $! readHexFingerprint hash_str
 -}
 
-instOrphWarn :: PrintUnqualified -> Instance -> WarnMsg
+instOrphWarn :: PrintUnqualified -> ClsInst -> WarnMsg
 instOrphWarn unqual inst
   = mkWarnMsg (getSrcSpan inst) unqual $
     hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst)
@@ -1419,9 +1423,7 @@ tyThingToIfaceDecl (ATyCon tycon)
   = IfaceSyn {  ifName    = getOccName tycon,
                 ifTyVars  = toIfaceTvBndrs tyvars,
                 ifSynRhs  = syn_rhs,
-                ifSynKind = syn_ki,
-                ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
-             }
+                ifSynKind = syn_ki }
 
   | isAlgTyCon tycon
   = IfaceData { ifName    = getOccName tycon,
@@ -1430,7 +1432,7 @@ tyThingToIfaceDecl (ATyCon tycon)
                 ifCons    = ifaceConDecls (algTyConRhs tycon),
                 ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
                 ifGadtSyntax = isGadtSyntaxTyCon tycon,
-                ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
+                ifAxiom   = fmap coAxiomName (tyConFamilyCoercion_maybe tycon) }
 
   | isForeignTyCon tycon
   = IfaceForeign { ifName    = getOccName tycon,
@@ -1448,7 +1450,7 @@ tyThingToIfaceDecl (ATyCon tycon)
       IfNewTyCon  (ifaceConDecl con)
     ifaceConDecls (DataTyCon { data_cons = cons })  = 
       IfDataTyCon (map ifaceConDecl cons)
-    ifaceConDecls DataFamilyTyCon {}                = IfOpenDataTyCon
+    ifaceConDecls DataFamilyTyCon {}                = IfDataFamTyCon
     ifaceConDecls (AbstractTyCon distinct)          = IfAbstractTyCon distinct
         -- The last case happens when a TyCon has been trimmed during tidying
         -- Furthermore, tyThingToIfaceDecl is also used
@@ -1472,11 +1474,16 @@ tyThingToIfaceDecl (ATyCon tycon)
 
     to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec]
 
-    famInstToIface Nothing                    = Nothing
-    famInstToIface (Just (famTyCon, instTys)) = 
-      Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
-
-tyThingToIfaceDecl c@(ACoAxiom _) = pprPanic "tyThingToIfaceDecl (ACoCon _)" (ppr c)
+tyThingToIfaceDecl (ACoAxiom ax)
+ = IfaceAxiom { ifName = name
+              , ifTyVars = tv_bndrs
+              , ifLHS = lhs
+              , ifRHS = rhs }
+ where
+   name = getOccName ax
+   tv_bndrs = toIfaceTvBndrs (coAxiomTyVars ax)
+   lhs = toIfaceType (coAxiomLHS ax)
+   rhs = toIfaceType (coAxiomRHS ax)
 
 tyThingToIfaceDecl (ADataCon dc)
  = pprPanic "toIfaceDecl" (ppr dc)      -- Should be trimmed out earlier
@@ -1527,11 +1534,11 @@ getFS :: NamedThing a => a -> FastString
 getFS x = occNameFS (getOccName x)
 
 --------------------------
-instanceToIfaceInst :: Instance -> IfaceInst
-instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
+instanceToIfaceInst :: ClsInst -> IfaceClsInst
+instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag,
                                 is_cls = cls_name, is_tcs = mb_tcs })
   = ASSERT( cls_name == className cls )
-    IfaceInst { ifDFun    = dfun_name,
+    IfaceClsInst { ifDFun    = dfun_name,
                 ifOFlag   = oflag,
                 ifInstCls = cls_name,
                 ifInstTys = map do_rough mb_tcs,
@@ -1569,16 +1576,34 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
 
 --------------------------
 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
-famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
-                                 fi_fam = fam,
-                                 fi_tcs = mb_tcs })
-  = IfaceFamInst { ifFamInstTyCon  = toIfaceTyCon tycon
-                 , ifFamInstFam    = fam
-                 , ifFamInstTys    = map do_rough mb_tcs }
+famInstToIfaceFamInst (FamInst { fi_axiom  = axiom,
+                                 fi_fam    = fam,
+                                 fi_tcs    = mb_tcs })
+  = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom
+                 , ifFamInstFam   = fam
+                 , ifFamInstTys   = map do_rough mb_tcs
+                 , ifFamInstOrph  = orph }
   where
     do_rough Nothing  = Nothing
     do_rough (Just n) = Just (toIfaceTyCon_name n)
 
+    fam_decl = tyConName . fst $ coAxiomSplitLHS axiom
+    mod = ASSERT( isExternalName (coAxiomName axiom) )
+          nameModule (coAxiomName axiom)
+    is_local name = nameIsLocalOrFrom mod name
+
+    lhs_names = filterNameSet is_local (orphNamesOfType (coAxiomLHS axiom))
+
+    orph | is_local fam_decl
+         = Just (nameOccName fam_decl)
+
+         | not (isEmptyNameSet lhs_names)
+         = Just (nameOccName (head (nameSetToList lhs_names)))
+
+
+         | otherwise
+         = Nothing
+
 --------------------------
 toIfaceLetBndr :: Id -> IfaceLetBndr
 toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
index a662d6a..570a631 100644 (file)
@@ -436,31 +436,41 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
                           ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
                           ifCons = rdr_cons, 
                           ifRec = is_rec, 
-                          ifFamInst = mb_family })
+                          ifAxiom = mb_axiom_name })
   = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
     { tc_name <- lookupIfaceTop occ_name
-    ; tycon <- fixM ( \ tycon -> do
+    ; tycon <- fixM $ \ tycon -> do
             { stupid_theta <- tcIfaceCtxt ctxt
+            ; parent' <- tc_parent tyvars mb_axiom_name
             ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
-            ; mb_fam_inst  <- tcFamInst mb_family
-            ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
-                            gadt_syn parent mb_fam_inst
-            })
+            ; return (buildAlgTyCon tc_name tyvars stupid_theta 
+                                    cons is_rec gadt_syn parent') }
     ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
     ; return (ATyCon tycon) }
+  where
+    tc_parent :: [TyVar] -> Maybe Name -> IfL TyConParent
+    tc_parent _ Nothing = return parent
+    tc_parent tyvars (Just ax_name)
+      = ASSERT( isNoParent parent )
+        do { ax <- tcIfaceCoAxiom ax_name
+           ; let (fam_tc, fam_tys) = coAxiomSplitLHS ax
+                 subst = zipTopTvSubst (coAxiomTyVars ax) (mkTyVarTys tyvars)
+                            -- The subst matches the tyvar of the TyCon
+                            -- with those from the CoAxiom.  They aren't
+                            -- necessarily the same, since the two may be
+                            -- gotten from separate interface-file declarations
+           ; return (FamInstTyCon ax fam_tc (substTys subst fam_tys)) }
 
 tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
                                   ifSynRhs = mb_rhs_ty,
-                                  ifSynKind = kind, ifFamInst = mb_family})
+                                  ifSynKind = kind })
    = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
      { tc_name  <- lookupIfaceTop occ_name
      ; rhs_kind <- tcIfaceType kind     -- Note [Synonym kind loop]
      ; rhs      <- forkM (mk_doc tc_name) $ 
                    tc_syn_rhs mb_rhs_ty
-     ; fam_info <- tcFamInst mb_family
-     ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent fam_info
-     ; return (ATyCon tycon)
-     }
+     ; tycon    <- buildSynTyCon tc_name tyvars rhs rhs_kind parent
+     ; return (ATyCon tycon) }
    where
      mk_doc n = ptext (sLit "Type syonym") <+> ppr n
      tc_syn_rhs Nothing   = return SynFamilyTyCon
@@ -493,14 +503,10 @@ tc_iface_decl _parent ignore_prags
           ; return (op_name, dm, op_ty) }
 
    tc_at cls (IfaceAT tc_decl defs_decls)
-     = do tc <- tc_iface_tc_decl (AssocFamilyTyCon cls) tc_decl
+     = do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl
           defs <- mapM tc_iface_at_def defs_decls
           return (tc, defs)
 
-   tc_iface_tc_decl parent decl = do
-       ATyCon tc <- tc_iface_decl parent ignore_prags decl
-       return tc
-
    tc_iface_at_def (IfaceATD tvs pat_tys ty) =
        bindIfaceTyVars_AT tvs $
          \tvs' -> liftM2 (\pats tys -> ATD tvs' pats tys noSrcSpan)
@@ -517,17 +523,25 @@ tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
         ; return (ATyCon (mkForeignTyCon name ext_name 
                                          liftedTypeKind 0)) }
 
-tcFamInst :: Maybe (IfaceTyCon, [IfaceType]) -> IfL (Maybe (TyCon, [Type]))
-tcFamInst Nothing           = return Nothing
-tcFamInst (Just (fam, tys)) = do { famTyCon <- tcIfaceTyCon fam
-                                 ; insttys <- mapM tcIfaceType tys
-                                 ; return $ Just (famTyCon, insttys) }
+tc_iface_decl _ _ (IfaceAxiom {ifName = tc_occ, ifTyVars = tv_bndrs,
+                               ifLHS = lhs, ifRHS = rhs })
+  = bindIfaceTyVars tv_bndrs $ \ tvs -> do
+    { tc_name <- lookupIfaceTop tc_occ
+    ; tc_lhs  <- tcIfaceType lhs
+    ; tc_rhs  <- tcIfaceType rhs
+    ; let axiom = CoAxiom { co_ax_unique   = nameUnique tc_name
+                          , co_ax_name     = tc_name
+                          , co_ax_implicit = False
+                          , co_ax_tvs      = tvs
+                          , co_ax_lhs      = tc_lhs
+                          , co_ax_rhs      = tc_rhs }
+    ; return (ACoAxiom axiom) }
 
 tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
 tcIfaceDataCons tycon_name tycon _ if_cons
   = case if_cons of
         IfAbstractTyCon dis -> return (AbstractTyCon dis)
-        IfOpenDataTyCon  -> return DataFamilyTyCon
+        IfDataFamTyCon  -> return DataFamilyTyCon
         IfDataTyCon cons -> do  { data_cons <- mapM tc_con_decl cons
                                 ; return (mkDataTyConRhs data_cons) }
         IfNewTyCon con   -> do  { data_con <- tc_con_decl con
@@ -603,8 +617,8 @@ look at it.
 %************************************************************************
 
 \begin{code}
-tcIfaceInst :: IfaceInst -> IfL Instance
-tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
+tcIfaceInst :: IfaceClsInst -> IfL ClsInst
+tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag,
                               ifInstCls = cls, ifInstTys = mb_tcs })
   = do { dfun    <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
                      tcIfaceExtId dfun_occ
@@ -612,14 +626,12 @@ tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
        ; return (mkImportedInstance cls mb_tcs' dfun oflag) }
 
 tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
-tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, 
-                               ifFamInstFam = fam, ifFamInstTys = mb_tcs })
---      { tycon'  <- forkM (ptext (sLit "Inst tycon") <+> ppr tycon) $
--- the above line doesn't work, but this below does => CPP in Haskell = evil!
-    = do tycon'  <- forkM (text ("Inst tycon") <+> ppr tycon) $
-                    tcIfaceTyCon tycon
+tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
+                             , ifFamInstAxiom = axiom_name } )
+    = do axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $
+                   tcIfaceCoAxiom axiom_name
          let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
-         return (mkImportedFamInst fam mb_tcs' tycon')
+         return (mkImportedFamInst fam mb_tcs' axiom')
 \end{code}
 
 
index a9684a6..591419a 100644 (file)
@@ -1,10 +1,10 @@
 \begin{code}
 module TcIface where
 
-import IfaceSyn    ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule, IfaceAnnotation )
+import IfaceSyn    ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule, IfaceAnnotation )
 import TypeRep     ( TyThing )
 import TcRnTypes   ( IfL )
-import InstEnv     ( Instance )
+import InstEnv     ( ClsInst )
 import FamInstEnv  ( FamInst )
 import CoreSyn     ( CoreRule )
 import HscTypes    ( TypeEnv, VectInfo, IfaceVectInfo )
@@ -14,7 +14,7 @@ import Annotations ( Annotation )
 tcIfaceDecl        :: Bool -> IfaceDecl -> IfL TyThing
 tcIfaceRules       :: Bool -> [IfaceRule] -> IfL [CoreRule]
 tcIfaceVectInfo    :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
-tcIfaceInst        :: IfaceInst -> IfL Instance
+tcIfaceInst        :: IfaceClsInst -> IfL ClsInst
 tcIfaceFamInst     :: IfaceFamInst -> IfL FamInst
 tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
 \end{code}
index df670f1..6c31e2e 100644 (file)
@@ -168,7 +168,7 @@ module GHC (
         pprFundeps,
 
         -- ** Instances
-        Instance
+        ClsInst
         instanceDFunId, 
         pprInstance, pprInstanceHdr,
         pprFamInst, pprFamInstHdr,
@@ -915,7 +915,7 @@ getBindings = withSession $ \hsc_env ->
     return $ icInScopeTTs $ hsc_IC hsc_env
 
 -- | Return the instances for the current interactive session.
-getInsts :: GhcMonad m => m ([Instance], [FamInst])
+getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
 getInsts = withSession $ \hsc_env ->
     return $ ic_instances (hsc_IC hsc_env)
 
@@ -928,7 +928,7 @@ data ModuleInfo = ModuleInfo {
         minf_type_env  :: TypeEnv,
         minf_exports   :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
         minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
-        minf_instances :: [Instance],
+        minf_instances :: [ClsInst],
         minf_iface     :: Maybe ModIface
 #ifdef GHCI
        ,minf_modBreaks :: ModBreaks 
@@ -1011,7 +1011,7 @@ modInfoExports minf = nameSetToList $! minf_exports minf
 
 -- | Returns the instances defined by the specified module.
 -- Warning: currently unimplemented for package modules.
-modInfoInstances :: ModuleInfo -> [Instance]
+modInfoInstances :: ModuleInfo -> [ClsInst]
 modInfoInstances = minf_instances
 
 modInfoIsExportedName :: ModuleInfo -> Name -> Bool
index 2882816..8c9e9a8 100644 (file)
@@ -296,7 +296,7 @@ hscTcRcLookupName hsc_env name =
       -- "name not found", and the Maybe in the return type
       -- is used to indicate that.
 
-hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [Instance]))
+hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst]))
 hscTcRnGetInfo hsc_env name =
     runHsc hsc_env $ ioMsgMaybe' $ tcRnGetInfo hsc_env name
 
index 6b389fd..3eda19f 100644 (file)
@@ -119,7 +119,7 @@ import HsSyn
 import RdrName
 import Avail
 import Module
-import InstEnv          ( InstEnv, Instance )
+import InstEnv          ( InstEnv, ClsInst )
 import FamInstEnv
 import Rules            ( RuleBase )
 import CoreSyn          ( CoreProgram )
@@ -467,7 +467,7 @@ lookupIfaceByModule dflags hpt pit mod
 -- modules imported by this one, directly or indirectly, and are in the Home
 -- Package Table.  This ensures that we don't see instances from modules @--make@
 -- compiled before this one, but which are not below this one.
-hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([Instance], [FamInst])
+hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])
 hptInstances hsc_env want_this_module
   = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do
                 guard (want_this_module (moduleName (mi_module (hm_iface mod_info))))
@@ -693,7 +693,7 @@ data ModIface
                 -- 'HomeModInfo', but that leads to more plumbing.
 
                 -- Instance declarations and rules
-        mi_insts       :: [IfaceInst],     -- ^ Sorted class instance
+        mi_insts       :: [IfaceClsInst],     -- ^ Sorted class instance
         mi_fam_insts   :: [IfaceFamInst],  -- ^ Sorted family instances
         mi_rules       :: [IfaceRule],     -- ^ Sorted rules
         mi_orphan_hash :: !Fingerprint,    -- ^ Hash for orphan rules and class
@@ -771,7 +771,7 @@ data ModDetails
         -- The next two fields are created by the typechecker
         md_exports   :: [AvailInfo],
         md_types     :: !TypeEnv,       -- ^ Local type environment for this particular module
-        md_insts     :: ![Instance],    -- ^ 'DFunId's for the instances in this module
+        md_insts     :: ![ClsInst],    -- ^ 'DFunId's for the instances in this module
         md_fam_insts :: ![FamInst],
         md_rules     :: ![CoreRule],    -- ^ Domain may include 'Id's from other modules
         md_anns      :: ![Annotation],  -- ^ Annotations present in this module: currently
@@ -817,7 +817,7 @@ data ModGuts
                                          -- ToDo: I'm unconvinced this is actually used anywhere
         mg_tcs       :: ![TyCon],        -- ^ TyCons declared in this module
                                          -- (includes TyCons for classes)
-        mg_insts     :: ![Instance],     -- ^ Class instances declared in this module
+        mg_insts     :: ![ClsInst],     -- ^ Class instances declared in this module
         mg_fam_insts :: ![FamInst],      -- ^ Family instances declared in this module
         mg_rules     :: ![CoreRule],     -- ^ Before the core pipeline starts, contains
                                          -- See Note [Overall plumbing for rules] in Rules.lhs
@@ -937,7 +937,7 @@ data InteractiveContext
              -- ^ Variables defined automatically by the system (e.g.
              -- record field selectors).  See Notes [ic_sys_vars]
 
-         ic_instances  :: ([Instance], [FamInst]),
+         ic_instances  :: ([ClsInst], [FamInst]),
              -- ^ All instances and family instances created during
              -- this session.  These are grabbed en masse after each
              -- update to be sure that proper overlapping is retained.
@@ -1163,10 +1163,34 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
 
 %************************************************************************
 %*                                                                      *
-                TyThing
+                Implicit TyThings
 %*                                                                      *
 %************************************************************************
 
+Note [Implicit TyThings]
+~~~~~~~~~~~~~~~~~~~~~~~~
+  DEFINITION: An "implicit" TyThing is one that does not have its own
+  IfaceDecl in an interface file.  Instead, its binding in the type
+  environment is created as part of typechecking the IfaceDecl for
+  some other thing.
+
+Examples:
+  * All DataCons are implicit, because they are generated from the
+    IfaceDecl for the data/newtype.  Ditto class methods.
+
+  * Record selectors are *not* implicit, because they get their own
+    free-standing IfaceDecl.
+
+  * Associated data/type families are implicit because they are
+    included in the IfaceDecl of the parent class.  (NB: the
+    IfaceClass decl happens to use IfaceDecl recursively for the
+    associated types, but that's irrelevant here.)
+
+  * Dictionary function Ids are not implict.
+
+  * Axioms for newtypes are implicit (same as above), but axioms
+    for data/type family instances are *not* implicit (like DFunIds).
+
 \begin{code}
 -- | Determine the 'TyThing's brought into scope by another 'TyThing'
 -- /other/ than itself. For example, Id's don't have any implicit TyThings
@@ -1175,7 +1199,7 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
 -- scope, just for a start!
 
 -- N.B. the set of TyThings returned here *must* match the set of
--- names returned by LoadIface.ifaceDeclSubBndrs, in the sense that
+-- names returned by LoadIface.ifaceDeclImplicitBndrs, in the sense that
 -- TyThing.getOccName should define a bijection between the two lists.
 -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
 -- The order of the list does not matter.
@@ -1201,9 +1225,10 @@ implicitTyConThings :: TyCon -> [TyThing]
 implicitTyConThings tc
   = class_stuff ++
       -- fields (names of selectors)
-      -- (possibly) implicit coercion and family coercion
-      --   depending on whether it's a newtype or a family instance or both
+
+      -- (possibly) implicit newtype coercion
     implicitCoTyCon tc ++
+
       -- for each data constructor in order,
       --   the contructor, worker, and (possibly) wrapper
     concatMap (extras_plus . ADataCon) (tyConDataCons tc)
@@ -1218,14 +1243,11 @@ implicitTyConThings tc
 extras_plus :: TyThing -> [TyThing]
 extras_plus thing = thing : implicitTyThings thing
 
--- For newtypes and indexed data types (and both),
--- add the implicit coercion tycon
+-- For newtypes (only) add the implicit coercion tycon
 implicitCoTyCon :: TyCon -> [TyThing]
 implicitCoTyCon tc
-  = map ACoAxiom . catMaybes $ [-- Just if newtype, Nothing if not
-                              newTyConCo_maybe tc,
-                              -- Just if family instance, Nothing if not
-                              tyConFamilyCoercion_maybe tc]
+  | Just co <- newTyConCo_maybe tc = [ACoAxiom co]
+  | otherwise                      = []
 
 -- | 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
@@ -1235,7 +1257,7 @@ isImplicitTyThing :: TyThing -> Bool
 isImplicitTyThing (ADataCon {}) = True
 isImplicitTyThing (AnId id)     = isImplicitId id
 isImplicitTyThing (ATyCon tc)   = isImplicitTyCon tc
-isImplicitTyThing (ACoAxiom {}) = True
+isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax
 
 -- | tyThingParent_maybe x returns (Just p)
 -- when pprTyThingInContext sould print a declaration for p
@@ -1321,13 +1343,14 @@ mkTypeEnvWithImplicits things =
   mkTypeEnv (concatMap implicitTyThings things)
 
 typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv
-typeEnvFromEntities ids tcs faminsts =
+typeEnvFromEntities ids tcs famInsts =
   mkTypeEnv (   map AnId ids
              ++ map ATyCon all_tcs
              ++ concatMap implicitTyConThings all_tcs
+             ++ map (ACoAxiom . famInstAxiom) famInsts
             )
  where
-  all_tcs = tcs ++ map famInstTyCon faminsts
+  all_tcs = tcs ++ famInstsRepTyCons famInsts
 
 lookupTypeEnv = lookupNameEnv
 
@@ -1432,7 +1455,7 @@ mkIfaceHashCache pairs
   = \occ -> lookupOccEnv env occ
   where
     env = foldr add_decl emptyOccEnv pairs
-    add_decl (v,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d)
+    add_decl (v,d) env0 = foldr add_imp env1 (ifaceDeclImplicitBndrs d)
       where
           decl_name = ifName d
           env1 = extendOccEnv env0 decl_name (decl_name, v)
index 3439231..eee5c00 100644 (file)
@@ -869,7 +869,7 @@ moduleIsInterpreted modl = withSession $ \h ->
 -- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
 -- The exact choice of which ones to show, and which to hide, is a judgement call.
 --      (see Trac #1581)
-getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))
+getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst]))
 getInfo name
   = withSession $ \hsc_env ->
     do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
index 830a352..5e2a937 100644 (file)
@@ -488,7 +488,7 @@ mustExposeTyCon exports tc
     exported_con con = any (`elemNameSet` exports) 
                           (dataConName con : dataConFieldLabels con)
 
-tidyInstances :: (DFunId -> DFunId) -> [Instance] -> [Instance]
+tidyInstances :: (DFunId -> DFunId) -> [ClsInst] -> [ClsInst]
 tidyInstances tidy_dfun ispecs
   = map tidy ispecs
   where
index 4f36d03..ccce0c9 100644 (file)
@@ -454,32 +454,45 @@ lookupOccRn rdr_name = do
 
 -- lookupPromotedOccRn looks up an optionally promoted RdrName.
 lookupPromotedOccRn :: RdrName -> RnM Name
--- see Note [Demotion] in OccName
-lookupPromotedOccRn rdr_name = do {
-    -- 1. lookup the name
-    opt_name <- lookupOccRn_maybe rdr_name 
-  ; case opt_name of
-      -- 1.a. we found it!
-      Just name -> return name
-      -- 1.b. we did not find it -> 2
-      Nothing -> do {
-  ; -- 2. maybe it was implicitly promoted
-    case demoteRdrName rdr_name of
-      -- 2.a it was not in a promoted namespace
-      Nothing -> err
-      -- 2.b let's try every thing again -> 3
-      Just demoted_rdr_name -> do {
-  ; poly_kinds <- xoptM Opt_PolyKinds
-    -- 3. lookup again
-  ; opt_demoted_name <- lookupOccRn_maybe demoted_rdr_name ;
-  ; case opt_demoted_name of
-      -- 3.a. it was implicitly promoted, but confirm that we can promote
-      -- JPM: We could try to suggest turning on PolyKinds here
-      Just demoted_name -> if poly_kinds then return demoted_name else err
-      -- 3.b. use rdr_name to have a correct error message
-      Nothing -> err } } }
-  where err = unboundName WL_Any rdr_name
+-- see Note [Demotion] 
+lookupPromotedOccRn rdr_name 
+  = do { mb_name <- lookupOccRn_maybe rdr_name 
+       ; case mb_name of {
+             Just name -> return name ;
+             Nothing   -> 
+
+    do { -- Maybe it's the name of a *data* constructor
+         poly_kinds <- xoptM Opt_PolyKinds
+       ; mb_demoted_name <- case demoteRdrName rdr_name of
+                              Just demoted_rdr -> lookupOccRn_maybe demoted_rdr
+                              Nothing          -> return Nothing
+       ; case mb_demoted_name of
+           Nothing -> unboundName WL_Any rdr_name
+           Just demoted_name 
+             | poly_kinds -> return demoted_name
+             | otherwise  -> unboundNameX WL_Any rdr_name suggest_pk }}}
+  where 
+    suggest_pk = ptext (sLit "A data constructor of that name is in scope; did you mean -XPolyKinds?")
+\end{code}
+
+Note [Demotion]
+~~~~~~~~~~~~~~~
+When the user writes:
+  data Nat = Zero | Succ Nat
+  foo :: f Zero -> Int
+
+'Zero' in the type signature of 'foo' is parsed as:
+  HsTyVar ("Zero", TcClsName)
 
+When the renamer hits this occurence of 'Zero' it's going to realise
+that it's not in scope. But because it is renaming a type, it knows
+that 'Zero' might be a promoted data constructor, so it will demote
+its namespace to DataName and do a second lookup.
+
+The final result (after the renamer) will be:
+  HsTyVar ("Zero", DataName)
+
+\begin{code}
 -- lookupOccRn looks up an occurrence of a RdrName
 lookupOccRn_maybe :: RdrName -> RnM (Maybe Name)
 lookupOccRn_maybe rdr_name
@@ -1125,13 +1138,16 @@ data WhereLooking = WL_Any        -- Any binding
                   | WL_LocalTop   -- Any top-level binding in this module
 
 unboundName :: WhereLooking -> RdrName -> RnM Name
-unboundName where_look rdr_name
+unboundName wl rdr = unboundNameX wl rdr empty
+
+unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name
+unboundNameX where_look rdr_name extra
   = do  { show_helpful_errors <- doptM Opt_HelpfulErrors
-        ; let err = unknownNameErr rdr_name
+        ; let err = unknownNameErr rdr_name $$ extra
         ; if not show_helpful_errors
           then addErr err
-          else do { extra_err <- unknownNameSuggestErr where_look rdr_name
-                  ; addErr (err $$ extra_err) }
+          else do { suggestions <- unknownNameSuggestErr where_look rdr_name
+                  ; addErr (err $$ suggestions) }
 
         ; env <- getGlobalRdrEnv;
        ; traceRn (vcat [unknownNameErr rdr_name, 
index 0a94b2b..6269051 100644 (file)
@@ -27,6 +27,7 @@ import SrcLoc
 import Outputable
 import UniqFM
 import FastString
+import VarSet   ( varSetElems )
 
 import Maybes
 import Control.Monad
@@ -166,7 +167,7 @@ then we have a coercion (ie, type instance of family instance coercion)
 which implies that :R42T was declared as 'data instance T [a]'.
 
 \begin{code}
-tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe (TyCon, [Type]))
+tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe (FamInst, [Type]))
 tcLookupFamInst tycon tys
   | not (isFamilyTyCon tycon)
   = return Nothing
@@ -176,7 +177,7 @@ tcLookupFamInst tycon tys
        ; case lookupFamInstEnv instEnv tycon tys of
           []                      -> return Nothing
           ((fam_inst, rep_tys):_) 
-             -> return $ Just (famInstTyCon fam_inst, rep_tys)
+             -> return $ Just (fam_inst, rep_tys)
        }
 
 tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
@@ -189,8 +190,9 @@ tcLookupDataFamInst tycon tys
   = ASSERT( isAlgTyCon tycon )
     do { maybeFamInst <- tcLookupFamInst tycon tys
        ; case maybeFamInst of
-           Nothing      -> famInstNotFound tycon tys
-           Just famInst -> return famInst }
+           Nothing             -> famInstNotFound tycon tys
+           Just (famInst, tys) -> let tycon' = dataFamInstRepTyCon famInst
+                                  in return (tycon', tys) }
 
 famInstNotFound :: TyCon -> [Type] -> TcM a
 famInstNotFound tycon tys 
@@ -250,7 +252,7 @@ addLocalFamInst home_fie famInst = do
     let inst_envs = (eps_fam_inst_env eps, home_fie)
 
         -- Check for conflicting instance decls
-    skol_tvs <- tcInstSkolTyVars (tyConTyVars (famInstTyCon famInst))
+    skol_tvs <- tcInstSkolTyVars (varSetElems (famInstTyVars famInst))
     let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs
     -- If there are any conflicts, we should probably error
     -- But, if we're allowed to overwrite and the conflict is in the home FIE,
@@ -285,7 +287,7 @@ checkForConflicts inst_envs famInst
                -- We use tcInstSkolType because we don't want to allocate
                -- fresh *meta* type variables.  
 
-       ; skol_tvs <- tcInstSkolTyVars (tyConTyVars (famInstTyCon famInst))
+       ; skol_tvs <- tcInstSkolTyVars (varSetElems (famInstTyVars famInst))
        ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs
        ; unless (null conflicts) $
           conflictInstErr famInst (fst (head conflicts))
index 34f6818..09ea2df 100644 (file)
@@ -395,7 +395,7 @@ tcGetInstEnvs :: TcM (InstEnv, InstEnv)
 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
                     return (eps_inst_env eps, tcg_inst_env env) }
 
-tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
+tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
   -- Add new locally-defined instances
 tcExtendLocalInstEnv dfuns thing_inside
  = do { traceDFuns dfuns
@@ -405,7 +405,7 @@ tcExtendLocalInstEnv dfuns thing_inside
                         tcg_inst_env = inst_env' }
       ; setGblEnv env' thing_inside }
 
-addLocalInst :: InstEnv -> Instance -> TcM InstEnv
+addLocalInst :: InstEnv -> ClsInst -> TcM InstEnv
 -- Check that the proposed new instance is OK, 
 -- and then add it to the home inst env
 -- If overwrite_inst, then we can overwrite a direct match
@@ -468,30 +468,30 @@ addLocalInst home_ie ispec = do
                     , let (_,_,_,dup_tys) = instanceHead dup_ispec
                     , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)]
 
-traceDFuns :: [Instance] -> TcRn ()
+traceDFuns :: [ClsInst] -> TcRn ()
 traceDFuns ispecs
   = traceTc "Adding instances:" (vcat (map pp ispecs))
   where
     pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
        -- Print the dfun name itself too
 
-funDepErr :: Instance -> [Instance] -> TcRn ()
+funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
 funDepErr ispec ispecs
   = addDictLoc ispec $
     addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
               2 (pprInstances (ispec:ispecs)))
-dupInstErr :: Instance -> Instance -> TcRn ()
+dupInstErr :: ClsInst -> ClsInst -> TcRn ()
 dupInstErr ispec dup_ispec
   = addDictLoc ispec $
     addErr (hang (ptext (sLit "Duplicate instance declarations:"))
               2 (pprInstances [ispec, dup_ispec]))
-overlappingInstErr :: Instance -> Instance -> TcRn ()
+overlappingInstErr :: ClsInst -> ClsInst -> TcRn ()
 overlappingInstErr ispec dup_ispec
   = addDictLoc ispec $
     addErr (hang (ptext (sLit "Overlapping instance declarations:"))
               2 (pprInstances [ispec, dup_ispec]))
 
-addDictLoc :: Instance -> TcRn a -> TcRn a
+addDictLoc :: ClsInst -> TcRn a -> TcRn a
 addDictLoc ispec thing_inside
   = setSrcSpan (mkSrcSpan loc loc) thing_inside
   where
index 67b36bf..480aa12 100644 (file)
@@ -338,14 +338,14 @@ tcDeriving tycl_decls inst_decls deriv_decls
   ; let all_tycons = map ATyCon (bagToList newTyCons)
   ; gbl_env <- tcExtendGlobalEnv all_tycons $
                tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $
-               tcExtendLocalFamInstEnv (map mkLocalFamInst (bagToList famInsts)) $
+               tcExtendLocalFamInstEnv (bagToList famInsts) $
                tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
 
   ; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) }
   where
     ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name 
-                   -> Bag TyCon  -- ^ Empty data constructors
-                   -> Bag TyCon  -- ^ Rep type family instances
+                   -> Bag TyCon    -- ^ Empty data constructors
+                   -> Bag FamInst  -- ^ Rep type family instances
                    -> SDoc
     ddump_deriving inst_infos extra_binds repMetaTys repTyCons
       =    hang (ptext (sLit "Derived instances:"))
@@ -355,9 +355,8 @@ tcDeriving tycl_decls inst_decls deriv_decls
               hangP "Generated datatypes for meta-information:"
                (vcat (map ppr (bagToList repMetaTys)))
            $$ hangP "Representation types:"
-                (vcat (map pprTyFamInst (bagToList repTyCons))))
+                (vcat (map ppr (bagToList repTyCons))))
     
-    pprTyFamInst t = ppr t <+> text "=" <+> ppr (synTyConType t)
     hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
 
 
@@ -1349,7 +1348,7 @@ inferInstanceContexts oflag infer_specs
         the_pred = mkClassPred clas inst_tys
 
 ------------------------------------------------------------------
-mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
+mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> ClsInst
 mkInstance overlap_flag theta
            (DS { ds_name = dfun_name
                , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
@@ -1358,7 +1357,7 @@ mkInstance overlap_flag theta
     dfun = mkDictFunId dfun_name tyvars theta clas tys
 
 
-extendLocalInstEnv :: [Instance] -> TcM a -> TcM a
+extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
 -- Add new locally-defined instances; don't bother to check
 -- for functional dependency errors -- that'll happen in TcInstDcls
 extendLocalInstEnv dfuns thing_inside
index 5c2c895..915978b 100644 (file)
@@ -17,7 +17,7 @@ module TcEnv(
         tcLookupLocatedGlobal, tcLookupGlobal, 
         tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
-        tcLookupLocatedClass, tcLookupInstance,
+        tcLookupLocatedClass, tcLookupInstance, tcLookupAxiom,
         
         -- Local environment
         tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTcTyThingEnv,
@@ -45,7 +45,7 @@ module TcEnv(
         topIdLvl, thTopLevelId, thRnBrack, isBrackStage,
 
         -- New Ids
-        newLocalName, newDFunName, newFamInstTyConName, 
+        newLocalName, newDFunName, newFamInstTyConName, newFamInstAxiomName,
         mkStableIdFromString, mkStableIdFromName
   ) where
 
@@ -164,6 +164,13 @@ tcLookupTyCon name = do
         ATyCon tc -> return tc
         _         -> wrongThingErr "type constructor" (AGlobal thing) name
 
+tcLookupAxiom :: Name -> TcM CoAxiom
+tcLookupAxiom name = do
+    thing <- tcLookupGlobal name
+    case thing of
+        ACoAxiom ax -> return ax
+        _           -> wrongThingErr "axiom" (AGlobal thing) name
+
 tcLookupLocatedGlobalId :: Located Name -> TcM Id
 tcLookupLocatedGlobalId = addLocM tcLookupId
 
@@ -176,7 +183,7 @@ tcLookupLocatedTyCon = addLocM tcLookupTyCon
 -- Find the instance that exactly matches a type class application.  The class arguments must be precisely
 -- the same as in the instance declaration (modulo renaming).
 --
-tcLookupInstance :: Class -> [Type] -> TcM Instance
+tcLookupInstance :: Class -> [Type] -> TcM ClsInst
 tcLookupInstance cls tys
   = do { instEnv <- tcGetInstEnvs
        ; case lookupUniqueInstEnv instEnv cls tys of
@@ -610,7 +617,7 @@ as well as explicit user written ones.
 \begin{code}
 data InstInfo a
   = InstInfo {
-      iSpec   :: Instance,        -- Includes the dfun id.  Its forall'd type
+      iSpec   :: ClsInst,        -- Includes the dfun id.  Its forall'd type
       iBinds  :: InstBindings a   -- variables scope over the stuff in InstBindings!
     }
 
@@ -688,13 +695,17 @@ Make a name for the representation tycon of a family instance.  It's an
 newGlobalBinder.
 
 \begin{code}
-newFamInstTyConName :: Located Name -> [Type] -> TcM Name
-newFamInstTyConName (L loc tc_name) tys
+newFamInstTyConName, newFamInstAxiomName :: Located Name -> [Type] -> TcM Name
+newFamInstTyConName = mk_fam_inst_name id
+newFamInstAxiomName = mk_fam_inst_name mkInstTyCoOcc
+
+mk_fam_inst_name :: (OccName -> OccName) -> Located Name -> [Type] -> TcM Name
+mk_fam_inst_name adaptOcc (L loc tc_name) tys
   = do  { mod   <- getModule
         ; let info_string = occNameString (getOccName tc_name) ++ 
                             concatMap (occNameString.getDFunTyKey) tys
         ; occ   <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
-        ; newGlobalBinder mod occ loc }
+        ; newGlobalBinder mod (adaptOcc occ) loc }
 \end{code}
 
 Stable names used for foreign exports and annotations.
index 340b33c..67f212f 100644 (file)
@@ -31,7 +31,8 @@ import TcUnify
 import BasicTypes
 import Inst
 import TcBinds
-import FamInst( tcLookupFamInst )
+import FamInst          ( tcLookupFamInst )
+import FamInstEnv       ( famInstAxiom, dataFamInstRepTyCon )
 import TcEnv
 import TcArrows
 import TcMatches
@@ -1159,12 +1160,12 @@ tcTagToEnum loc fun_name arg res_ty
       = do { mb_fam <- tcLookupFamInst tc tc_args
            ; case mb_fam of 
               Nothing -> failWithTc (tagToEnumError ty doc3)
-               Just (rep_tc, rep_args) 
+               Just (rep_fam, rep_args) 
                    -> return ( mkTcSymCo (mkTcAxInstCo co_tc rep_args)
                              , rep_tc, rep_args )
                  where
-                   co_tc = expectJust "tcTagToEnum" $
-                           tyConFamilyCoercion_maybe rep_tc }
+                   co_tc  = famInstAxiom rep_fam
+                   rep_tc = dataFamInstRepTyCon rep_fam }
 
 tagToEnumError :: TcType -> SDoc -> SDoc
 tagToEnumError ty what
index 0839e18..70d841e 100644 (file)
@@ -49,6 +49,7 @@ import Name
 
 import HscTypes
 import PrelInfo
+import FamInstEnv( FamInst )
 import MkCore  ( eRROR_ID )
 import PrelNames hiding (error_RDR)
 import PrimOp
@@ -90,7 +91,7 @@ data DerivStuff     -- Please add this auxiliary stuff
 
   -- Generics
   | DerivTyCon TyCon      -- New data types
-  | DerivFamInst TyCon    -- New type family instances
+  | DerivFamInst FamInst  -- New type family instances
 
   -- New top-level auxiliary bindings 
   | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
@@ -1800,8 +1801,8 @@ genAuxBindSpec loc (DerivMaxTag tycon)
 type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
                               ( Bag (LHsBind RdrName, LSig RdrName)
                                 -- Extra bindings (used by Generic only)
-                              , Bag TyCon -- Extra top-level datatypes
-                              , Bag TyCon -- Extra family instances
+                              , Bag TyCon   -- Extra top-level datatypes
+                              , Bag FamInst -- Extra family instances
                               , Bag (InstInfo RdrName)) -- Extra instances
 
 genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
index 126575d..8bef059 100644 (file)
@@ -24,9 +24,10 @@ import TcType
 import TcGenDeriv
 import DataCon
 import TyCon
-import Name hiding (varName)
-import Module (Module, moduleName, moduleNameString)
-import IfaceEnv (newGlobalBinder)
+import FamInstEnv       ( FamInst, mkSynFamInst )
+import Module           ( Module, moduleName, moduleNameString )
+import IfaceEnv         ( newGlobalBinder )
+import Name      hiding ( varName )
 import RdrName
 import BasicTypes
 import TysWiredIn
@@ -70,7 +71,7 @@ gen_Generic_binds tc mod = do
                    `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons))
                    `unionBags` metaInsts)) }
 
-genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, TyCon)
+genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, FamInst)
 genGenericRepExtras tc mod =
   do  uniqS <- newUniqueSupply
       let
@@ -99,15 +100,14 @@ genGenericRepExtras tc mod =
         
         mkTyCon name = ASSERT( isExternalName name )
                        buildAlgTyCon name [] [] distinctAbstractTyConRhs
-                           NonRecursive False NoParentTyCon Nothing
+                                          NonRecursive False NoParentTyCon
 
-      metaDTyCon  <- mkTyCon d_name
-      metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ]
-      metaSTyCons <- mapM sequence 
-                       [ [ mkTyCon s_name 
-                         | s_name <- s_namesC ] | s_namesC <- s_names ]
+      let metaDTyCon  = mkTyCon d_name
+          metaCTyCons = map mkTyCon c_names
+          metaSTyCons =  [ [ mkTyCon s_name | s_name <- s_namesC ] 
+                         | s_namesC <- s_names ]
 
-      let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
+          metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
   
       rep0_tycon <- tc_mkRepTyCon tc metaDts mod
       
@@ -257,7 +257,7 @@ mkBindsRep tycon =
 tc_mkRepTyCon :: TyCon            -- The type to generate representation for
                -> MetaTyCons      -- Metadata datatypes to refer to
                -> Module          -- Used as the location of the new RepTy
-               -> TcM TyCon       -- Generated representation0 type
+               -> TcM FamInst     -- Generated representation0 coercion
 tc_mkRepTyCon tycon metaDts mod = 
 -- Consider the example input tycon `D`, where data D a b = D_ a
   do { -- `rep0` = GHC.Generics.Rep (type family)
@@ -269,17 +269,14 @@ tc_mkRepTyCon tycon metaDts mod =
        -- `rep_name` is a name we generate for the synonym
      ; rep_name <- newGlobalBinder mod (mkGenR (nameOccName (tyConName tycon)))
                      (nameSrcSpan (tyConName tycon))
+
      ; let -- `tyvars` = [a,b]
            tyvars  = tyConTyVars tycon
 
-           -- rep0Ty has kind * -> *
-           rep_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
-
            -- `appT` = D a b
            appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
-
-     ; buildSynTyCon rep_name tyvars (SynonymTyCon rep0Ty) rep_kind
-                     NoParentTyCon (Just (rep0, appT)) }
+     ; return $ mkSynFamInst rep_name tyvars rep0 appT rep0Ty
+     }
 
 
 
index 11ec175..ac9769c 100644 (file)
@@ -366,40 +366,30 @@ tcInstDecls1    -- Deal with both source-code and imported instance decls
 
 tcInstDecls1 tycl_decls inst_decls deriv_decls 
   = checkNoErrs $
-    do {        -- Stop if addInstInfos etc discovers any errors
-                -- (they recover, so that we get more than one error each
-                -- round)
-
-                -- (1) Do class and family instance declarations
-       ; idx_tycons        <- mapAndRecoverM tcTopFamInstDecl $
-                              filter (isFamInstDecl . unLoc) tycl_decls
-       ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1  inst_decls
-
-       ; let { (local_info,
-                at_tycons_s)   = unzip local_info_tycons
-             ; at_idx_tycons   = concat at_tycons_s ++ idx_tycons
-             ; at_things       = map ATyCon at_idx_tycons }
-
-                -- (2) Add the tycons of indexed types and their implicit
-                --     tythings to the global environment
-       ; tcExtendGlobalEnvImplicit at_things $ do
-       { tcg_env <- tcAddImplicits at_things
-       ; setGblEnv tcg_env $
-
-
-                -- Next, construct the instance environment so far, consisting
-                -- of
-                --   (a) local instance decls
-                --   (b) local family instance decls
-         addInsts local_info         $
-         addFamInsts at_idx_tycons   $ do {
-
-                -- (3) Compute instances from "deriving" clauses;
-                -- This stuff computes a context for the derived instance
-                -- decl, so it needs to know about all the instances possible
-                -- NB: class instance declarations can contain derivings as
-                --     part of associated data type declarations
-         failIfErrsM    -- If the addInsts stuff gave any errors, don't
+    do {    -- Stop if addInstInfos etc discovers any errors
+            -- (they recover, so that we get more than one error each
+            -- round)
+
+            -- (1) Do class and family instance declarations
+       ; fam_insts       <- mapAndRecoverM tcTopFamInstDecl $
+                            filter (isFamInstDecl . unLoc) tycl_decls
+       ; inst_decl_stuff <- mapAndRecoverM tcLocalInstDecl1  inst_decls
+
+       ; let { (local_info, at_fam_insts_s) = unzip inst_decl_stuff
+             ; all_fam_insts = concat at_fam_insts_s ++ fam_insts }
+
+            -- (2) Next, construct the instance environment so far, consisting of
+            --   (a) local instance decls
+            --   (b) local family instance decls
+       ; addClsInsts local_info      $
+         addFamInsts all_fam_insts   $ do
+
+            -- (3) Compute instances from "deriving" clauses;
+            -- This stuff computes a context for the derived instance
+            -- decl, so it needs to know about all the instances possible
+            -- NB: class instance declarations can contain derivings as
+            --     part of associated data type declarations
+       { failIfErrsM    -- If the addInsts stuff gave any errors, don't
                         -- try the deriving stuff, because that may give
                         -- more errors still
 
@@ -421,24 +411,33 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
        ; return ( gbl_env
                 , (bagToList deriv_inst_info) ++ local_info
                 , deriv_binds)
-    }}}
+    }}
   where
     typInstCheck ty = is_cls (iSpec ty) `elem` typeableClassNames
     typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"
                               ++ " Haskell! Can only derive them"
 
-addInsts :: [InstInfo Name] -> TcM a -> TcM a
-addInsts infos thing_inside
+addClsInsts :: [InstInfo Name] -> TcM a -> TcM a
+addClsInsts infos thing_inside
   = tcExtendLocalInstEnv (map iSpec infos) thing_inside
 
-addFamInsts :: [TyCon] -> TcM a -> TcM a
-addFamInsts tycons thing_inside
-  = tcExtendLocalFamInstEnv (map mkLocalFamInst tycons) thing_inside
+addFamInsts :: [FamInst] -> TcM a -> TcM a
+-- Extend (a) the family instance envt
+--        (b) the type envt with stuff from data type decls
+addFamInsts fam_insts thing_inside
+  = tcExtendLocalFamInstEnv fam_insts $ 
+    tcExtendGlobalEnvImplicit things  $ 
+    do { tcg_env <- tcAddImplicits things
+       ; setGblEnv tcg_env thing_inside }
+  where
+    axioms = map famInstAxiom fam_insts
+    tycons = famInstsRepTyCons fam_insts
+    things = map ATyCon tycons ++ map ACoAxiom axioms 
 \end{code}
 
 \begin{code}
 tcLocalInstDecl1 :: LInstDecl Name
-                 -> TcM (InstInfo Name, [TyCon])
+                 -> TcM (InstInfo Name, [FamInst])
         -- A source-file instance declaration
         -- Type-check all the stuff before the "where"
         --
@@ -457,14 +456,14 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
                            
         -- Next, process any associated types.
         ; traceTc "tcLocalInstDecl" (ppr poly_ty)
-        ; idx_tycons0 <- tcExtendTyVarEnv tyvars $
-                         mapAndRecoverM (tcAssocDecl clas mini_env) ats
+        ; fam_insts0 <- tcExtendTyVarEnv tyvars $
+                        mapAndRecoverM (tcAssocDecl clas mini_env) ats
 
         -- Check for missing associated types and build them
         -- from their defaults (if available)
         ; let defined_ats = mkNameSet $ map (tcdName . unLoc) ats
 
-              mk_deflt_at_instances :: ClassATItem -> TcM [TyCon]
+              mk_deflt_at_instances :: ClassATItem -> TcM [FamInst]
               mk_deflt_at_instances (fam_tc, defs)
                  -- User supplied instances ==> everything is OK
                 | tyConName fam_tc `elemNameSet` defined_ats 
@@ -487,12 +486,9 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
                            tvs'     = varSetElems tv_set'
                      ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys'
                      ; ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) 
-                       buildSynTyCon rep_tc_name tvs'
-                                     (SynonymTyCon rhs')
-                                     (typeKind rhs')
-                                     NoParentTyCon (Just (fam_tc, pat_tys')) }
+                       return (mkSynFamInst rep_tc_name tvs' fam_tc pat_tys' rhs') }
 
-        ; idx_tycons1 <- mapM mk_deflt_at_instances (classATItems clas)
+        ; fam_insts1 <- mapM mk_deflt_at_instances (classATItems clas)
         
         -- Finally, construct the Core representation of the instance.
         -- (This no longer includes the associated types.)
@@ -504,10 +500,9 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
               ispec    = mkLocalInstance dfun overlap_flag
               inst_info = InstInfo { iSpec  = ispec, iBinds = VanillaInst binds uprags False }
 
-        ; return (inst_info, idx_tycons0 ++ concat idx_tycons1) }
+        ; return ( inst_info, fam_insts0 ++ concat fam_insts1) }
 \end{code}
 
-
 %************************************************************************
 %*                                                                      *
                Type checking family instances
@@ -520,15 +515,15 @@ lot of kinding and type checking code with ordinary algebraic data types (and
 GADTs).
 
 \begin{code}
-tcTopFamInstDecl :: LTyClDecl Name -> TcM TyCon
+tcTopFamInstDecl :: LTyClDecl Name -> TcM FamInst
 tcTopFamInstDecl (L loc decl)
   = setSrcSpan loc      $
     tcAddDeclCtxt decl  $
     tcFamInstDecl TopLevel decl
 
-tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM TyCon
+tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM FamInst
 tcFamInstDecl top_lvl decl
-  = do { -- type family instances require -XTypeFamilies
+  = do { -- Type family instances require -XTypeFamilies
          -- and can't (currently) be in an hs-boot file
        ; traceTc "tcFamInstDecl" (ppr decl)
        ; let fam_tc_lname = tcdLName decl
@@ -546,13 +541,9 @@ tcFamInstDecl top_lvl decl
 
          -- Now check the type/data instance itself
          -- This is where type and data decls are treated separately
-       ; tc <- tcFamInstDecl1 fam_tc decl
-       ; checkValidTyCon tc     -- Remember to check validity;
-                                -- no recursion to worry about here
+       ; tcFamInstDecl1 fam_tc decl }
 
-       ; return tc }
-
-tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM TyCon
+tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM FamInst
 
   -- "type instance"
 tcFamInstDecl1 fam_tc (decl@TySynonym {})
@@ -563,17 +554,14 @@ tcFamInstDecl1 fam_tc (decl@TySynonym {})
        ; checkValidFamInst t_typats t_rhs
 
          -- (3) construct representation tycon
-       ; rep_tc_name <- newFamInstTyConName (tcdLName decl) t_typats
-       ; buildSynTyCon rep_tc_name t_tvs
-                       (SynonymTyCon t_rhs)
-                       (typeKind t_rhs)
-                       NoParentTyCon (Just (fam_tc, t_typats))
-       }
+       ; rep_tc_name <- newFamInstAxiomName (tcdLName decl) t_typats
+
+       ; return (mkSynFamInst rep_tc_name t_tvs fam_tc t_typats t_rhs) }
 
   -- "newtype instance" and "data instance"
 tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt
                                    , tcdTyVars = tvs, tcdTyPats = Just pats
-                                  , tcdCons = cons})
+                                   , tcdCons = cons})
   = do { -- Check that the family declaration is for the right kind
          checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
        ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)
@@ -595,27 +583,33 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt
 
          -- Construct representation tycon
        ; rep_tc_name <- newFamInstTyConName (tcdLName decl) pats'
+       ; axiom_name  <- newImplicitBinder rep_tc_name mkInstTyCoOcc
        ; let ex_ok = True       -- Existentials ok for type families!
-       ; fixM (\ rep_tycon -> do
-             { let orig_res_ty = mkTyConApp fam_tc pats'
-             ; data_cons <- tcConDecls new_or_data ex_ok rep_tycon
+             orig_res_ty = mkTyConApp fam_tc pats'
+
+       ; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) ->
+           do { data_cons <- tcConDecls new_or_data ex_ok rec_rep_tc
                                        (tvs', orig_res_ty) cons
-             ; tc_rhs <-
-                 case new_or_data of
-                   DataType -> return (mkDataTyConRhs data_cons)
-                   NewType  -> ASSERT( not (null data_cons) )
-                               mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
-             ; buildAlgTyCon rep_tc_name tvs' stupid_theta tc_rhs Recursive
-                             h98_syntax NoParentTyCon (Just (fam_tc, pats'))
+              ; tc_rhs <- case new_or_data of
+                     DataType -> return (mkDataTyConRhs data_cons)
+                     NewType  -> ASSERT( not (null data_cons) )
+                                 mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)
+              ; let fam_inst = mkDataFamInst axiom_name tvs' fam_tc pats' rep_tc
+                    parent   = FamInstTyCon (famInstAxiom fam_inst) fam_tc pats'
+                    rep_tc   = buildAlgTyCon rep_tc_name tvs' stupid_theta tc_rhs 
+                                             Recursive h98_syntax parent
                  -- We always assume that indexed types are recursive.  Why?
                  -- (1) Due to their open nature, we can never be sure that a
                  -- further instance might not introduce a new recursive
                  -- dependency.  (2) They are always valid loop breakers as
                  -- they involve a coercion.
-             })
-       } }
+              ; return (rep_tc, fam_inst) }
+
+         -- Remember to check validity; no recursion to worry about here
+       ; checkValidTyCon rep_tc
+       ; return fam_inst } }
     where
-         h98_syntax = case cons of      -- All constructors have same shape
+       h98_syntax = case cons of      -- All constructors have same shape
                         L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
                         _ -> True
 
@@ -626,26 +620,28 @@ tcFamInstDecl1 _ d = pprPanic "tcFamInstDecl1" (ppr d)
 tcAssocDecl :: Class           -- ^ Class of associated type
             -> VarEnv Type     -- ^ Instantiation of class TyVars
             -> LTyClDecl Name  -- ^ RHS
-            -> TcM TyCon
+            -> TcM FamInst
 tcAssocDecl clas mini_env (L loc decl)
   = setSrcSpan loc      $
     tcAddDeclCtxt decl  $
-    do { at_tc <- tcFamInstDecl NotTopLevel decl
-       ; let Just (fam_tc, at_tys) = tyConFamInst_maybe at_tc
-  
+    do { fam_inst <- tcFamInstDecl NotTopLevel decl
+       ; let (fam_tc, at_tys) = famInstLHS fam_inst
+
        -- Check that the associated type comes from this class
        ; checkTc (Just clas == tyConAssoc_maybe fam_tc)
-                 (badATErr (className clas) (tyConName at_tc))
+                 (badATErr (className clas) (tyConName fam_tc))
 
        -- See Note [Checking consistent instantiation] in TcTyClsDecls
        ; zipWithM_ check_arg (tyConTyVars fam_tc) at_tys
 
-       ; return at_tc }
+       ; return fam_inst }
   where
     check_arg fam_tc_tv at_ty
       | Just inst_ty <- lookupVarEnv mini_env fam_tc_tv
       = checkTc (inst_ty `eqType` at_ty) 
                 (wrongATArgErr at_ty inst_ty)
+                -- No need to instantiate here, becuase the axiom
+                -- uses the same type variables as the assocated class
       | otherwise
       = return ()   -- Allow non-type-variable instantiation
                     -- See Note [Associated type instances]
index b0eca45..08086e4 100644 (file)
@@ -20,10 +20,11 @@ import TcCanonical
 import VarSet
 import Type
 import Unify
+import FamInstEnv
+import Coercion( mkAxInstRHS )
 
 import Id 
 import Var
-import VarEnv ( ) -- unitVarEnv, mkInScopeSet
 
 import TcType
 
@@ -1507,16 +1508,12 @@ doTopReact _inerts workItem@(CFunEqCan { cc_id = eqv, cc_flavor = fl
                                        , cc_fun = tc, cc_tyargs = args, cc_rhs = xi })
   = ASSERT (isSynFamilyTyCon tc)   -- No associated data families have reached that far 
     do { match_res <- matchFam tc args   -- See Note [MATCHING-SYNONYMS]
-       ; case match_res of 
+       ; case match_res of
            Nothing -> return NoTopInt 
-           Just (rep_tc, rep_tys)
-             -> do { let Just coe_tc = tyConFamilyCoercion_maybe rep_tc
-                         Just rhs_ty = tcView (mkTyConApp rep_tc rep_tys)
-                           -- Eagerly expand away the type synonym on the
-                           -- RHS of a type function, so that it never
-                           -- appears in an error message
-                            -- See Note [Type synonym families] in TyCon
-                         coe = mkTcAxInstCo coe_tc rep_tys 
+           Just (famInst, rep_tys)
+             -> do { let coe_ax = famInstAxiom famInst
+                         rhs_ty = mkAxInstRHS coe_ax rep_tys
+                         coe    = mkTcAxInstCo coe_ax rep_tys 
                    ; case fl of
                        Wanted {} -> do { evc <- newEqVar fl rhs_ty xi -- Wanted version
                                        ; let eqv' = evc_the_evvar evc
@@ -1545,7 +1542,6 @@ doTopReact _inerts workItem@(CFunEqCan { cc_id = eqv, cc_flavor = fl
                                                                , cc_flavor = fl'
                                                                , cc_depth = cc_depth workItem + 1}  
                                       ; updWorkListTcS (extendWorkListEq ct) 
-
                                       ; return $ 
                                         SomeTopInt { tir_rule = "Fun/Top (given)"
                                                    , tir_new_item = ContinueWith workItem } }
index 2bbb2e1..2d65816 100644 (file)
@@ -549,7 +549,8 @@ zonkTcTypeAndSubst subst ty = zonkType zonk_tv ty
   where
     zonk_tv tv
       = do { z_tv <- updateTyVarKindM zonkTcKind tv
-           ; case tcTyVarDetails tv of
+           ; ASSERT ( isTcTyVar tv )
+             case tcTyVarDetails tv of
                 SkolemTv {}   -> return (TyVarTy z_tv)
                 RuntimeUnk {} -> return (TyVarTy z_tv)
                 FlatSkol ty   -> zonkType zonk_tv ty
index 137df8a..f1f502d 100644 (file)
@@ -761,6 +761,9 @@ matchExpectedConTy data_tc pat_ty
   = do { (_, tys, subst) <- tcInstTyVars (tyConTyVars data_tc)
                     -- tys = [ty1,ty2]
 
+       ; traceTc "matchExpectedConTy" (vcat [ppr data_tc, 
+                                             ppr (tyConTyVars data_tc),
+                                             ppr fam_tc, ppr fam_args])
        ; co1 <- unifyType (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty
                     -- co1 : T (ty1,ty2) ~ pat_ty
 
index 4879974..bb1013b 100644 (file)
@@ -689,7 +689,7 @@ checkHiBootIface
     local_export_env :: NameEnv AvailInfo
     local_export_env = availsToNameEnv local_exports
 
-    check_inst :: Instance -> TcM (Maybe (Id, Id))
+    check_inst :: ClsInst -> TcM (Maybe (Id, Id))
        -- Returns a pair of the boot dfun in terms of the equivalent real dfun
     check_inst boot_inst
        = case [dfun | inst <- local_insts, 
@@ -838,7 +838,7 @@ bootMisMatch thing boot_decl real_decl
          ptext (sLit "Main module:") <+> ppr real_decl,
          ptext (sLit "Boot file:  ") <+> ppr boot_decl]
 
-instMisMatch :: Instance -> SDoc
+instMisMatch :: ClsInst -> SDoc
 instMisMatch inst
   = hang (ppr inst)
        2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself"))
@@ -1592,7 +1592,7 @@ tcRnLookupName' name = do
 
 tcRnGetInfo :: HscEnv
             -> Name
-            -> IO (Messages, Maybe (TyThing, Fixity, [Instance]))
+            -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst]))
 
 -- Used to implement :info in GHCi
 --
@@ -1607,7 +1607,7 @@ tcRnGetInfo hsc_env name
 
 tcRnGetInfo' :: HscEnv
              -> Name
-             -> TcRn (TyThing, Fixity, [Instance])
+             -> TcRn (TyThing, Fixity, [ClsInst])
 tcRnGetInfo' hsc_env name
   = let ictxt = hsc_IC hsc_env in
     setInteractiveContext hsc_env ictxt $ do
@@ -1623,7 +1623,7 @@ tcRnGetInfo' hsc_env name
     ispecs <- lookupInsts thing
     return (thing, fixity, ispecs)
 
-lookupInsts :: TyThing -> TcM [Instance]
+lookupInsts :: TyThing -> TcM [ClsInst]
 lookupInsts (ATyCon tc)
   | Just cls <- tyConClass_maybe tc
   = do  { inst_envs <- tcGetInstEnvs
@@ -1734,7 +1734,7 @@ pprModGuts (ModGuts { mg_tcs = tcs
   = vcat [ ppr_types [] (mkTypeEnv (map ATyCon tcs)),
           ppr_rules rules ]
 
-ppr_types :: [Instance] -> TypeEnv -> SDoc
+ppr_types :: [ClsInst] -> TypeEnv -> SDoc
 ppr_types insts type_env
   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
   where
@@ -1756,14 +1756,14 @@ ppr_tycons fam_insts type_env
          , text "COERCION AXIOMS" 
          ,   nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]
   where
-    fi_tycons = map famInstTyCon fam_insts
+    fi_tycons = famInstsRepTyCons fam_insts
     tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
     want_tycon tycon | opt_PprStyle_Debug = True
                     | otherwise          = not (isImplicitTyCon tycon) &&
                                            isExternalName (tyConName tycon) &&
                                            not (tycon `elem` fi_tycons)
 
-ppr_insts :: [Instance] -> SDoc
+ppr_insts :: [ClsInst] -> SDoc
 ppr_insts []     = empty
 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
 
index b85a892..8b59a12 100644 (file)
@@ -305,7 +305,7 @@ data TcGblEnv
        tcg_warns     :: Warnings,          -- ...Warnings and deprecations
        tcg_anns      :: [Annotation],      -- ...Annotations
         tcg_tcs       :: [TyCon],           -- ...TyCons and Classes
-       tcg_insts     :: [Instance],        -- ...Instances
+       tcg_insts     :: [ClsInst],         -- ...Instances
         tcg_fam_insts :: [FamInst],         -- ...Family instances
         tcg_rules     :: [LRuleDecl Id],    -- ...Rules
         tcg_fords     :: [LForeignDecl Id], -- ...Foreign import & exports
index aabc737..1106c92 100644 (file)
@@ -1197,7 +1197,8 @@ isTouchableMetaTyVar tv
 
 isTouchableMetaTyVar_InRange :: TcsUntouchables -> TcTyVar -> Bool 
 isTouchableMetaTyVar_InRange (untch,untch_tcs) tv 
-  = case tcTyVarDetails tv of 
+  = ASSERT2 ( isTcTyVar tv, ppr tv )
+    case tcTyVarDetails tv of 
       MetaTv TcsTv _ -> not (tv `elemVarSet` untch_tcs)
                         -- See Note [Touchable meta type variables] 
       MetaTv {}      -> inTouchableRange untch tv 
@@ -1469,7 +1470,7 @@ matchClass clas tys
        }
         }
 
-matchFam :: TyCon -> [Type] -> TcS (Maybe (TyCon, [Type]))
+matchFam :: TyCon -> [Type] -> TcS (Maybe (FamInst, [Type]))
 matchFam tycon args = wrapTcS $ tcLookupFamInst tycon args
 \end{code}
 
index 37fa817..6346480 100644 (file)
@@ -1268,7 +1268,7 @@ reifyClass cls
                           ; return (TH.SigD (reifyName op) ty) }
 
 ------------------------------
-reifyClassInstance :: Instance -> TcM TH.Dec
+reifyClassInstance :: ClsInst -> TcM TH.Dec
 reifyClassInstance i
   = do { cxt <- reifyCxt theta
        ; thtypes <- reifyTypes types
@@ -1280,21 +1280,22 @@ reifyClassInstance i
 ------------------------------
 reifyFamilyInstance :: FamInst -> TcM TH.Dec
 reifyFamilyInstance fi
-  | isSynTyCon rep_tc
-  = do { th_tys <- reifyTypes (fi_tys fi)
-       ; rhs_ty <- reifyType (synTyConType rep_tc)
-       ; return (TH.TySynInstD fam th_tys rhs_ty) }
-
-  | otherwise
-  = do { let tvs = tyConTyVars rep_tc
-             fam = reifyName (fi_fam fi)
-       ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons rep_tc)
-       ; th_tys <- reifyTypes (fi_tys fi)
-       ; return (if isNewTyCon rep_tc
-                 then TH.NewtypeInstD [] fam th_tys (head cons) []
-                 else TH.DataInstD    [] fam th_tys cons        []) }
+  = case fi_flavor fi of
+      SynFamilyInst ->
+        do { th_tys <- reifyTypes (fi_tys fi)
+           ; rhs_ty <- reifyType (coAxiomRHS rep_ax)
+           ; return (TH.TySynInstD fam th_tys rhs_ty) }
+
+      DataFamilyInst rep_tc ->
+        do { let tvs = tyConTyVars rep_tc
+                 fam = reifyName (fi_fam fi)
+           ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons rep_tc)
+           ; th_tys <- reifyTypes (fi_tys fi)
+           ; return (if isNewTyCon rep_tc
+                     then TH.NewtypeInstD [] fam th_tys (head cons) []
+                     else TH.DataInstD    [] fam th_tys cons        []) }
   where
-    rep_tc = fi_tycon fi
+    rep_ax = fi_axiom fi
     fam = reifyName (fi_fam fi)
 
 ------------------------------
index f91ccdf..2e0e45b 100644 (file)
@@ -558,7 +558,7 @@ tcTyClDecl1 parent _calc_isrec
   = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
   { traceTc "type family:" (ppr tc_name)
   ; checkFamFlag tc_name
-  ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
+  ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent
   ; return [ATyCon tycon] }
 
   -- "data family" declaration
@@ -569,8 +569,8 @@ tcTyClDecl1 parent _calc_isrec
   ; checkFamFlag tc_name
   ; extra_tvs <- tcDataKindSig kind
   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
-  ; tycon <- buildAlgTyCon tc_name final_tvs []
-               DataFamilyTyCon Recursive True parent Nothing
+        tycon = buildAlgTyCon tc_name final_tvs []
+                              DataFamilyTyCon Recursive True parent
   ; return [ATyCon tycon] }
 
   -- "type" synonym declaration
@@ -580,7 +580,7 @@ tcTyClDecl1 _parent _calc_isrec
     tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
     { rhs_ty' <- tcCheckHsType rhs_ty kind
     ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty')
-                            kind NoParentTyCon Nothing
+                 kind NoParentTyCon
     ; return [ATyCon tycon] }
 
   -- "newtype" and "data"
@@ -606,7 +606,7 @@ tcTyClDecl1 _parent calc_isrec
 
   ; dataDeclChecks tc_name new_or_data stupid_theta cons
 
-  ; tycon <- fixM (\ tycon -> do
+  ; tycon <- fixM \ tycon -> do
        { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
        ; data_cons <- tcConDecls new_or_data ex_ok tycon (final_tvs, res_ty) cons
        ; tc_rhs <-
@@ -616,9 +616,8 @@ tcTyClDecl1 _parent calc_isrec
                   DataType -> return (mkDataTyConRhs data_cons)
                   NewType  -> ASSERT( not (null data_cons) )
                                mkNewTyConRhs tc_name tycon (head data_cons)
-       ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
-           (not h98_syntax) NoParentTyCon Nothing
-       })
+       ; return (buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs
+                               is_rec (not h98_syntax) NoParentTyCon) }
   ; return [ATyCon tycon] }
 
 tcTyClDecl1 _parent calc_isrec
index 840365e..836c9e5 100644 (file)
@@ -24,13 +24,17 @@ module Coercion (
         isReflCo_maybe,
         mkCoercionType,
 
+        -- ** Functions over coercion axioms
+        coAxiomSplitLHS,
+
        -- ** Constructing coercions
         mkReflCo, mkCoVarCo, 
-        mkAxInstCo, mkPiCo, mkPiCos,
+        mkAxInstCo, mkAxInstRHS,
+        mkPiCo, mkPiCos,
         mkSymCo, mkTransCo, mkNthCo,
        mkInstCo, mkAppCo, mkTyConAppCo, mkFunCo,
         mkForAllCo, mkUnsafeCo,
-        mkNewTypeCo, mkFamInstCo,
+        mkNewTypeCo, 
 
         -- ** Decomposition
         splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo,
@@ -82,7 +86,7 @@ import TyCon
 import Var
 import VarEnv
 import VarSet
-import Maybes  ( orElse )
+import Maybes   ( orElse )
 import Name    ( Name, NamedThing(..), nameUnique )
 import OccName         ( parenSymOcc )
 import Util
@@ -277,6 +281,23 @@ Now (Nth 0 g) will optimise to Refl, but perhaps not instantly.
 
 
 %************************************************************************
+%*                                                                      *
+\subsection{Coercion axioms}
+%*                                                                      *
+%************************************************************************
+These functions are not in TyCon because they need knowledge about
+the type representation (from TypeRep)
+
+\begin{code}
+-- If `ax :: F a ~ b`, and `F` is a family instance, returns (F, [a])
+coAxiomSplitLHS :: CoAxiom -> (TyCon, [Type])
+coAxiomSplitLHS ax
+  = case splitTyConApp_maybe (coAxiomLHS ax) of
+      Just (tc,tys) -> (tc,tys)
+      Nothing       -> pprPanic "coAxiomSplitLHS" (ppr ax)
+\end{code}
+
+%************************************************************************
 %*                                                                     *
 \subsection{Coercion variables}
 %*                                                                     *
@@ -511,6 +532,8 @@ mkReflCo :: Type -> Coercion
 mkReflCo = Refl
 
 mkAxInstCo :: CoAxiom -> [Type] -> Coercion
+-- mkAxInstCo can legitimately be called over-staturated; 
+-- i.e. with more type arguments than the coercion requires
 mkAxInstCo ax tys
   | arity == n_tys = AxiomInstCo ax rtys
   | otherwise      = ASSERT( arity < n_tys )
@@ -521,6 +544,19 @@ mkAxInstCo ax tys
     arity = coAxiomArity ax
     rtys  = map Refl tys
 
+mkAxInstRHS :: CoAxiom -> [Type] -> Type
+-- Instantiate the axiom with specified types,
+-- returning the instantiated RHS
+-- A companion to mkAxInstCo: 
+--    mkAxInstRhs ax tys = snd (coercionKind (mkAxInstCo ax tys))
+mkAxInstRHS ax tys
+  = ASSERT( tvs `equalLength` tys1 ) 
+    mkAppTys rhs' tys2
+  where
+    tvs          = coAxiomTyVars ax
+    (tys1, tys2) = splitAtList tvs tys
+    rhs'         = substTyWith tvs tys1 (coAxiomRHS ax)
+
 -- | Apply a 'Coercion' to another 'Coercion'.
 mkAppCo :: Coercion -> Coercion -> Coercion
 mkAppCo (Refl ty1) (Refl ty2)       = Refl (mkAppTy ty1 ty2)
@@ -611,28 +647,12 @@ mkUnsafeCo ty1 ty2 = UnsafeCo ty1 ty2
 --   the free variables a subset of those 'TyVar's.
 mkNewTypeCo :: Name -> TyCon -> [TyVar] -> Type -> CoAxiom
 mkNewTypeCo name tycon tvs rhs_ty
-  = CoAxiom { co_ax_unique = nameUnique name
-            , co_ax_name   = name
-            , co_ax_tvs    = tvs
-            , co_ax_lhs    = mkTyConApp tycon (mkTyVarTys tvs)
-            , co_ax_rhs    = rhs_ty }
-
--- | Create a coercion identifying a @data@, @newtype@ or @type@ representation type
--- and its family instance.  It has the form @Co tvs :: F ts ~ R tvs@, where @Co@ is 
--- the coercion constructor built here, @F@ the family tycon and @R@ the (derived)
--- representation tycon.
-mkFamInstCo :: Name    -- ^ Unique name for the coercion tycon
-                 -> [TyVar]    -- ^ Type parameters of the coercion (@tvs@)
-                 -> TyCon      -- ^ Family tycon (@F@)
-                 -> [Type]     -- ^ Type instance (@ts@)
-                 -> TyCon      -- ^ Representation tycon (@R@)
-                 -> CoAxiom    -- ^ Coercion constructor (@Co@)
-mkFamInstCo name tvs family inst_tys rep_tycon
-  = CoAxiom { co_ax_unique = nameUnique name
-            , co_ax_name   = name
-            , co_ax_tvs    = tvs
-            , co_ax_lhs    = mkTyConApp family inst_tys 
-            , co_ax_rhs    = mkTyConApp rep_tycon (mkTyVarTys tvs) }
+  = CoAxiom { co_ax_unique   = nameUnique name
+            , co_ax_name     = name
+            , co_ax_implicit = True  -- See Note [Implicit axioms] in TyCon
+            , co_ax_tvs      = tvs
+            , co_ax_lhs      = mkTyConApp tycon (mkTyVarTys tvs)
+            , co_ax_rhs      = rhs_ty }
 
 mkPiCos :: [Var] -> Coercion -> Coercion
 mkPiCos vs co = foldr mkPiCo co vs
index 2361851..f103b64 100644 (file)
@@ -13,9 +13,11 @@ FamInstEnv: Type checked family instance declarations
 -- for details
 
 module FamInstEnv (
-       FamInst(..), famInstTyCon, famInstTyVars, 
+       FamInst(..), FamFlavor(..), famInstAxiom, famInstTyVars,
+        famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, 
+        famInstLHS,
        pprFamInst, pprFamInstHdr, pprFamInsts, 
-       famInstHead, mkLocalFamInst, mkImportedFamInst,
+       mkSynFamInst, mkDataFamInst, mkImportedFamInst,
 
        FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, 
        extendFamInstEnv, overwriteFamInstEnv, extendFamInstEnvList, 
@@ -51,30 +53,76 @@ import FastString
 %*                                                                     *
 %************************************************************************
 
+Note [FamInsts and CoAxioms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* CoAxioms and FamInsts are just like
+  DFunIds  and ClsInsts
+
+* A CoAxiom is a System-FC thing: it can relate any two types
+
+* A FamInst is a Haskell source-language thing, corresponding
+  to a type/data family instance declaration.  
+    - The FamInst contains a CoAxiom, which is the evidence
+      for the instance
+
+    - The LHS of the CoAxiom is always of form F ty1 .. tyn
+      where F is a type family
+
+
 \begin{code}
-data FamInst 
-  = FamInst { fi_fam   :: Name         -- Family name
-               -- INVARIANT: fi_fam = case tyConFamInst_maybe fi_tycon of
-               --                         Just (tc, tys) -> tc
+data FamInst  -- See Note [FamInsts and CoAxioms]
+  = FamInst { fi_axiom  :: CoAxiom      -- The new coercion axiom introduced
+                                        -- by this family instance
+            , fi_flavor :: FamFlavor
+
+            -- Everything below here is a redundant, 
+            -- cached version of the two things above
+            , fi_fam   :: Name         -- Family name
+               -- INVARIANT: fi_fam = name of fi_fam_tc
 
                -- Used for "rough matching"; same idea as for class instances
+                -- See Note [Rough-match field] in InstEnv
            , fi_tcs   :: [Maybe Name]  -- Top of type args
                -- INVARIANT: fi_tcs = roughMatchTcs fi_tys
 
                -- Used for "proper matching"; ditto
-           , fi_tvs   :: TyVarSet      -- Template tyvars for full match
-           , fi_tys   :: [Type]        -- Full arg types
-               -- INVARIANT: fi_tvs = tyConTyVars fi_tycon
-               --            fi_tys = case tyConFamInst_maybe fi_tycon of
-               --                         Just (_, tys) -> tys
+           , fi_tvs    :: TyVarSet     -- Template tyvars for full match
+            , fi_fam_tc :: TyCon        -- Family tycon
+           , fi_tys    :: [Type]       --   and its arg types
+               -- INVARIANT: fi_tvs = coAxiomTyVars fi_axiom
+               --            (fi_fam_tc, fi_tys) = coAxiomSplitLHS fi_axiom
+            }
+
+data FamFlavor 
+  = SynFamilyInst         -- A synonym family
+  | DataFamilyInst TyCon  -- A data family, with its representation TyCon
+\end{code}
 
-           , fi_tycon :: TyCon         -- Representation tycon
-           }
 
--- Obtain the representation tycon of a family instance.
---
-famInstTyCon :: FamInst -> TyCon
-famInstTyCon = fi_tycon
+\begin{code}
+-- Obtain the axiom of a family instance
+famInstAxiom :: FamInst -> CoAxiom
+famInstAxiom = fi_axiom
+
+famInstLHS :: FamInst -> (TyCon, [Type])
+famInstLHS (FamInst { fi_fam_tc = tc, fi_tys = tys }) = (tc, tys)
+
+-- Return the representation TyCons introduced by data family instances, if any
+famInstsRepTyCons :: [FamInst] -> [TyCon]
+famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis]
+
+-- Extracts the TyCon for this *data* (or newtype) instance
+famInstRepTyCon_maybe :: FamInst -> Maybe TyCon
+famInstRepTyCon_maybe fi 
+  = case fi_flavor fi of
+       DataFamilyInst tycon -> Just tycon
+       SynFamilyInst        -> Nothing
+
+dataFamInstRepTyCon :: FamInst -> TyCon
+dataFamInstRepTyCon fi 
+  = case fi_flavor fi of
+       DataFamilyInst tycon -> tycon
+       SynFamilyInst        -> pprPanic "dataFamInstRepTyCon" (ppr fi)
 
 famInstTyVars :: FamInst -> TyVarSet
 famInstTyVars = fi_tvs
@@ -82,7 +130,7 @@ famInstTyVars = fi_tvs
 
 \begin{code}
 instance NamedThing FamInst where
-   getName = getName . fi_tycon
+   getName = coAxiomName . fi_axiom
 
 instance Outputable FamInst where
    ppr = pprFamInst
@@ -91,18 +139,17 @@ instance Outputable FamInst where
 pprFamInst :: FamInst -> SDoc
 pprFamInst famInst
   = hang (pprFamInstHdr famInst)
-       2 (vcat [ ifPprDebug (ptext (sLit "Coercion axiom:") <+> pp_ax)
+       2 (vcat [ ifPprDebug (ptext (sLit "Coercion axiom:") <+> ppr ax)
+               , ifPprDebug (ptext (sLit "RHS:") <+> ppr (coAxiomRHS ax))
                , ptext (sLit "--") <+> pprDefinedAt (getName famInst)])
   where
-    pp_ax = case tyConFamilyCoercion_maybe (fi_tycon famInst) of
-              Just ax -> ppr ax
-              Nothing -> ptext (sLit "<not there!>")
+    ax = fi_axiom famInst
 
 pprFamInstHdr :: FamInst -> SDoc
-pprFamInstHdr (FamInst {fi_tycon = rep_tc})
+pprFamInstHdr (FamInst {fi_axiom = axiom, fi_flavor = flavor})
   = pprTyConSort <+> pp_instance <+> pprHead
   where
-    Just (fam_tc, tys) = tyConFamInst_maybe rep_tc 
+    (fam_tc, tys) = coAxiomSplitLHS axiom 
     
     -- For *associated* types, say "type T Int = blah" 
     -- For *top level* type instances, say "type instance T Int = blah"
@@ -111,55 +158,100 @@ pprFamInstHdr (FamInst {fi_tycon = rep_tc})
       | otherwise           = ptext (sLit "instance")
 
     pprHead = pprTypeApp fam_tc tys
-    pprTyConSort | isDataTyCon     rep_tc = ptext (sLit "data")
-                | isNewTyCon      rep_tc = ptext (sLit "newtype")
-                | isSynTyCon      rep_tc = ptext (sLit "type")
-                | isAbstractTyCon rep_tc = ptext (sLit "data")
-                | otherwise              = panic "FamInstEnv.pprFamInstHdr"
+    pprTyConSort = case flavor of
+                     SynFamilyInst        -> ptext (sLit "type")
+                     DataFamilyInst tycon
+                       | isDataTyCon     tycon -> ptext (sLit "data")
+                       | isNewTyCon      tycon -> ptext (sLit "newtype")
+                       | isAbstractTyCon tycon -> ptext (sLit "data")
+                       | otherwise             -> ptext (sLit "WEIRD") <+> ppr tycon
 
 pprFamInsts :: [FamInst] -> SDoc
 pprFamInsts finsts = vcat (map pprFamInst finsts)
 
-famInstHead :: FamInst -> ([TyVar], TyCon, [Type])
-famInstHead (FamInst {fi_tycon = tycon})
-  = case tyConFamInst_maybe tycon of
-      Nothing         -> panic "FamInstEnv.famInstHead"
-      Just (fam, tys) -> (tyConTyVars tycon, fam, tys)
-
--- Make a family instance representation from a tycon.  This is used for local
--- instances, where we can safely pull on the tycon.
---
-mkLocalFamInst :: TyCon -> FamInst
-mkLocalFamInst tycon
-  = case tyConFamInst_maybe tycon of
-           Nothing         -> panic "FamInstEnv.mkLocalFamInst"
-          Just (fam, tys) -> 
-            FamInst {
-              fi_fam   = tyConName fam,
-              fi_tcs   = roughMatchTcs tys,
-              fi_tvs   = mkVarSet . tyConTyVars $ tycon,
-              fi_tys   = tys,
-              fi_tycon = tycon
-            }
+-- | Create a coercion identifying a @type@ family instance.
+-- It has the form @Co tvs :: F ts ~ R@, where @Co@ is 
+-- the coercion constructor built here, @F@ the family tycon and @R@ the
+-- right-hand side of the type family instance.
+mkSynFamInst :: Name       -- ^ Unique name for the coercion tycon
+             -> [TyVar]    -- ^ Type parameters of the coercion (@tvs@)
+             -> TyCon      -- ^ Family tycon (@F@)
+             -> [Type]     -- ^ Type instance (@ts@)
+             -> Type       -- ^ Representation tycon (@R@)
+             -> FamInst
+mkSynFamInst name tvs fam_tc inst_tys rep_ty
+  = FamInst { fi_fam    = tyConName fam_tc,
+              fi_fam_tc = fam_tc,
+              fi_tcs    = roughMatchTcs inst_tys,
+              fi_tvs    = mkVarSet tvs,
+              fi_tys    = inst_tys,
+              fi_flavor = SynFamilyInst,
+              fi_axiom  = axiom }
+  where
+    axiom = CoAxiom { co_ax_unique   = nameUnique name
+                    , co_ax_name     = name
+                    , co_ax_implicit = False
+                    , co_ax_tvs      = tvs
+                    , co_ax_lhs      = mkTyConApp fam_tc inst_tys 
+                    , co_ax_rhs      = rep_ty }
+
+-- | Create a coercion identifying a @data@ or @newtype@ representation type
+-- and its family instance.  It has the form @Co tvs :: F ts ~ R tvs@,
+-- where @Co@ is the coercion constructor built here, @F@ the family tycon
+-- and @R@ the (derived) representation tycon.
+mkDataFamInst :: Name         -- ^ Unique name for the coercion tycon
+              -> [TyVar]      -- ^ Type parameters of the coercion (@tvs@)
+              -> TyCon        -- ^ Family tycon (@F@)
+              -> [Type]       -- ^ Type instance (@ts@)
+              -> TyCon        -- ^ Representation tycon (@R@)
+              -> FamInst
+mkDataFamInst name tvs fam_tc inst_tys rep_tc
+  = FamInst { fi_fam    = tyConName fam_tc,
+              fi_fam_tc = fam_tc,
+              fi_tcs    = roughMatchTcs inst_tys,
+              fi_tvs    = mkVarSet tvs,
+              fi_tys    = inst_tys,
+              fi_flavor = DataFamilyInst rep_tc,
+              fi_axiom  = axiom }
+  where
+    axiom = CoAxiom { co_ax_unique   = nameUnique name
+                    , co_ax_name     = name
+                    , co_ax_implicit = False
+                    , co_ax_tvs      = tvs
+                    , co_ax_lhs      = mkTyConApp fam_tc inst_tys 
+                    , co_ax_rhs      = mkTyConApp rep_tc (mkTyVarTys tvs) }
 
 -- Make a family instance representation from the information found in an
--- unterface file.  In particular, we get the rough match info from the iface
+-- interface file.  In particular, we get the rough match info from the iface
 -- (instead of computing it here).
---
-mkImportedFamInst :: Name -> [Maybe Name] -> TyCon -> FamInst
-mkImportedFamInst fam mb_tcs tycon
+mkImportedFamInst :: Name               -- Name of the family
+                  -> [Maybe Name]       -- Rough match info
+                  -> CoAxiom            -- Axiom introduced
+                  -> FamInst            -- Resulting family instance
+mkImportedFamInst fam mb_tcs axiom
   = FamInst {
-      fi_fam   = fam,
-      fi_tcs   = mb_tcs,
-      fi_tvs   = mkVarSet . tyConTyVars $ tycon,
-      fi_tys   = case tyConFamInst_maybe tycon of
-                  Nothing       -> panic "FamInstEnv.mkImportedFamInst"
-                  Just (_, tys) -> tys,
-      fi_tycon = tycon
-    }
+      fi_fam    = fam,
+      fi_fam_tc = fam_tc,
+      fi_tcs    = mb_tcs,
+      fi_tvs    = mkVarSet . coAxiomTyVars $ axiom,
+      fi_tys    = tys,
+      fi_axiom  = axiom,
+      fi_flavor = flavor }
+  where 
+     (fam_tc, tys) = coAxiomSplitLHS axiom
+
+         -- Derive the flavor for an imported FamInst rather disgustingly
+         -- Maybe we should store it in the IfaceFamInst?
+     flavor = case splitTyConApp_maybe (coAxiomRHS axiom) of
+                Just (tc, _)
+                  | Just ax' <- tyConFamilyCoercion_maybe tc
+                  , ax' == axiom
+                  -> DataFamilyInst tc
+                _ -> SynFamilyInst
 \end{code}
 
 
+
 %************************************************************************
 %*                                                                     *
                FamInstEnv
@@ -242,9 +334,8 @@ overwriteFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs
     ins_tyvar = not (any isJust mb_tcs)
     match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys
     
-    inst_tycon = famInstTyCon ins_item
-    (fam, tys) = expectJust "FamInstEnv.lookuFamInstEnvConflicts"
-                           (tyConFamInst_maybe inst_tycon)
+    inst_axiom = famInstAxiom ins_item
+    (fam, tys) = coAxiomSplitLHS inst_axiom
     arity = tyConArity fam
     n_tys = length tys
     match_tys 
@@ -326,11 +417,10 @@ lookupFamInstEnvConflicts
 lookupFamInstEnvConflicts envs fam_inst skol_tvs
   = lookup_fam_inst_env my_unify False envs fam tys1
   where
-    inst_tycon = famInstTyCon fam_inst
-    (fam, tys) = expectJust "FamInstEnv.lookuFamInstEnvConflicts"
-                           (tyConFamInst_maybe inst_tycon)
-    skol_tys = mkTyVarTys skol_tvs
-    tys1     = substTys (zipTopTvSubst (tyConTyVars inst_tycon) skol_tys) tys
+    inst_axiom = famInstAxiom fam_inst
+    (fam, tys) = famInstLHS fam_inst
+    skol_tys   = mkTyVarTys skol_tvs
+    tys1       = substTys (zipTopTvSubst (coAxiomTyVars inst_axiom) skol_tys) tys
         -- In example above,   fam tys' = F [b]   
 
     my_unify old_fam_inst tpl_tvs tpl_tys match_tys
@@ -348,10 +438,10 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs
       | isAlgTyCon fam = True
       | otherwise      = not (old_rhs `eqType` new_rhs)
       where
-        old_tycon = famInstTyCon old_fam_inst
-        old_tvs   = tyConTyVars old_tycon
-        old_rhs   = mkTyConApp old_tycon  (substTyVars subst old_tvs)
-        new_rhs   = mkTyConApp inst_tycon (substTyVars subst skol_tvs)
+        old_axiom = famInstAxiom old_fam_inst
+        old_tvs   = coAxiomTyVars old_axiom
+        old_rhs   = mkAxInstRHS old_axiom  (substTyVars subst old_tvs)
+        new_rhs   = mkAxInstRHS inst_axiom (substTyVars subst skol_tvs)
 
 -- This variant is called when we want to check if the conflict is only in the
 -- home environment (see FamInst.addLocalFamInst)
@@ -436,14 +526,14 @@ lookup_fam_inst_env' match_fun one_sided ie fam tys
     --------------
     find [] = []
     find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, 
-                         fi_tys = tpl_tys, fi_tycon = tycon }) : rest)
+                         fi_tys = tpl_tys, fi_axiom = axiom }) : rest)
        -- Fast check for no match, uses the "rough match" fields
       | instanceCantMatch rough_tcs mb_tcs
       = find rest
 
         -- Proper check
       | Just subst <- match_fun item tpl_tvs tpl_tys match_tys
-      = (item, add_extra_tys $ substTyVars subst (tyConTyVars tycon)) : find rest
+      = (item, add_extra_tys $ substTyVars subst (coAxiomTyVars axiom)) : find rest
 
         -- No match => try next
       | otherwise
@@ -547,11 +637,11 @@ normaliseTcApp env tc tys
   , tyConArity tc <= length tys           -- Unsaturated data families are possible
   , [(fam_inst, inst_tys)] <- lookupFamInstEnv env tc ntys 
   = let    -- A matching family instance exists
-       rep_tc          = famInstTyCon fam_inst
-       co_tycon        = expectJust "lookupFamInst" (tyConFamilyCoercion_maybe rep_tc)
-       co              = mkAxInstCo co_tycon inst_tys
+        ax              = famInstAxiom fam_inst
+        co              = mkAxInstCo  ax inst_tys
+        rhs             = mkAxInstRHS ax inst_tys
        first_coi       = mkTransCo tycon_coi co
-       (rest_coi,nty)  = normaliseType env (mkTyConApp rep_tc inst_tys)
+       (rest_coi,nty)  = normaliseType env rhs
        fix_coi         = mkTransCo first_coi rest_coi
     in 
     (fix_coi, nty)
index 70eabb4..8a15813 100644 (file)
@@ -324,7 +324,7 @@ improveFromInstEnv inst_env pred@(ty, _)
                -- Remember that instanceCantMatch treats both argumnents
                -- symmetrically, so it's ok to trim the rough_tcs,
                -- rather than trimming each inst_tcs in turn
-    , ispec@(Instance { is_tvs = qtvs, is_tys = tys_inst,
+    , ispec@(ClsInst { is_tvs = qtvs, is_tys = tys_inst,
                        is_tcs = inst_tcs }) <- instances
     , not (instanceCantMatch inst_tcs trimmed_tcs)
     , let p_inst = (mkClassPred cls tys_inst,
@@ -504,8 +504,8 @@ if s1 matches
 
 
 \begin{code}
-checkFunDeps :: (InstEnv, InstEnv) -> Instance
-            -> Maybe [Instance]        -- Nothing  <=> ok
+checkFunDeps :: (InstEnv, InstEnv) -> ClsInst
+            -> Maybe [ClsInst] -- Nothing  <=> ok
                                        -- Just dfs <=> conflict with dfs
 -- Check wheher adding DFunId would break functional-dependency constraints
 -- Used only for instance decls defined in the module being compiled
@@ -518,14 +518,14 @@ checkFunDeps inst_envs ispec
     cls_inst_env = classInstances inst_envs clas
     bad_fundeps  = badFunDeps cls_inst_env clas ins_tv_set ins_tys
 
-badFunDeps :: [Instance] -> Class
+badFunDeps :: [ClsInst] -> Class
           -> TyVarSet -> [Type]        -- Proposed new instance type
-          -> [Instance]
+          -> [ClsInst]
 badFunDeps cls_insts clas ins_tv_set ins_tys 
   = nubBy eq_inst $
     [ ispec | fd <- fds,       -- fds is often empty, so do this first!
              let trimmed_tcs = trimRoughMatchTcs clas_tvs fd rough_tcs,
-             ispec@(Instance { is_tcs = inst_tcs, is_tvs = tvs, 
+             ispec@(ClsInst { is_tcs = inst_tcs, is_tvs = tvs, 
                                is_tys = tys }) <- cls_insts,
                -- Filter out ones that can't possibly match, 
                -- based on the head of the fundep
index d05495f..ee0749a 100644 (file)
@@ -9,7 +9,7 @@ The bits common to TcInstDcls and TcDeriv.
 \begin{code}
 module InstEnv (
         DFunId, OverlapFlag(..),
-        Instance(..), pprInstance, pprInstanceHdr, pprInstances, 
+        ClsInst(..), pprInstance, pprInstanceHdr, pprInstances, 
         instanceHead, mkLocalInstance, mkImportedInstance,
         instanceDFunId, setInstanceDFunId, instanceRoughTcs,
 
@@ -47,8 +47,8 @@ import Data.Maybe       ( isJust, isNothing )
 %************************************************************************
 
 \begin{code}
-data Instance 
-  = Instance { is_cls  :: Name  -- Class name
+data ClsInst 
+  = ClsInst { is_cls  :: Name  -- Class name
 
                 -- Used for "rough matching"; see Note [Rough-match field]
                 -- INVARIANT: is_tcs = roughMatchTcs is_tys
@@ -117,15 +117,15 @@ being equal to
   * the InstDecl used to construct the Instance.
 
 \begin{code}
-instanceDFunId :: Instance -> DFunId
+instanceDFunId :: ClsInst -> DFunId
 instanceDFunId = is_dfun
 
-setInstanceDFunId :: Instance -> DFunId -> Instance
+setInstanceDFunId :: ClsInst -> DFunId -> ClsInst
 setInstanceDFunId ispec dfun
    = ASSERT( idType dfun `eqType` idType (is_dfun ispec) )
         -- We need to create the cached fields afresh from
         -- the new dfun id.  In particular, the is_tvs in
-        -- the Instance must match those in the dfun!
+        -- the ClsInst must match those in the dfun!
         -- We assume that the only thing that changes is
         -- the quantified type variables, so the other fields
         -- are ok; hence the assert
@@ -133,27 +133,27 @@ setInstanceDFunId ispec dfun
    where 
      (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
 
-instanceRoughTcs :: Instance -> [Maybe Name]
+instanceRoughTcs :: ClsInst -> [Maybe Name]
 instanceRoughTcs = is_tcs
 \end{code}
 
 \begin{code}
-instance NamedThing Instance where
+instance NamedThing ClsInst where
    getName ispec = getName (is_dfun ispec)
 
-instance Outputable Instance where
+instance Outputable ClsInst where
    ppr = pprInstance
 
-pprInstance :: Instance -> SDoc
--- Prints the Instance as an instance declaration
+pprInstance :: ClsInst -> SDoc
+-- Prints the ClsInst as an instance declaration
 pprInstance ispec
   = hang (pprInstanceHdr ispec)
         2 (ptext (sLit "--") <+> pprDefinedAt (getName ispec))
 
 -- * pprInstanceHdr is used in VStudio to populate the ClassView tree
-pprInstanceHdr :: Instance -> SDoc
--- Prints the Instance as an instance declaration
-pprInstanceHdr ispec@(Instance { is_flag = flag })
+pprInstanceHdr :: ClsInst -> SDoc
+-- Prints the ClsInst as an instance declaration
+pprInstanceHdr ispec@(ClsInst { is_flag = flag })
   = ptext (sLit "instance") <+> ppr flag
        <+> sep [pprThetaArrowTy theta, ppr res_ty]
   where
@@ -161,10 +161,10 @@ pprInstanceHdr ispec@(Instance { is_flag = flag })
     (_, theta, res_ty) = tcSplitSigmaTy (idType dfun)
         -- Print without the for-all, which the programmer doesn't write
 
-pprInstances :: [Instance] -> SDoc
+pprInstances :: [ClsInst] -> SDoc
 pprInstances ispecs = vcat (map pprInstance ispecs)
 
-instanceHead :: Instance -> ([TyVar], ThetaType, Class, [Type])
+instanceHead :: ClsInst -> ([TyVar], ThetaType, Class, [Type])
 instanceHead ispec = (tvs, theta, cls, tys)
    where
      (tvs, theta, tau) = tcSplitSigmaTy (idType dfun)
@@ -173,21 +173,21 @@ instanceHead ispec = (tvs, theta, cls, tys)
 
 mkLocalInstance :: DFunId
                 -> OverlapFlag
-                -> Instance
+                -> ClsInst
 -- Used for local instances, where we can safely pull on the DFunId
 mkLocalInstance dfun oflag
-  = Instance {  is_flag = oflag, is_dfun = dfun,
+  = ClsInst {  is_flag = oflag, is_dfun = dfun,
                 is_tvs = mkVarSet tvs, is_tys = tys,
                 is_cls = className cls, is_tcs = roughMatchTcs tys }
   where
     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
 
 mkImportedInstance :: Name -> [Maybe Name]
-                   -> DFunId -> OverlapFlag -> Instance
+                   -> DFunId -> OverlapFlag -> ClsInst
 -- Used for imported instances, where we get the rough-match stuff
 -- from the interface file
 mkImportedInstance cls mb_tcs dfun oflag
-  = Instance {  is_flag = oflag, is_dfun = dfun,
+  = ClsInst {  is_flag = oflag, is_dfun = dfun,
                 is_tvs = mkVarSet tvs, is_tys = tys,
                 is_cls = cls, is_tcs = mb_tcs }
   where
@@ -354,13 +354,13 @@ or, to put it another way, we have
 type InstEnv = UniqFM ClsInstEnv        -- Maps Class to instances for that class
 
 newtype ClsInstEnv 
-  = ClsIE [Instance]    -- The instances for a particular class, in any order
+  = ClsIE [ClsInst]    -- The instances for a particular class, in any order
 
 instance Outputable ClsInstEnv where
   ppr (ClsIE is) = pprInstances is
 
 -- INVARIANTS:
---  * The is_tvs are distinct in each Instance
+--  * The is_tvs are distinct in each ClsInst
 --      of a ClsInstEnv (so we can safely unify them)
 
 -- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry:
@@ -371,10 +371,10 @@ instance Outputable ClsInstEnv where
 emptyInstEnv :: InstEnv
 emptyInstEnv = emptyUFM
 
-instEnvElts :: InstEnv -> [Instance]
+instEnvElts :: InstEnv -> [ClsInst]
 instEnvElts ie = [elt | ClsIE elts <- eltsUFM ie, elt <- elts]
 
-classInstances :: (InstEnv,InstEnv) -> Class -> [Instance]
+classInstances :: (InstEnv,InstEnv) -> Class -> [ClsInst]
 classInstances (pkg_ie, home_ie) cls 
   = get home_ie ++ get pkg_ie
   where
@@ -382,24 +382,24 @@ classInstances (pkg_ie, home_ie) cls
                 Just (ClsIE insts) -> insts
                 Nothing            -> []
 
-extendInstEnvList :: InstEnv -> [Instance] -> InstEnv
+extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv
 extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs
 
-extendInstEnv :: InstEnv -> Instance -> InstEnv
-extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm })
+extendInstEnv :: InstEnv -> ClsInst -> InstEnv
+extendInstEnv inst_env ins_item@(ClsInst { is_cls = cls_nm })
   = addToUFM_C add inst_env cls_nm (ClsIE [ins_item])
   where
     add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts)
 
-overwriteInstEnv :: InstEnv -> Instance -> InstEnv
-overwriteInstEnv inst_env ins_item@(Instance { is_cls = cls_nm, is_tys = tys })
+overwriteInstEnv :: InstEnv -> ClsInst -> InstEnv
+overwriteInstEnv inst_env ins_item@(ClsInst { is_cls = cls_nm, is_tys = tys })
   = addToUFM_C add inst_env cls_nm (ClsIE [ins_item])
   where
     add (ClsIE cur_insts) _ = ClsIE (replaceInst cur_insts)
     
     rough_tcs  = roughMatchTcs tys
     replaceInst [] = [ins_item]
-    replaceInst (item@(Instance { is_tcs = mb_tcs,  is_tvs = tpl_tvs, 
+    replaceInst (item@(ClsInst { is_tcs = mb_tcs,  is_tvs = tpl_tvs, 
                                   is_tys = tpl_tys,
                                   is_dfun = dfun }) : rest)
     -- Fast check for no match, uses the "rough match" fields
@@ -431,13 +431,13 @@ type InstTypes = [Either TyVar Type]
         -- Right ty     => Instantiate with this type
         -- Left tv      => Instantiate with any type of this tyvar's kind
 
-type InstMatch = (Instance, InstTypes)
+type InstMatch = (ClsInst, InstTypes)
 \end{code}
 
 Note [InstTypes: instantiating types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A successful match is an Instance, together with the types at which
-        the dfun_id in the Instance should be instantiated
+A successful match is an ClsInst, together with the types at which
+        the dfun_id in the ClsInst should be instantiated
 The instantiating types are (Either TyVar Type)s because the dfun
 might have some tyvars that *only* appear in arguments
         dfun :: forall a b. C a b, Ord b => D [a]
@@ -454,7 +454,7 @@ where the 'Left b' indicates that 'b' can be freely instantiated.
 --
 lookupUniqueInstEnv :: (InstEnv, InstEnv) 
                     -> Class -> [Type]
-                    -> Either Message (Instance, [Type])
+                    -> Either Message (ClsInst, [Type])
 lookupUniqueInstEnv instEnv cls tys
   = case lookupInstEnv instEnv cls tys of
       ([(inst, inst_tys)], _, _) 
@@ -472,7 +472,7 @@ lookupUniqueInstEnv instEnv cls tys
 lookupInstEnv' :: InstEnv          -- InstEnv to look in
                -> Class -> [Type]  -- What we are looking for
                -> ([InstMatch],    -- Successful matches
-                   [Instance])     -- These don't match but do unify
+                   [ClsInst])     -- These don't match but do unify
 -- The second component of the result pair happens when we look up
 --      Foo [a]
 -- in an InstEnv that has entries for
@@ -495,7 +495,7 @@ lookupInstEnv' ie cls tys
 
     --------------
     find ms us [] = (ms, us)
-    find ms us (item@(Instance { is_tcs = mb_tcs, is_tvs = tpl_tvs, 
+    find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs, 
                                  is_tys = tpl_tys, is_flag = oflag,
                                  is_dfun = dfun }) : rest)
         -- Fast check for no match, uses the "rough match" fields
@@ -537,7 +537,7 @@ lookupInstEnv' ie cls tys
 lookupInstEnv :: (InstEnv, InstEnv)     -- External and home package inst-env
                    -> Class -> [Type]   -- What we are looking for
                    -> ([InstMatch],     -- Successful matches
-                       [Instance],      -- These don't match but do unify
+                       [ClsInst],      -- These don't match but do unify
                        Bool)            -- True if error condition caused by
                                         -- SafeHaskell condition.
 
index fa467a7..91af7fc 100644 (file)
@@ -30,7 +30,7 @@ module Kind (
        pprKind, pprParendKind,
 
         -- ** Deconstructing Kinds
-        kindFunResult, kindAppResult, synTyConResKind,
+        kindAppResult, synTyConResKind,
         splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe,
 
         -- ** Predicates on Kinds
index f8745e6..f5c0567 100644 (file)
@@ -22,7 +22,9 @@ module TyCon(
        SynTyConRhs(..),
 
        -- ** Coercion axiom constructors
-        CoAxiom(..), coAxiomName, coAxiomArity,
+        CoAxiom(..), 
+        coAxiomName, coAxiomArity, coAxiomTyVars,
+        coAxiomLHS, coAxiomRHS, isImplicitCoAxiom,
 
         -- ** Constructing TyCons
        mkAlgTyCon,
@@ -71,7 +73,7 @@ module TyCon(
        tyConArity,
         tyConParent,
        tyConTuple_maybe, tyConClass_maybe, tyConIP_maybe,
-       tyConFamInst_maybe, tyConFamilyCoercion_maybe,tyConFamInstSig_maybe,
+       tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe,
         synTyConDefn, synTyConRhs, synTyConType,
         tyConExtName,           -- External name for foreign types
        algTyConRhs,
@@ -138,48 +140,11 @@ Note [Type synonym families]
   translates to
     a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon
 
-* Translation of type instance decl:
-       type instance F [a] = Maybe a
-  translates to a "representation TyCon", 'R:FList', where
-     R:FList is a SynTyCon, whose 
-       SynTyConRhs is (SynonymTyCon (Maybe a))
-       TyConParent is (FamInstTyCon F [a] co)
-         where co :: F [a] ~ R:FList a
-
-  It's very much as if the user had written
-       type instance F [a] = R:FList a
-       type R:FList a = Maybe a
-  Indeed, in GHC's internal representation, the RHS of every
-  'type instance' is simply an application of the representation
-  TyCon to the quantified varaibles.
-
-  The intermediate representation TyCon is a bit gratuitous, but 
-  it means that:
-
-        each 'type instance' decls is in 1-1 correspondance 
-       with its representation TyCon
-
-  So the result of typechecking a 'type instance' decl is just a
-  TyCon.  In turn this means that type and data families can be
-  treated uniformly.
-
 * Translation of type family decl:
        type family F a :: *
   translates to
     a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon
 
-* Translation of type instance decl:
-       type instance F [a] = Maybe a
-  translates to
-    A SynTyCon 'R:FList a', whose 
-       SynTyConRhs is (SynonymTyCon (Maybe a))
-       TyConParent is (FamInstTyCon F [a] co)
-         where co :: F [a] ~ R:FList a
-    Notice that we introduce a gratuitous vanilla type synonym
-       type R:FList a = Maybe a
-    solely so that type and data families can be treated more
-    uniformly, via a single FamInstTyCon descriptor        
-
 * In the future we might want to support
     * closed type families (esp when we have proper kinds)
     * injective type families (allow decomposition)
@@ -570,7 +535,7 @@ data TyConParent
         Class          -- The class in whose declaration the family is declared
                        -- See Note [Associated families and their parent class]
 
-  -- | Type constructors representing an instance of a type family. Parameters:
+  -- | Type constructors representing an instance of a *data* family. Parameters:
   --
   --  1) The type family in question
   --
@@ -581,11 +546,17 @@ data TyConParent
   --  3) A 'CoTyCon' identifying the representation
   --  type with the type instance family
   | FamInstTyCon         -- See Note [Data type families]
-                         -- and Note [Type synonym families]
+        CoAxiom   -- The coercion constructor,
+                  -- always of kind   T ty1 ty2 ~ R:T a b c
+                  -- where T is the family TyCon, 
+                  -- and R:T is the representation TyCon (ie this one)
+                  -- and a,b,c are the tyConTyVars of this TyCon
+
+          -- Cached fields of the CoAxiom, but adjusted to
+          -- use the tyConTyVars of this TyCon
        TyCon   -- The family TyCon
        [Type]  -- Argument types (mentions the tyConTyVars of this TyCon)
                -- Match in length the tyConTyVars of the family TyCon
-        CoAxiom   -- The coercion constructor
 
        -- E.g.  data intance T [a] = ...
        -- gives a representation tycon:
@@ -598,15 +569,15 @@ instance Outputable TyConParent where
     ppr (ClassTyCon cls)        = text "Class parent" <+> ppr cls
     ppr (IPTyCon n)             = text "IP parent" <+> ppr n
     ppr (AssocFamilyTyCon cls)  = text "Class parent (assoc. family)" <+> ppr cls
-    ppr (FamInstTyCon tc tys _) = text "Family parent (family instance)" <+> ppr tc <+> sep (map ppr tys)
+    ppr (FamInstTyCon _ tc tys) = text "Family parent (family instance)" <+> ppr tc <+> sep (map ppr tys)
 
 -- | Checks the invariants of a 'TyConParent' given the appropriate type class name, if any
 okParent :: Name -> TyConParent -> Bool
-okParent _       NoParentTyCon                    = True
-okParent tc_name (AssocFamilyTyCon cls)           = tc_name `elem` map tyConName (classATs cls)
-okParent tc_name (ClassTyCon cls)                 = tc_name == tyConName (classTyCon cls)
-okParent tc_name (IPTyCon ip)                     = tc_name == ipTyConName ip
-okParent _       (FamInstTyCon fam_tc tys _co_tc) = tyConArity fam_tc == length tys
+okParent _       NoParentTyCon               = True
+okParent tc_name (AssocFamilyTyCon cls)      = tc_name `elem` map tyConName (classATs cls)
+okParent tc_name (ClassTyCon cls)            = tc_name == tyConName (classTyCon cls)
+okParent tc_name (IPTyCon ip)                = tc_name == ipTyConName ip
+okParent _       (FamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys
 
 isNoParent :: TyConParent -> Bool
 isNoParent NoParentTyCon = True
@@ -676,23 +647,21 @@ See Trac #4528.
 
 Note [Newtype coercions]
 ~~~~~~~~~~~~~~~~~~~~~~~~
-The NewTyCon field nt_co is a a TyCon (a coercion constructor in fact)
-which is used for coercing from the representation type of the
-newtype, to the newtype itself. For example,
+The NewTyCon field nt_co is a CoAxiom which is used for coercing from
+the representation type of the newtype, to the newtype itself. For
+example,
 
    newtype T a = MkT (a -> a)
 
-the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t ->
-t.  This TyCon is a CoTyCon, so it does not have a kind on its
-own; it basically has its own typing rule for the fully-applied
-version.  If the newtype T has k type variables then CoT has arity at
-most k.  In the case that the right hand side is a type application
+the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t.  
+
+In the case that the right hand side is a type application
 ending with the same type variables as the left hand side, we
 "eta-contract" the coercion.  So if we had
 
    newtype S a = MkT [a]
 
-then we would generate the arity 0 coercion CoS : S ~ [].  The
+then we would generate the arity 0 axiom CoS : S ~ [].  The
 primary reason we do this is to make newtype deriving cleaner.
 
 In the paper we'd write
@@ -701,14 +670,6 @@ and then when we used CoT at a particular type, s, we'd say
        CoT @ s
 which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s])
 
-But in GHC we instead make CoT into a new piece of type syntax, CoTyCon,
-(like instCoercionTyCon, symCoercionTyCon etc), which must always
-be saturated, but which encodes as
-       TyConApp CoT [s]
-In the vocabulary of the paper it's as if we had axiom declarations
-like
-       axiom CoT t :  T t ~ [t]
-
 Note [Newtype eta]
 ~~~~~~~~~~~~~~~~~~
 Consider
@@ -757,12 +718,14 @@ so the coercion tycon CoT must have
 \begin{code}
 -- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom.
 data CoAxiom
-  = CoAxiom                   -- type equality axiom.
-    { co_ax_unique :: Unique   -- unique identifier
-    , co_ax_name   :: Name     -- name for pretty-printing
-    , co_ax_tvs    :: [TyVar]  -- bound type variables 
-    , co_ax_lhs    :: Type     -- left-hand side of the equality
-    , co_ax_rhs    :: Type     -- right-hand side of the equality
+  = CoAxiom                   -- Type equality axiom.
+    { co_ax_unique   :: Unique      -- unique identifier
+    , co_ax_name     :: Name        -- name for pretty-printing
+    , co_ax_tvs      :: [TyVar]     -- bound type variables 
+    , co_ax_lhs      :: Type        -- left-hand side of the equality
+    , co_ax_rhs      :: Type        -- right-hand side of the equality
+    , co_ax_implicit :: Bool        -- True <=> the axiom is "implicit"
+                                    -- See Note [Implicit axioms]
     }
   deriving Typeable
 
@@ -771,8 +734,29 @@ coAxiomArity ax = length (co_ax_tvs ax)
 
 coAxiomName :: CoAxiom -> Name
 coAxiomName = co_ax_name
+
+coAxiomTyVars :: CoAxiom -> [TyVar]
+coAxiomTyVars = co_ax_tvs
+
+coAxiomLHS, coAxiomRHS :: CoAxiom -> Type
+coAxiomLHS = co_ax_lhs
+coAxiomRHS = co_ax_rhs
+
+isImplicitCoAxiom :: CoAxiom -> Bool
+isImplicitCoAxiom = co_ax_implicit
 \end{code}
 
+Note [Implicit axioms]
+~~~~~~~~~~~~~~~~~~~~~~
+See also Note [Implicit TyThings] in HscTypes
+* A CoAxiom arising from data/type family instances is not "implicit".
+  That is, it has its own IfaceAxiom declaration in an interface file
+
+* The CoAxiom arising from a newtype declaration *is* "implicit".
+  That is, it does not have its own IfaceAxiom declaration in an
+  interface file; instead the CoAxiom is generated by type-checking
+  the newtype declaration
+
 
 %************************************************************************
 %*                                                                     *
@@ -1251,12 +1235,13 @@ isPromotedTypeTyCon _                      = False
 -- * Family instances are /not/ implicit as they represent the instance body
 --   (similar to a @dfun@ does that for a class instance).
 isImplicitTyCon :: TyCon -> Bool
-isImplicitTyCon tycon | isTyConAssoc tycon           = True
-                     | isSynTyCon tycon             = False
-                     | isAlgTyCon tycon             = isTupleTyCon tycon
-isImplicitTyCon _other                               = True
-        -- catches: FunTyCon, PrimTyCon, 
-        -- CoTyCon, SuperKindTyCon
+isImplicitTyCon tycon 
+  | isTyConAssoc tycon = True
+  | isSynTyCon tycon   = False
+  | isAlgTyCon tycon   = isTupleTyCon tycon
+  | otherwise          = True
+        -- 'otherwise' catches: FunTyCon, PrimTyCon, 
+        -- PromotedDataCon, PomotedTypeTyCon, SuperKindTyCon
 \end{code}
 
 
@@ -1465,15 +1450,15 @@ isFamInstTyCon tc = case tyConParent tc of
 tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom)
 tyConFamInstSig_maybe tc
   = case tyConParent tc of
-      FamInstTyCon f ts co_tc -> Just (f, ts, co_tc)
-      _                       -> Nothing
+      FamInstTyCon ax f ts -> Just (f, ts, ax)
+      _                    -> Nothing
 
 -- | If this 'TyCon' is that of a family instance, return the family in question
 -- and the instance types. Otherwise, return @Nothing@
 tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])
 tyConFamInst_maybe tc
   = case tyConParent tc of
-      FamInstTyCon f ts _ -> Just (f, ts)
+      FamInstTyCon _ f ts -> Just (f, ts)
       _                   -> Nothing
 
 -- | If this 'TyCon' is that of a family instance, return a 'TyCon' which represents 
@@ -1482,7 +1467,7 @@ tyConFamInst_maybe tc
 tyConFamilyCoercion_maybe :: TyCon -> Maybe CoAxiom
 tyConFamilyCoercion_maybe tc
   = case tyConParent tc of
-      FamInstTyCon _ _ co -> Just co
+      FamInstTyCon co _ _ -> Just co
       _                   -> Nothing
 \end{code}
 
index 0af5fe0..d73bea1 100644 (file)
@@ -44,13 +44,14 @@ import Name
 --
 buildPADict
         :: TyCon        -- ^ tycon of the type being vectorised.
-        -> TyCon        -- ^ tycon of the type used for the vectorised representation.
+        -> CoAxiom      -- ^ Coercion between the type and 
+                        --     its vectorised representation.
         -> TyCon        -- ^ PData  instance tycon
         -> TyCon        -- ^ PDatas instance tycon
         -> SumRepr      -- ^ representation used for the type being vectorised.
         -> VM Var       -- ^ name of the top-level dictionary function.
 
-buildPADict vect_tc prepr_tc pdata_tc pdatas_tc repr
+buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr
  = polyAbstract tvs $ \args ->    -- The args are the dictionaries we lambda
                                   -- abstract over; and they are put in the
                                   -- envt, so when we need a (PA a) we can 
@@ -94,7 +95,7 @@ buildPADict vect_tc prepr_tc pdata_tc pdatas_tc repr
 
     method args dfun_name (name, build)
      = localV
-     $ do  expr     <- build vect_tc prepr_tc pdata_tc pdatas_tc repr
+     $ do  expr     <- build vect_tc prepr_ax pdata_tc pdatas_tc repr
            let body = mkLams (tvs ++ args) expr
            raw_var  <- newExportedVar (method_name dfun_name name) (exprType body)
            let var  = raw_var
index 85e3336..ce2d947 100644 (file)
@@ -15,10 +15,10 @@ import Vectorise.Builtins
 import Vectorise.Generic.Description
 import CoreSyn
 import CoreUtils
+import FamInstEnv
 import MkCore            ( mkWildCase )
 import TyCon
 import Type
-import BuildTyCl
 import OccName
 import Coercion
 import MkId
@@ -29,26 +29,15 @@ import Control.Monad
 import Outputable
 
 
-buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon
+buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
 buildPReprTyCon orig_tc vect_tc repr
  = do name      <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc)
       rhs_ty    <- sumReprType repr
       prepr_tc  <- builtin preprTyCon
-      liftDs    $  buildSynTyCon name
-                             tyvars
-                             (SynonymTyCon rhs_ty)
-                             (typeKind rhs_ty)
-                             NoParentTyCon
-                             (Just $ mk_fam_inst prepr_tc vect_tc)
+      return $ mkSynFamInst name tyvars prepr_tc instTys rhs_ty
   where
     tyvars = tyConTyVars vect_tc
-
-
-mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
-mk_fam_inst fam_tc arg_tc
-  = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
-
-
+    instTys = [mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars vect_tc]
 
 -- buildPAScAndMethods --------------------------------------------------------
 
@@ -69,7 +58,7 @@ mk_fam_inst fam_tc arg_tc
 --
 type PAInstanceBuilder
         =  TyCon        -- ^ Vectorised TyCon 
-        -> TyCon        -- ^ Representation TyCon
+        -> CoAxiom      -- ^ Coercion to the representation TyCon
         -> TyCon        -- ^ 'PData'  TyCon
         -> TyCon        -- ^ 'PDatas' TyCon
         -> SumRepr      -- ^ Description of generic representation.
@@ -88,8 +77,8 @@ buildPAScAndMethods
 
 
 buildPRDict :: PAInstanceBuilder
-buildPRDict vect_tc prepr_tc _ _ _
-  = prDictOfPReprInstTyCon inst_ty prepr_tc arg_tys
+buildPRDict vect_tc prepr_ax _ _ _
+  = prDictOfPReprInstTyCon inst_ty prepr_ax arg_tys
   where
     arg_tys = mkTyVarTys (tyConTyVars vect_tc)
     inst_ty = mkTyConApp vect_tc arg_tys
@@ -98,7 +87,7 @@ buildPRDict vect_tc prepr_tc _ _ _
 -- buildToPRepr ---------------------------------------------------------------
 -- | Build the 'toRepr' method of the PA class.
 buildToPRepr :: PAInstanceBuilder
-buildToPRepr vect_tc repr_tc _ _ repr
+buildToPRepr vect_tc repr_ax _ _ repr
  = do let arg_ty = mkTyConApp vect_tc ty_args
 
       -- Get the representation type of the argument.
@@ -114,7 +103,7 @@ buildToPRepr vect_tc repr_tc _ _ repr
   where
     ty_args        = mkTyVarTys (tyConTyVars vect_tc)
 
-    wrap_repr_inst = wrapFamInstBody repr_tc ty_args
+    wrap_repr_inst = wrapTypeFamInstBody repr_ax ty_args
 
     -- CoreExp to convert the given argument to the generic representation.
     -- We start by doing a case branch on the possible data constructors.
@@ -172,12 +161,12 @@ buildToPRepr vect_tc repr_tc _ _ repr
 -- |Build the 'fromPRepr' method of the PA class.
 --
 buildFromPRepr :: PAInstanceBuilder
-buildFromPRepr vect_tc repr_tc _ _ repr
+buildFromPRepr vect_tc repr_ax _ _ repr
   = do
       arg_ty <- mkPReprType res_ty
       arg <- newLocalVar (fsLit "x") arg_ty
 
-      result <- from_sum (unwrapFamInstScrut repr_tc ty_args (Var arg))
+      result <- from_sum (unwrapTypeFamInstScrut repr_ax ty_args (Var arg))
                          repr
       return $ Lam arg result
   where
@@ -225,14 +214,13 @@ buildFromPRepr vect_tc repr_tc _ _ repr
 -- |Build the 'toArrRepr' method of the PA class.
 --
 buildToArrPRepr :: PAInstanceBuilder
-buildToArrPRepr vect_tc prepr_tc pdata_tc _ r
+buildToArrPRepr vect_tc repr_co pdata_tc _ r
  = do arg_ty <- mkPDataType el_ty
       res_ty <- mkPDataType =<< mkPReprType el_ty
       arg    <- newLocalVar (fsLit "xs") arg_ty
 
       pdata_co <- mkBuiltinCo pdataTyCon
-      let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
-          co           = mkAppCo pdata_co
+      let co           = mkAppCo pdata_co
                        . mkSymCo
                        $ mkAxInstCo repr_co ty_args
 
@@ -291,13 +279,12 @@ buildToArrPRepr vect_tc prepr_tc pdata_tc _ r
 -- |Build the 'fromArrPRepr' method for the PA class.
 --
 buildFromArrPRepr :: PAInstanceBuilder
-buildFromArrPRepr vect_tc prepr_tc pdata_tc _ r
+buildFromArrPRepr vect_tc repr_co pdata_tc _ r
  = do arg_ty <- mkPDataType =<< mkPReprType el_ty
       res_ty <- mkPDataType el_ty
       arg    <- newLocalVar (fsLit "xs") arg_ty
 
       pdata_co <- mkBuiltinCo pdataTyCon
-      let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
       let co           = mkAppCo pdata_co
                        $ mkAxInstCo repr_co var_tys
 
@@ -367,7 +354,7 @@ buildFromArrPRepr vect_tc prepr_tc pdata_tc _ r
 -- | Build the 'toArrPReprs' instance for the PA class.
 --   This converts a PData of elements into the generic representation.
 buildToArrPReprs :: PAInstanceBuilder
-buildToArrPReprs vect_tc prepr_tc _ pdatas_tc r
+buildToArrPReprs vect_tc repr_co _ pdatas_tc r
  = do
     -- The argument type of the instance.
     --  eg: 'PDatas (Tree a b)'
@@ -383,7 +370,6 @@ buildToArrPReprs vect_tc prepr_tc _ pdatas_tc r
 
     -- Coersion to case between the (PRepr a) type and its instance.
     pdatas_co <- mkBuiltinCo pdatasTyCon
-    let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
     let co           = mkAppCo pdatas_co
                      . mkSymCo
                      $ mkAxInstCo repr_co ty_args
@@ -457,7 +443,7 @@ buildToArrPReprs vect_tc prepr_tc _ pdatas_tc r
 
 -- buildFromArrPReprs ---------------------------------------------------------
 buildFromArrPReprs :: PAInstanceBuilder
-buildFromArrPReprs vect_tc prepr_tc _ pdatas_tc r
+buildFromArrPReprs vect_tc repr_co _ pdatas_tc r
  = do   
     -- The argument type of the instance.
     --  eg: 'PDatas (PRepr (Tree a b))'
@@ -471,9 +457,8 @@ buildFromArrPReprs vect_tc prepr_tc _ pdatas_tc r
     -- eg: (xss :: PDatas (PRepr (Tree a b)))
     varg        <- newLocalVar (fsLit "xss") arg_ty
         
-    -- Build the coersion between PRepr and the instance type
+    -- Build the coercion between PRepr and the instance type
     pdatas_co <- mkBuiltinCo pdatasTyCon
-    let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
     let co           = mkAppCo pdatas_co
                      $ mkAxInstCo repr_co var_tys
 
index 3587452..1026e95 100644 (file)
@@ -18,6 +18,7 @@ import BuildTyCl
 import DataCon
 import TyCon
 import Type
+import FamInstEnv
 import Name
 import Util
 import MonadUtils
@@ -26,27 +27,36 @@ import Control.Monad
 
 -- buildPDataTyCon ------------------------------------------------------------
 -- | Build the PData instance tycon for a given type constructor.
-buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon
+buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
 buildPDataTyCon orig_tc vect_tc repr 
- = fixV $ \repr_tc ->
- do name' <- mkLocalisedName mkPDataTyConOcc orig_name
-    rhs   <- buildPDataTyConRhs orig_name vect_tc repr_tc repr
-    pdata <- builtin pdataTyCon
+ = fixV $ \fam_inst ->
+   do let repr_tc = dataFamInstRepTyCon fam_inst
+      name' <- mkLocalisedName mkPDataTyConOcc orig_name
+      rhs   <- buildPDataTyConRhs orig_name vect_tc repr_tc repr
+      pdata <- builtin pdataTyCon
+      buildDataFamInst name' pdata vect_tc rhs
+ where
+    orig_name = tyConName orig_tc
 
-    liftDs $ buildAlgTyCon name'
+buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst
+buildDataFamInst name' fam_tc vect_tc rhs
+ = do { axiom_name <- mkDerivedName mkInstTyCoOcc name'
+
+      ; let fam_inst = mkDataFamInst axiom_name tyvars fam_tc pat_tys rep_tc
+            ax       = famInstAxiom fam_inst
+            pat_tys  = [mkTyConApp vect_tc (mkTyVarTys tyvars)]
+            rep_tc   = buildAlgTyCon name'
                            tyvars
                            []          -- no stupid theta
                            rhs
                            rec_flag    -- FIXME: is this ok?
                            False       -- not GADT syntax
-                           NoParentTyCon
-                           (Just $ mk_fam_inst pdata vect_tc)
+                           (FamInstTyCon ax fam_tc pat_tys)
+      ; return fam_inst }
  where
-    orig_name = tyConName orig_tc
     tyvars    = tyConTyVars vect_tc
     rec_flag  = boolToRecFlag (isRecursiveTyCon vect_tc)
 
-
 buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
 buildPDataTyConRhs orig_name vect_tc repr_tc repr
  = do data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr
@@ -74,26 +84,16 @@ buildPDataDataCon orig_name vect_tc repr_tc repr
 
 -- buildPDatasTyCon -----------------------------------------------------------
 -- | Build the PDatas instance tycon for a given type constructor.
-buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon
+buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst
 buildPDatasTyCon orig_tc vect_tc repr 
- = fixV $ \repr_tc ->
- do name'       <- mkLocalisedName mkPDatasTyConOcc orig_name
-    rhs         <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr
-    pdatas      <- builtin pdatasTyCon
-
-    liftDs $ buildAlgTyCon name'
-                           tyvars
-                           []          -- no stupid theta
-                           rhs
-                           rec_flag    -- FIXME: is this ok?
-                           False       -- not GADT syntax
-                           NoParentTyCon
-                           (Just $ mk_fam_inst pdatas vect_tc)
+ = fixV $ \fam_inst ->
+   do let repr_tc = dataFamInstRepTyCon fam_inst
+      name'       <- mkLocalisedName mkPDatasTyConOcc orig_name
+      rhs         <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr
+      pdatas     <- builtin pdatasTyCon
+      buildDataFamInst name' pdatas vect_tc rhs
  where
-    orig_name = tyConName   orig_tc
-    tyvars    = tyConTyVars vect_tc
-    rec_flag  = boolToRecFlag (isRecursiveTyCon vect_tc)
-
+    orig_name = tyConName orig_tc
 
 buildPDatasTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs
 buildPDatasTyConRhs orig_name vect_tc repr_tc repr
@@ -145,7 +145,8 @@ mkSumTys repr_selX_ty mkTc repr
 
     comp_ty r = mkTc (compOrigType r)
 
-
+{-
 mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type])
 mk_fam_inst fam_tc arg_tc
   = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc])
+-}
\ No newline at end of file
index c36f179..971fd8f 100644 (file)
@@ -57,7 +57,8 @@ lookupFamInst tycon tys
   = ASSERT( isFamilyTyCon tycon )
     do { instEnv <- readGEnv global_fam_inst_env
        ; case lookupFamInstEnv instEnv tycon tys of
-           [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys)
+           [(fam_inst, rep_tys)] -> return ( dataFamInstRepTyCon fam_inst
+                                           , rep_tys)
            _other                -> 
              cantVectorise "VectMonad.lookupFamInst: not found: " 
                            (ppr $ mkTyConApp tycon tys)
index ecf0e81..30b8a0e 100644 (file)
@@ -2,6 +2,7 @@
 
 module Vectorise.Monad.Naming
   ( mkLocalisedName
+  , mkDerivedName
   , mkVectId
   , cloneVar
   , newExportedVar
@@ -35,16 +36,25 @@ import Control.Monad
 -- always an internal system name.
 --
 mkLocalisedName :: (Maybe String -> OccName -> OccName) -> Name -> VM Name
-mkLocalisedName mk_occ name = 
-  do { mod <- liftDs getModuleDs
-     ; u   <- liftDs newUnique
-     ; let occ_name = mkLocalisedOccName mod mk_occ name
-
-           new_name | isExternalName name = mkExternalName u mod occ_name (nameSrcSpan name)
-                    | otherwise           = mkSystemName   u     occ_name
-
-     ; return new_name
-     }
+mkLocalisedName mk_occ name
+  = do { mod <- liftDs getModuleDs
+       ; u   <- liftDs newUnique
+       ; let occ_name = mkLocalisedOccName mod mk_occ name
+
+             new_name | isExternalName name = mkExternalName u mod occ_name (nameSrcSpan name)
+                      | otherwise           = mkSystemName   u     occ_name
+
+       ; return new_name }
+
+mkDerivedName :: (OccName -> OccName) -> Name -> VM Name
+-- Similar to mkLocalisedName, but assumes the
+-- incoming name is from this module.  
+-- Works on External names only
+mkDerivedName mk_occ name 
+  = do { u   <- liftDs newUnique
+       ; return (mkExternalName u (nameModule name)  
+                                  (mk_occ (nameOccName name))
+                                  (nameSrcSpan name)) }
 
 -- |Produce the vectorised variant of an `Id` with the given vectorised type, while taking care that
 -- vectorised dfun ids must be dfuns again.
index 5d2213a..a6f77bb 100644 (file)
@@ -229,12 +229,15 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
            -- Build 'PRepr' and 'PData' instance type constructors and family instances for all
            -- type constructors with vectorised representations.
        ; reprs      <- mapM tyConRepr vect_tcs
-       ; repr_tcs   <- zipWith3M buildPReprTyCon  orig_tcs vect_tcs reprs
-       ; pdata_tcs  <- zipWith3M buildPDataTyCon  orig_tcs vect_tcs reprs
-       ; pdatas_tcs <- zipWith3M buildPDatasTyCon orig_tcs vect_tcs reprs
-
-       ; let inst_tcs  = repr_tcs ++ pdata_tcs ++ pdatas_tcs
-             fam_insts = map mkLocalFamInst inst_tcs
+       ; repr_fis   <- zipWith3M buildPReprTyCon  orig_tcs vect_tcs reprs
+       ; pdata_fis  <- zipWith3M buildPDataTyCon  orig_tcs vect_tcs reprs
+       ; pdatas_fis <- zipWith3M buildPDatasTyCon orig_tcs vect_tcs reprs
+
+       ; let fam_insts  = repr_fis ++ pdata_fis ++ pdatas_fis
+             repr_axs   = map famInstAxiom repr_fis
+             pdata_tcs  = famInstsRepTyCons pdata_fis
+             pdatas_tcs = famInstsRepTyCons pdatas_fis
+             
        ; updGEnv $ extendFamEnv fam_insts
 
            -- Generate workers for the vectorised data constructors, dfuns for the 'PA' instances of
@@ -262,7 +265,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
               ; dfuns <- sequence $
                            zipWith4 buildTyConPADict
                                     vect_tcs
-                                    repr_tcs
+                                    repr_axs
                                     pdata_tcs
                                     pdatas_tcs
 
@@ -272,7 +275,8 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
 
            -- Return the vectorised variants of type constructors as well as the generated instance
            -- type constructors, family instances, and dfun bindings.
-       ; return (new_tcs ++ inst_tcs ++ syn_tcs, fam_insts, binds)
+       ; return ( new_tcs ++ pdata_tcs ++ pdatas_tcs ++ syn_tcs
+                , fam_insts, binds)
        }
   where
     fst3 (a, _, _) = a
@@ -319,9 +323,9 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
 
 -- Helpers --------------------------------------------------------------------
 
-buildTyConPADict :: TyCon -> TyCon -> TyCon -> TyCon -> VM Var
-buildTyConPADict vect_tc prepr_tc pdata_tc pdatas_tc
- = tyConRepr vect_tc >>= buildPADict vect_tc prepr_tc pdata_tc pdatas_tc
+buildTyConPADict :: TyCon -> CoAxiom -> TyCon -> TyCon -> VM Var
+buildTyConPADict vect_tc prepr_ax pdata_tc pdatas_tc
+ = tyConRepr vect_tc >>= buildPADict vect_tc prepr_ax pdata_tc pdatas_tc
 
 -- Produce a custom-made worker for the data constructors of a vectorised data type.  This includes
 -- all data constructors that may be used in vetcorised code — i.e., all data constructors of data
index 88ff686..9b83044 100644 (file)
@@ -93,7 +93,7 @@ vectTyConDecl tycon name'
              gadt_flag = isGadtSyntaxTyCon tycon
 
            -- build the vectorised type constructor
-       ; liftDs $ buildAlgTyCon 
+       ; return $ buildAlgTyCon 
                     name'                   -- new name
                     (tyConTyVars tycon)     -- keep original type vars
                     []                      -- no stupid theta
@@ -101,7 +101,6 @@ vectTyConDecl tycon name'
                     rec_flag                -- whether recursive
                     gadt_flag               -- whether in GADT syntax
                     NoParentTyCon           
-                    Nothing                 -- not a family instance
        }
 
   -- some other crazy thing that we don't handle
index 0c111f4..2b47ddf 100644 (file)
@@ -36,7 +36,6 @@ import DataCon
 import MkId
 import FastString
 
-
 -- Simple Types ---------------------------------------------------------------
 
 voidType :: VM Type
index 164ebae..dfc08bc 100644 (file)
@@ -113,20 +113,17 @@ paMethod method _ ty
 --
 -- Note that @ty@ is only used for error messages
 --
-prDictOfPReprInstTyCon :: Type -> TyCon -> [Type] -> VM CoreExpr
-prDictOfPReprInstTyCon ty prepr_tc prepr_args
-  | Just rhs <- coreView (mkTyConApp prepr_tc prepr_args)
+prDictOfPReprInstTyCon :: Type -> CoAxiom -> [Type] -> VM CoreExpr
+prDictOfPReprInstTyCon _ty prepr_ax prepr_args
   = do
+      let rhs = mkAxInstRHS prepr_ax prepr_args
       dict <- prDictOfReprType' rhs
       pr_co <- mkBuiltinCo prTyCon
-      let Just arg_co = tyConFamilyCoercion_maybe prepr_tc
       let co = mkAppCo pr_co
              $ mkSymCo
-             $ mkAxInstCo arg_co prepr_args
+             $ mkAxInstCo prepr_ax prepr_args
       return $ mkCast dict co
 
-  | otherwise = cantVectorise "Invalid PRepr type instance" (ppr ty)
-
 -- |Get the PR dictionary for a type. The argument must be a representation
 -- type.
 --
index cc4be40..de65b1d 100644 (file)
@@ -962,7 +962,7 @@ filterOutChildren get_thing xs
                      Just p  -> getName p `elemNameSet` all_names
                      Nothing -> False
 
-pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
+pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.ClsInst]) -> SDoc
 pprInfo pefas (thing, fixity, insts)
   =  pprTyThingInContextLoc pefas thing
   $$ show_fixity fixity
@@ -2005,7 +2005,7 @@ showBindings = do
         let pefas = dopt Opt_PrintExplicitForalls dflags
         mb_stuff <- GHC.getInfo (getName tt)
         return $ maybe (text "") (pprTT pefas) mb_stuff
-    pprTT :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
+    pprTT :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.ClsInst]) -> SDoc
     pprTT pefas (thing, fixity, _insts) =
         pprTyThing pefas thing
         $$ show_fixity fixity