Check category of type instances and some newtype family fixes
[ghc-hetmet.git] / compiler / types / TyCon.lhs
index 785d085..d536f59 100644 (file)
@@ -10,11 +10,13 @@ module TyCon(
        PrimRep(..),
        tyConPrimRep,
 
-       AlgTyConRhs(..), visibleDataCons,
+       AlgTyConRhs(..), visibleDataCons, AlgTyConParent(..),
+       SynTyConRhs(..),
 
        isFunTyCon, isUnLiftedTyCon, isProductTyCon, 
        isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
-       isEnumerationTyCon, isGadtSyntaxTyCon,
+       isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
+       assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss,
        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
        isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
        isHiBootTyCon, isSuperKindTyCon,
@@ -46,7 +48,8 @@ module TyCon(
        tyConStupidTheta,
        tyConArity,
        isClassTyCon, tyConClass_maybe,
-       synTyConDefn, synTyConRhs,
+       isFamInstTyCon, tyConFamInst_maybe, tyConFamilyCoercion_maybe,
+       synTyConDefn, synTyConRhs, synTyConType, synTyConResKind,
        tyConExtName,           -- External name for foreign types
 
         maybeTyConSingleCon,
@@ -65,6 +68,7 @@ import Class          ( Class )
 import BasicTypes      ( Arity, RecFlag(..), Boxity(..), isBoxed )
 import Name            ( Name, nameUnique, NamedThing(getName) )
 import PrelNames       ( Unique, Uniquable(..) )
+import Maybe           ( isJust )
 import Maybes          ( orElse )
 import Outputable
 import FastString
@@ -92,11 +96,20 @@ data TyCon
        tyConName   :: Name,
        tyConKind   :: Kind,
        tyConArity  :: Arity,
-       
-       tyConTyVars :: [TyVar],         -- Scopes over (a) the [PredType] in AlgTyConRhs.DataTyCon
-                                       --             (b) the cached types in AlgTyConRhs.NewTyCon
+
+       tyConTyVars :: [TyVar],         -- Scopes over (a) the algTcStupidTheta
+                                       --             (b) the cached types in
+                                       --                 algTyConRhs.NewTyCon
                                        -- But not over the data constructors
-       algTcSelIds :: [Id],            -- Its record selectors (empty if none): 
+
+        tyConArgPoss :: Maybe [Int],    -- for associated families: for each
+                                       -- tyvar in the AT decl, gives the
+                                       -- position of that tyvar in the class
+                                       -- argument list (starting from 0).
+                                       -- NB: Length is less than tyConArity
+                                       --     if higher kind signature.
+       
+       algTcSelIds :: [Id],            -- Its record selectors (empty if none)
 
        algTcGadtSyntax  :: Bool,       -- True <=> the data type was declared using GADT syntax
                                        -- That doesn't mean it's a true GADT; only that the "where"
@@ -107,14 +120,15 @@ data TyCon
 
        algTcRhs :: AlgTyConRhs,        -- Data constructors in here
 
-       algTcRec :: RecFlag,            -- Tells whether the data type is part of 
-                                       -- a mutually-recursive group or not
+       algTcRec :: RecFlag,            -- Tells whether the data type is part
+                                       -- of a mutually-recursive group or not
 
        hasGenerics :: Bool,            -- True <=> generic to/from functions are available
                                        -- (in the exports of the data type's source module)
 
-       algTcClass :: Maybe Class
-               -- Just cl if this tycon came from a class declaration
+       algTcParent :: AlgTyConParent   -- Gives the class or family tycon for
+                                       -- derived tycons representing classes
+                                       -- or family instances, respectively.
     }
 
   | TupleTyCon {
@@ -129,15 +143,21 @@ data TyCon
     }
 
   | SynTyCon {
-       tyConUnique :: Unique,
-       tyConName   :: Name,
-       tyConKind   :: Kind,
-       tyConArity  :: Arity,
-
-       tyConTyVars :: [TyVar],         -- Bound tyvars
-       synTcRhs    :: Type             -- Right-hand side, mentioning these type vars.
-                                       -- Acts as a template for the expansion when
-                                       -- the tycon is applied to some types.
+       tyConUnique  :: Unique,
+       tyConName    :: Name,
+       tyConKind    :: Kind,
+       tyConArity   :: Arity,
+
+       tyConTyVars  :: [TyVar],        -- Bound tyvars
+
+        tyConArgPoss :: Maybe [Int],    -- for associated families: for each
+                                       -- tyvar in the AT decl, gives the
+                                       -- position of that tyvar in the class
+                                       -- argument list (starting from 0).
+                                       -- NB: Length is less than tyConArity
+                                       --     if higher kind signature.
+       
+       synTcRhs     :: SynTyConRhs     -- Expanded type in here
     }
 
   | PrimTyCon {                        -- Primitive types; cannot be defined in Haskell
@@ -183,6 +203,9 @@ data AlgTyConRhs
                        -- Used when we export a data type abstractly into
                        -- an hi file
 
+  | OpenDataTyCon       -- data family        (further instances can appear
+  | OpenNewTyCon        -- newtype family      at any time)
+
   | DataTyCon {
        data_cons :: [DataCon],
                        -- The constructors; can be empty if the user declares
@@ -227,8 +250,35 @@ data AlgTyConRhs
 
 visibleDataCons :: AlgTyConRhs -> [DataCon]
 visibleDataCons AbstractTyCon                = []
+visibleDataCons OpenDataTyCon                = []
+visibleDataCons OpenNewTyCon                 = []
 visibleDataCons (DataTyCon{ data_cons = cs }) = cs
 visibleDataCons (NewTyCon{ data_con = c })    = [c]
+
+-- 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
+  | SynonymTyCon Type   -- Mentioning head type vars.  Acts as a template for
+                       --  the expansion when the tycon is applied to some
+                       --  types.  
 \end{code}
 
 Note [Newtype coercions]
@@ -238,12 +288,20 @@ 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,
 
-   newtype T a = MkT [a]
+   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 CoercionTyCon, 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
+ending with the same type variables as the left hand side, we
+"eta-contract" the coercion.  So if we had
 
-the NewTyCon for T will contain nt_co = CoT where CoT t : T t :=: [t].
-This TyCon is a CoercionTyCon, 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 k.
+   newtype S a = MkT [a]
+
+then we would generate the arity 0 coercion CoS : S :=: [].  The
+primary reason we do this is to make newtype deriving cleaner.
 
 In the paper we'd write
        axiom CoT : (forall t. T t) :=: (forall t. [t])
@@ -352,38 +410,25 @@ mkFunTyCon name kind
 -- This is the making of a TyCon. Just the same as the old mkAlgTyCon,
 -- but now you also have to pass in the generic information about the type
 -- constructor - you can get hold of it easily (see Generics module)
-mkAlgTyCon name kind tyvars stupid rhs sel_ids is_rec gen_info gadt_syn
+mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn
   = AlgTyCon { 
        tyConName        = name,
        tyConUnique      = nameUnique name,
        tyConKind        = kind,
        tyConArity       = length tyvars,
        tyConTyVars      = tyvars,
+       tyConArgPoss     = Nothing,
        algTcStupidTheta = stupid,
        algTcRhs         = rhs,
        algTcSelIds      = sel_ids,
-       algTcClass       = Nothing,
+       algTcParent      = parent,
        algTcRec         = is_rec,
        algTcGadtSyntax  = gadt_syn,
        hasGenerics = gen_info
     }
 
-mkClassTyCon name kind tyvars rhs clas is_rec
-  = AlgTyCon { 
-       tyConName        = name,
-       tyConUnique      = nameUnique name,
-       tyConKind        = kind,
-       tyConArity       = length tyvars,
-       tyConTyVars      = tyvars,
-       algTcStupidTheta = [],
-       algTcRhs         = rhs,
-       algTcSelIds      = [],
-       algTcClass       = Just clas,
-       algTcRec         = is_rec,
-       algTcGadtSyntax  = False,       -- Doesn't really matter
-       hasGenerics = False
-    }
-
+mkClassTyCon name kind tyvars rhs clas is_rec =
+  mkAlgTyCon name kind tyvars [] rhs [] (ClassTyCon clas) is_rec False False
 
 mkTupleTyCon name kind arity tyvars con boxed gen_info
   = TupleTyCon {
@@ -442,6 +487,7 @@ mkSynTyCon name kind tyvars rhs
        tyConKind = kind,
        tyConArity = length tyvars,
        tyConTyVars = tyvars,
+       tyConArgPoss = Nothing,
        synTcRhs = rhs
     }
 
@@ -499,16 +545,20 @@ isDataTyCon :: TyCon -> Bool
 --               unboxed tuples
 isDataTyCon tc@(AlgTyCon {algTcRhs = rhs})  
   = case rhs of
+        OpenDataTyCon -> True
        DataTyCon {}  -> True
+       OpenNewTyCon  -> False
        NewTyCon {}   -> False
        AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc)
-
 isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
 isDataTyCon other = False
 
 isNewTyCon :: TyCon -> Bool
-isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True 
-isNewTyCon other                              = False
+isNewTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of
+                                          OpenNewTyCon -> True
+                                          NewTyCon {}  -> True
+                                          _            -> False
+isNewTyCon other                       = False
 
 isProductTyCon :: TyCon -> Bool
 -- A "product" tycon
@@ -539,6 +589,25 @@ isEnumerationTyCon :: TyCon -> Bool
 isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon { is_enum = res }}) = res
 isEnumerationTyCon other                                              = False
 
+isOpenTyCon :: TyCon -> Bool
+isOpenTyCon (SynTyCon {synTcRhs = OpenSynTyCon _}) = True
+isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True
+isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon  }) = True
+isOpenTyCon _                                     = False
+
+assocTyConArgPoss_maybe :: TyCon -> Maybe [Int]
+assocTyConArgPoss_maybe (AlgTyCon { tyConArgPoss = poss }) = poss
+assocTyConArgPoss_maybe (SynTyCon { tyConArgPoss = poss }) = poss
+assocTyConArgPoss_maybe _                                  = Nothing
+
+isTyConAssoc :: TyCon -> Bool
+isTyConAssoc = isJust . assocTyConArgPoss_maybe
+
+setTyConArgPoss :: TyCon -> [Int] -> TyCon
+setTyConArgPoss tc@(AlgTyCon {}) poss = tc { tyConArgPoss = Just poss }
+setTyConArgPoss tc@(SynTyCon {}) poss = tc { tyConArgPoss = Just poss }
+setTyConArgPoss tc _ = pprPanic "setTyConArgPoss" (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
@@ -602,7 +671,8 @@ tcExpandTyCon_maybe, coreExpandTyCon_maybe
                  [Type])               -- Leftover args
 
 -- For the *typechecker* view, we expand synonyms only
-tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, synTcRhs = rhs }) tys
+tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, 
+                              synTcRhs = SynonymTyCon rhs }) tys
    = expand tvs rhs tys
 tcExpandTyCon_maybe other_tycon tys = Nothing
 
@@ -649,9 +719,11 @@ tyConDataCons_maybe (TupleTyCon {dataCon = con})                      = Just [con]
 tyConDataCons_maybe other                                                 = Nothing
 
 tyConFamilySize  :: TyCon -> Int
-tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon { data_cons = cons }}) = length cons
-tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon {}}) = 1
-tyConFamilySize (TupleTyCon {})                            = 1
+tyConFamilySize (AlgTyCon   {algTcRhs = DataTyCon {data_cons = cons}}) = 
+  length cons
+tyConFamilySize (AlgTyCon   {algTcRhs = NewTyCon {}})                  = 1
+tyConFamilySize (AlgTyCon   {algTcRhs = OpenDataTyCon})                = 0
+tyConFamilySize (TupleTyCon {})                                               = 1
 #ifdef DEBUG
 tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other)
 #endif
@@ -676,7 +748,10 @@ newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }})
 newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon)
 
 newTyConCo :: TyCon -> Maybe TyCon
-newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }}) = co
+newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }})
+  = co
+newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = OpenNewTyCon})
+  = Nothing
 newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon)
 
 tyConPrimRep :: TyCon -> PrimRep
@@ -693,11 +768,22 @@ tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon)
 
 \begin{code}
 synTyConDefn :: TyCon -> ([TyVar], Type)
-synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = ty}) = (tyvars,ty)
+synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty}) 
+  = (tyvars, ty)
 synTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon)
 
-synTyConRhs :: TyCon -> Type
-synTyConRhs tc = synTcRhs tc
+synTyConRhs :: TyCon -> SynTyConRhs
+synTyConRhs (SynTyCon {synTcRhs = rhs}) = rhs
+synTyConRhs tc                         = pprPanic "synTyConRhs" (ppr tc)
+
+synTyConType :: TyCon -> Type
+synTyConType tc = case synTcRhs tc of
+                   SynonymTyCon t -> t
+                   _              -> pprPanic "synTyConType" (ppr tc)
+
+synTyConResKind :: TyCon -> Kind
+synTyConResKind (SynTyCon {synTcRhs = OpenSynTyCon kind}) = kind
+synTyConResKind tycon  = pprPanic "synTyConResKind" (ppr tycon)
 \end{code}
 
 \begin{code}
@@ -713,12 +799,28 @@ maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $ ppr
 
 \begin{code}
 isClassTyCon :: TyCon -> Bool
-isClassTyCon (AlgTyCon {algTcClass = Just _}) = True
-isClassTyCon other_tycon                        = False
+isClassTyCon (AlgTyCon {algTcParent = ClassTyCon _}) = True
+isClassTyCon other_tycon                            = False
 
 tyConClass_maybe :: TyCon -> Maybe Class
-tyConClass_maybe (AlgTyCon {algTcClass = maybe_clas}) = maybe_clas
-tyConClass_maybe ther_tycon                             = Nothing
+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
+
+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}