Check that AT instance is in a class

[ghc-hetmet.git] / compiler / types / TyCon.lhs

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 7fcc52b..40cfa06 100644 (file)
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -15,7 +15,8 @@ module TyCon(
 
        isFunTyCon, isUnLiftedTyCon, isProductTyCon, 
        isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
-       isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
+       isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, isAssocTyCon,
+       makeTyConAssoc,
        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
        isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
        isHiBootTyCon, isSuperKindTyCon,
@@ -47,7 +48,7 @@ module TyCon(
        tyConStupidTheta,
        tyConArity,
        isClassTyCon, tyConClass_maybe,
-       isFamInstTyCon, tyConFamily_maybe,
+       isFamInstTyCon, tyConFamInst_maybe, tyConFamilyCoercion_maybe,
        synTyConDefn, synTyConRhs, synTyConType, synTyConResKind,
        tyConExtName,           -- External name for foreign types
 
@@ -94,11 +95,14 @@ data TyCon
        tyConName   :: Name,
        tyConKind   :: Kind,
        tyConArity  :: Arity,
-       
+
        tyConTyVars :: [TyVar],         -- Scopes over (a) the algTcStupidTheta
                                        --             (b) the cached types in
                                        --                 algTyConRhs.NewTyCon
                                        -- But not over the data constructors
+
+        tyConIsAssoc :: Bool,           -- for families: declared in a class?
+       
        algTcSelIds :: [Id],            -- Its record selectors (empty if none)
 
        algTcGadtSyntax  :: Bool,       -- True <=> the data type was declared using GADT syntax
@@ -133,13 +137,14 @@ data TyCon
     }
 
   | SynTyCon {
-       tyConUnique :: Unique,
-       tyConName   :: Name,
-       tyConKind   :: Kind,
-       tyConArity  :: Arity,
-
-       tyConTyVars :: [TyVar],         -- Bound tyvars
-       synTcRhs    :: SynTyConRhs      -- Expanded type in here
+       tyConUnique  :: Unique,
+       tyConName    :: Name,
+       tyConKind    :: Kind,
+       tyConArity   :: Arity,
+
+       tyConTyVars  :: [TyVar],        -- Bound tyvars
+        tyConIsAssoc :: Bool,           -- for families: declared in a class?
+       synTcRhs     :: SynTyConRhs     -- Expanded type in here
     }
 
   | PrimTyCon {                        -- Primitive types; cannot be defined in Haskell
@@ -237,9 +242,24 @@ visibleDataCons OpenNewTyCon                     = []
 visibleDataCons (DataTyCon{ data_cons = cs }) = cs
 visibleDataCons (NewTyCon{ data_con = c })    = [c]
 
-data AlgTyConParent = NoParentTyCon            -- ordinary data type
-                   | ClassTyCon    Class       -- class dictionary
-                   | FamilyTyCon   TyCon       -- instance of type family
+-- Both type classes as well as data/newtype family instances imply implicit
+-- type constructors.  These implicit type constructors refer to their parent
+-- structure (ie, the class or family from which they derive) using a type of
+-- the following form.
+--
+data AlgTyConParent = -- An ordinary type constructor has no parent.
+                     NoParentTyCon
+
+                     -- Type constructors representing a class dictionary.
+                   | ClassTyCon    Class       
+
+                     -- Type constructors representing an instances of a type
+                     -- family.
+                   | FamilyTyCon   TyCon       -- the type family
+                                   [Type]      -- instance types
+                                   TyCon       -- a *coercion* identifying
+                                               -- the representation type
+                                               -- with the type instance
 
 data SynTyConRhs
   = OpenSynTyCon Kind  -- Type family: *result* kind given
@@ -384,6 +404,7 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn
        tyConKind        = kind,
        tyConArity       = length tyvars,
        tyConTyVars      = tyvars,
+       tyConIsAssoc     = False,
        algTcStupidTheta = stupid,
        algTcRhs         = rhs,
        algTcSelIds      = sel_ids,
@@ -453,6 +474,7 @@ mkSynTyCon name kind tyvars rhs
        tyConKind = kind,
        tyConArity = length tyvars,
        tyConTyVars = tyvars,
+       tyConIsAssoc = False,
        synTcRhs = rhs
     }
 
@@ -558,6 +580,16 @@ isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True
 isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon  }) = True
 isOpenTyCon _                                     = False
 
+isAssocTyCon :: TyCon -> Bool
+isAssocTyCon (AlgTyCon { tyConIsAssoc = isAssoc }) = isAssoc
+isAssocTyCon (SynTyCon { tyConIsAssoc = isAssoc }) = isAssoc
+isAssocTyCon _                                     = False
+
+makeTyConAssoc :: TyCon -> TyCon
+makeTyConAssoc tc@(AlgTyCon {}) = tc { tyConIsAssoc = True }
+makeTyConAssoc tc@(SynTyCon {}) = tc { tyConIsAssoc = True }
+makeTyConAssoc tc = pprPanic "makeTyConAssoc" (ppr tc)
+
 isTupleTyCon :: TyCon -> Bool
 -- The unit tycon didn't used to be classed as a tuple tycon
 -- but I thought that was silly so I've undone it
@@ -754,12 +786,20 @@ tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas
 tyConClass_maybe ther_tycon                                = Nothing
 
 isFamInstTyCon :: TyCon -> Bool
-isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _}) = True
-isFamInstTyCon other_tycon                             = False
-
-tyConFamily_maybe :: TyCon -> Maybe TyCon
-tyConFamily_maybe (AlgTyCon {algTcParent = FamilyTyCon fam}) = Just fam
-tyConFamily_maybe ther_tycon                                = Nothing
+isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _}) = True
+isFamInstTyCon other_tycon                                 = False
+
+tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])
+tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) = 
+  Just (fam, instTys)
+tyConFamInst_maybe ther_tycon                                          = 
+  Nothing
+
+tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon
+tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) = 
+  Just coe
+tyConFamilyCoercion_maybe ther_tycon                                    = 
+  Nothing
 \end{code}