Extend Class.Class to include the TyCons of ATs

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

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index fab15fc..5ab8458 100644 (file)
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -11,16 +11,17 @@ module TyCon(
        tyConPrimRep,
 
        AlgTyConRhs(..), visibleDataCons,
        tyConPrimRep,
 
        AlgTyConRhs(..), visibleDataCons,

+       SynTyConRhs(..),

 
        isFunTyCon, isUnLiftedTyCon, isProductTyCon, 
        isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
 
        isFunTyCon, isUnLiftedTyCon, isProductTyCon, 
        isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,

-       isEnumerationTyCon, isGadtSyntaxTyCon,
+       isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,

        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
        isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
        isHiBootTyCon, isSuperKindTyCon,
         isCoercionTyCon_maybe, isCoercionTyCon,
 
        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
        isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
        isHiBootTyCon, isSuperKindTyCon,
         isCoercionTyCon_maybe, isCoercionTyCon,
 

-       tcExpandTyCon_maybe, coreExpandTyCon_maybe, stgExpandTyCon_maybe,
+       tcExpandTyCon_maybe, coreExpandTyCon_maybe,

 
        makeTyConAbstract, isAbstractTyCon,
 
 
        makeTyConAbstract, isAbstractTyCon,
 

@@ -46,7 +47,7 @@ module TyCon(
        tyConStupidTheta,
        tyConArity,
        isClassTyCon, tyConClass_maybe,
        tyConStupidTheta,
        tyConArity,
        isClassTyCon, tyConClass_maybe,

-       synTyConDefn, synTyConRhs,
+       synTyConDefn, synTyConRhs, synTyConType, synTyConResKind,

        tyConExtName,           -- External name for foreign types
 
         maybeTyConSingleCon,
        tyConExtName,           -- External name for foreign types
 
         maybeTyConSingleCon,

@@ -93,10 +94,11 @@ data TyCon
        tyConKind   :: Kind,
        tyConArity  :: Arity,
        
        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
                                        -- But not over the data constructors

-       algTcSelIds :: [Id],            -- Its record selectors (empty if none): 
+       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"
 
        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,8 +109,8 @@ data TyCon
 
        algTcRhs :: AlgTyConRhs,        -- Data constructors in here
 
 
        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)
 
        hasGenerics :: Bool,            -- True <=> generic to/from functions are available
                                        -- (in the exports of the data type's source module)

@@ -135,9 +137,7 @@ data TyCon
        tyConArity  :: Arity,
 
        tyConTyVars :: [TyVar],         -- Bound tyvars
        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.
+       synTcRhs    :: SynTyConRhs      -- Expanded type in here

     }
 
   | PrimTyCon {                        -- Primitive types; cannot be defined in Haskell
     }
 
   | PrimTyCon {                        -- Primitive types; cannot be defined in Haskell

@@ -183,6 +183,9 @@ data AlgTyConRhs
                        -- Used when we export a data type abstractly into
                        -- an hi file
 
                        -- 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
   | DataTyCon {
        data_cons :: [DataCon],
                        -- The constructors; can be empty if the user declares

@@ -199,8 +202,9 @@ data AlgTyConRhs
                                --  = the representation type of the tycon
                                -- The free tyvars of this type are the tyConTyVars
       
                                --  = the representation type of the tycon
                                -- The free tyvars of this type are the tyConTyVars
       

-        nt_co :: TyCon,                -- The coercion used to create the newtype
+        nt_co :: Maybe TyCon,   -- The coercion used to create the newtype

                                 -- from the representation
                                 -- from the representation

+                                -- optional for non-recursive newtypes

                                -- See Note [Newtype coercions]
 
        nt_etad_rhs :: ([TyVar], Type) ,
                                -- See Note [Newtype coercions]
 
        nt_etad_rhs :: ([TyVar], Type) ,

@@ -226,8 +230,16 @@ data AlgTyConRhs
 
 visibleDataCons :: AlgTyConRhs -> [DataCon]
 visibleDataCons AbstractTyCon                = []
 
 visibleDataCons :: AlgTyConRhs -> [DataCon]
 visibleDataCons AbstractTyCon                = []

+visibleDataCons OpenDataTyCon                = []
+visibleDataCons OpenNewTyCon                 = []

 visibleDataCons (DataTyCon{ data_cons = cs }) = cs
 visibleDataCons (NewTyCon{ data_con = c })    = [c]
 visibleDataCons (DataTyCon{ data_cons = cs }) = cs
 visibleDataCons (NewTyCon{ data_con = c })    = [c]

+
+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]
 \end{code}
 
 Note [Newtype coercions]

@@ -237,15 +249,23 @@ 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,
 
 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
+
+   newtype S a = MkT [a]

 
 

-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.
+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
 
 In the paper we'd write

-       axiom CoT : (forall t. [t]) :=: (forall t. T t)
+       axiom CoT : (forall t. T t) :=: (forall t. [t])

 and then when we used CoT at a particular type, s, we'd say
        CoT @ s
 which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s])
 and then when we used CoT at a particular type, s, we'd say
        CoT @ s
 which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s])

@@ -253,10 +273,10 @@ which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s])
 But in GHC we instead make CoT into a new piece of type syntax
 (like instCoercionTyCon, symCoercionTyCon etc), which must always
 be saturated, but which encodes as
 But in GHC we instead make CoT into a new piece of type syntax
 (like instCoercionTyCon, symCoercionTyCon etc), which must always
 be saturated, but which encodes as

-       TyConAp CoT [s]
+       TyConApp CoT [s]

 In the vocabulary of the paper it's as if we had axiom declarations
 like
 In the vocabulary of the paper it's as if we had axiom declarations
 like

-       axiom CoT t : ([t] :=: T t)
+       axiom CoT t :  T t :=: [t]

 
 Note [Newtype eta]
 ~~~~~~~~~~~~~~~~~~
 
 Note [Newtype eta]
 ~~~~~~~~~~~~~~~~~~

@@ -498,7 +518,9 @@ isDataTyCon :: TyCon -> Bool
 --               unboxed tuples
 isDataTyCon tc@(AlgTyCon {algTcRhs = rhs})  
   = case rhs of
 --               unboxed tuples
 isDataTyCon tc@(AlgTyCon {algTcRhs = rhs})  
   = case rhs of

+        OpenDataTyCon -> True

        DataTyCon {}  -> True
        DataTyCon {}  -> True

+       OpenNewTyCon  -> False

        NewTyCon {}   -> False
        AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc)
 
        NewTyCon {}   -> False
        AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc)
 

@@ -514,9 +536,10 @@ isProductTyCon :: TyCon -> Bool
 --     has *one* constructor, 
 --     is *not* existential
 -- but
 --     has *one* constructor, 
 --     is *not* existential
 -- but

---     may be  DataType or NewType, 
+--     may be  DataType, NewType

 --     may be  unboxed or not, 
 --     may be  recursive or not
 --     may be  unboxed or not, 
 --     may be  recursive or not

+-- 

 isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of
                                    DataTyCon{ data_cons = [data_con] } 
                                                -> isVanillaDataCon data_con
 isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of
                                    DataTyCon{ data_cons = [data_con] } 
                                                -> isVanillaDataCon data_con

@@ -537,6 +560,12 @@ isEnumerationTyCon :: TyCon -> Bool
 isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon { is_enum = res }}) = res
 isEnumerationTyCon other                                              = False
 
 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
+

 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
 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

@@ -600,30 +629,22 @@ tcExpandTyCon_maybe, coreExpandTyCon_maybe
                  [Type])               -- Leftover args
 
 -- For the *typechecker* view, we expand synonyms only
                  [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
 
 ---------------
 -- For the *Core* view, we expand synonyms only as well
    = expand tvs rhs tys
 tcExpandTyCon_maybe other_tycon tys = Nothing
 
 ---------------
 -- For the *Core* view, we expand synonyms only as well

-{-
+

 coreExpandTyCon_maybe (AlgTyCon {algTcRec = NonRecursive,      -- Not recursive
 coreExpandTyCon_maybe (AlgTyCon {algTcRec = NonRecursive,      -- Not recursive

-         algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs }}) tys
+         algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs, nt_co = Nothing }}) tys

    = case etad_rhs of  -- Don't do this in the pattern match, lest we accidentally
                        -- match the etad_rhs of a *recursive* newtype
        (tvs,rhs) -> expand tvs rhs tys
    = case etad_rhs of  -- Don't do this in the pattern match, lest we accidentally
                        -- match the etad_rhs of a *recursive* newtype
        (tvs,rhs) -> expand tvs rhs tys

--}
-coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys

 
 

----------------
--- For the *STG* view, we expand synonyms *and* non-recursive newtypes
-stgExpandTyCon_maybe (AlgTyCon {algTcRec = NonRecursive,       -- Not recursive
-         algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs }}) tys
-   = case etad_rhs of  -- Don't do this in the pattern match, lest we accidentally
-                       -- match the etad_rhs of a *recursive* newtype
-       (tvs,rhs) -> expand tvs rhs tys
+coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys

 
 

-stgExpandTyCon_maybe tycon tys = coreExpandTyCon_maybe tycon tys

 
 ----------------
 expand :: [TyVar] -> Type                      -- Template
 
 ----------------
 expand :: [TyVar] -> Type                      -- Template

@@ -682,7 +703,7 @@ newTyConRep :: TyCon -> ([TyVar], Type)
 newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) = (tvs, rep)
 newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon)
 
 newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) = (tvs, rep)
 newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon)
 

-newTyConCo :: TyCon -> TyCon
+newTyConCo :: TyCon -> Maybe TyCon

 newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }}) = co
 newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon)
 
 newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }}) = co
 newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon)
 

@@ -700,11 +721,22 @@ tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon)
 
 \begin{code}
 synTyConDefn :: TyCon -> ([TyVar], Type)
 
 \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)
 
 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}
 \end{code}
 
 \begin{code}