Extended TyCon and friends to represent family declarations

Mon Sep 18 18:50:35 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Extended TyCon and friends to represent family declarations
  Tue Aug 15 16:52:31 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Extended TyCon and friends to represent family declarations

diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 13be049..a11b351 100644 (file)
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -913,11 +913,12 @@ instance Binary IfaceDecl where
            put_ bh a6
            put_ bh a7
 
            put_ bh a6
            put_ bh a7
 

-    put_ bh (IfaceSyn aq ar as) = do
+    put_ bh (IfaceSyn aq ar as at) = do

            putByte bh 3
            put_ bh aq
            put_ bh ar
            put_ bh as
            putByte bh 3
            put_ bh aq
            put_ bh ar
            put_ bh as

+           put_ bh at

     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6) = do
            putByte bh 4
            put_ bh a1
     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6) = do
            putByte bh 4
            put_ bh a1

@@ -947,7 +948,8 @@ instance Binary IfaceDecl where
                    aq <- get bh
                    ar <- get bh
                    as <- get bh
                    aq <- get bh
                    ar <- get bh
                    as <- get bh

-                   return (IfaceSyn aq ar as)
+                   at <- get bh
+                   return (IfaceSyn aq ar as at)

              _ -> do
                    a1 <- get bh
                    a2 <- get bh
              _ -> do
                    a1 <- get bh
                    a2 <- get bh

@@ -983,15 +985,19 @@ instance Binary OverlapFlag where
 
 instance Binary IfaceConDecls where
     put_ bh IfAbstractTyCon = putByte bh 0
 
 instance Binary IfaceConDecls where
     put_ bh IfAbstractTyCon = putByte bh 0

-    put_ bh (IfDataTyCon cs) = do { putByte bh 1
+    put_ bh IfOpenDataTyCon = putByte bh 1
+    put_ bh IfOpenNewTyCon = putByte bh 2
+    put_ bh (IfDataTyCon cs) = do { putByte bh 3

                                  ; put_ bh cs }
                                  ; put_ bh cs }

-    put_ bh (IfNewTyCon c)  = do { putByte bh 2
+    put_ bh (IfNewTyCon c)  = do { putByte bh 4

                                  ; put_ bh c }
     get bh = do
            h <- getByte bh
            case h of
              0 -> return IfAbstractTyCon
                                  ; put_ bh c }
     get bh = do
            h <- getByte bh
            case h of
              0 -> return IfAbstractTyCon

-             1 -> do cs <- get bh
+             1 -> return IfOpenDataTyCon
+             2 -> return IfOpenNewTyCon
+             3 -> do cs <- get bh

                      return (IfDataTyCon cs)
              _ -> do aa <- get bh
                      return (IfNewTyCon aa)
                      return (IfDataTyCon cs)
              _ -> do aa <- get bh
                      return (IfNewTyCon aa)

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index d1118c0..c669daf 100644 (file)
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -6,7 +6,8 @@
 module BuildTyCl (
        buildSynTyCon, buildAlgTyCon, buildDataCon,
        buildClass,
 module BuildTyCl (
        buildSynTyCon, buildAlgTyCon, buildDataCon,
        buildClass,

-       mkAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs
+       mkAbstractTyConRhs, mkOpenDataTyConRhs, mkOpenNewTyConRhs,
+       mkNewTyConRhs, mkDataTyConRhs 

     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"

@@ -26,14 +27,16 @@ import OccName              ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc,
                          mkClassDataConOcc, mkSuperDictSelOcc, mkNewTyCoOcc )
 import MkId            ( mkDataConIds, mkRecordSelId, mkDictSelId )
 import Class           ( mkClass, Class( classTyCon), FunDep, DefMeth(..) )
                          mkClassDataConOcc, mkSuperDictSelOcc, mkNewTyCoOcc )
 import MkId            ( mkDataConIds, mkRecordSelId, mkDictSelId )
 import Class           ( mkClass, Class( classTyCon), FunDep, DefMeth(..) )

-import TyCon           ( mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta,
-                         tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ),
-                         isRecursiveTyCon, tyConArity,
-                         AlgTyConRhs(..), newTyConRhs )
+import TyCon           ( mkSynTyCon, mkAlgTyCon, visibleDataCons,
+                         tyConStupidTheta, tyConDataCons, isNewTyCon,
+                         mkClassTyCon, TyCon( tyConTyVars ),
+                         isRecursiveTyCon, tyConArity, AlgTyConRhs(..),
+                         SynTyConRhs(..), newTyConRhs )

 import Type            ( mkArrowKinds, liftedTypeKind, typeKind, 
                          tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
 import Type            ( mkArrowKinds, liftedTypeKind, typeKind, 
                          tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,

-                         splitTyConApp_maybe, splitAppTy_maybe, getTyVar_maybe,
-                         mkPredTys, mkTyVarTys, ThetaType, Type, 
+                         splitTyConApp_maybe, splitAppTy_maybe,
+                         getTyVar_maybe, 
+                         mkPredTys, mkTyVarTys, ThetaType, Type, Kind,

                          substTyWith, zipTopTvSubst, substTheta, mkForAllTys,
                           mkTyConApp, mkTyVarTy )
 import Coercion         ( mkNewTypeCoercion )
                          substTyWith, zipTopTvSubst, substTheta, mkForAllTys,
                           mkTyConApp, mkTyVarTy )
 import Coercion         ( mkNewTypeCoercion )

@@ -45,8 +48,13 @@ import List          ( nub )
 
 \begin{code}
 ------------------------------------------------------
 
 \begin{code}
 ------------------------------------------------------

-buildSynTyCon name tvs rhs_ty
-  = mkSynTyCon name kind tvs rhs_ty
+buildSynTyCon :: Name -> [TyVar] -> SynTyConRhs -> TyCon
+buildSynTyCon name tvs rhs@(OpenSynTyCon rhs_ki)
+  = mkSynTyCon name kind tvs rhs
+  where
+    kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
+buildSynTyCon name tvs rhs@(SynonymTyCon rhs_ty)
+  = mkSynTyCon name kind tvs rhs

   where
     kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
 
   where
     kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
 

@@ -72,6 +80,12 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
 mkAbstractTyConRhs :: AlgTyConRhs
 mkAbstractTyConRhs = AbstractTyCon
 
 mkAbstractTyConRhs :: AlgTyConRhs
 mkAbstractTyConRhs = AbstractTyCon
 

+mkOpenDataTyConRhs :: AlgTyConRhs
+mkOpenDataTyConRhs = OpenDataTyCon
+
+mkOpenNewTyConRhs :: AlgTyConRhs
+mkOpenNewTyConRhs = OpenNewTyCon
+

 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
 mkDataTyConRhs cons
   = DataTyCon { data_cons = cons, is_enum = all isNullarySrcDataCon cons }
 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
 mkDataTyConRhs cons
   = DataTyCon { data_cons = cons, is_enum = all isNullarySrcDataCon cons }

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 330a6fc..0d649fb 100644 (file)
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -81,9 +81,12 @@ data IfaceDecl
                                                -- imported modules may have been compiled with
                                                -- different flags to the current compilation unit
 
                                                -- imported modules may have been compiled with
                                                -- different flags to the current compilation unit
 

-  | IfaceSyn  {        ifName   :: OccName,            -- Type constructor
-               ifTyVars :: [IfaceTvBndr],      -- Type variables
-               ifSynRhs :: IfaceType           -- synonym expansion
+  | IfaceSyn  {        ifName    :: OccName,           -- Type constructor
+               ifTyVars  :: [IfaceTvBndr],     -- Type variables
+               ifOpenSyn :: Bool,              -- Is an open family?
+               ifSynRhs  :: IfaceType          -- Type for an ordinary
+                                               -- synonym and kind for an
+                                               -- open family

     }
 
   | IfaceClass { ifCtxt    :: IfaceContext,    -- Context...
     }
 
   | IfaceClass { ifCtxt    :: IfaceContext,    -- Context...

@@ -104,11 +107,15 @@ data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
 
 data IfaceConDecls
   = IfAbstractTyCon            -- No info
 
 data IfaceConDecls
   = IfAbstractTyCon            -- No info

+  | IfOpenDataTyCon            -- Open data family
+  | IfOpenNewTyCon             -- Open newtype family

   | IfDataTyCon [IfaceConDecl] -- data type decls
   | IfNewTyCon  IfaceConDecl   -- newtype decls
 
 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
 visibleIfConDecls IfAbstractTyCon  = []
   | IfDataTyCon [IfaceConDecl] -- data type decls
   | IfNewTyCon  IfaceConDecl   -- newtype decls
 
 visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
 visibleIfConDecls IfAbstractTyCon  = []

+visibleIfConDecls IfOpenDataTyCon  = []
+visibleIfConDecls IfOpenNewTyCon   = []

 visibleIfConDecls (IfDataTyCon cs) = cs
 visibleIfConDecls (IfNewTyCon c)   = [c]
 
 visibleIfConDecls (IfDataTyCon cs) = cs
 visibleIfConDecls (IfNewTyCon c)   = [c]
 

@@ -229,10 +236,16 @@ pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
 pprIfaceDecl (IfaceForeign {ifName = tycon})
   = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
 
 pprIfaceDecl (IfaceForeign {ifName = tycon})
   = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
 

-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty})
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, 
+                       ifOpenSyn = False, ifSynRhs = mono_ty})

   = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
        4 (equals <+> ppr mono_ty)
 
   = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
        4 (equals <+> ppr mono_ty)
 

+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, 
+                       ifOpenSyn = True, ifSynRhs = mono_ty})
+  = hang (ptext SLIT("type family") <+> pprIfaceDeclHead [] tycon tyvars)
+       4 (dcolon <+> ppr mono_ty)
+

 pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
                         ifTyVars = tyvars, ifCons = condecls, 
                         ifRec = isrec})
 pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
                         ifTyVars = tyvars, ifCons = condecls, 
                         ifRec = isrec})

@@ -241,8 +254,10 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
   where
     pp_nd = case condecls of
                IfAbstractTyCon -> ptext SLIT("data")
   where
     pp_nd = case condecls of
                IfAbstractTyCon -> ptext SLIT("data")

+               IfOpenDataTyCon -> ptext SLIT("data family")

                IfDataTyCon _   -> ptext SLIT("data")
                IfNewTyCon _    -> ptext SLIT("newtype")
                IfDataTyCon _   -> ptext SLIT("data")
                IfNewTyCon _    -> ptext SLIT("newtype")

+               IfOpenNewTyCon  -> ptext SLIT("newtype family")

 
 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, 
                          ifFDs = fds, ifSigs = sigs, ifRec = isrec})
 
 pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, 
                          ifFDs = fds, ifSigs = sigs, ifRec = isrec})

@@ -262,7 +277,9 @@ pprIfaceDeclHead context thing tyvars
   = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars]
 
 pp_condecls tc IfAbstractTyCon  = ptext SLIT("{- abstract -}")
   = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars]
 
 pp_condecls tc IfAbstractTyCon  = ptext SLIT("{- abstract -}")

+pp_condecls tc IfOpenNewTyCon   = empty

 pp_condecls tc (IfNewTyCon c)   = equals <+> pprIfaceConDecl tc c
 pp_condecls tc (IfNewTyCon c)   = equals <+> pprIfaceConDecl tc c

+pp_condecls tc IfOpenDataTyCon  = empty

 pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
                                                             (map (pprIfaceConDecl tc) cs))
 
 pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
                                                             (map (pprIfaceConDecl tc) cs))
 

@@ -556,6 +573,8 @@ eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
 
 eq_hsCD env (IfNewTyCon c1)  (IfNewTyCon c2)  = eq_ConDecl env c1 c2
 eq_hsCD env IfAbstractTyCon  IfAbstractTyCon  = Equal
 
 eq_hsCD env (IfNewTyCon c1)  (IfNewTyCon c2)  = eq_ConDecl env c1 c2
 eq_hsCD env IfAbstractTyCon  IfAbstractTyCon  = Equal

+eq_hsCD env IfOpenDataTyCon  IfOpenDataTyCon  = Equal
+eq_hsCD env IfOpenNewTyCon   IfOpenNewTyCon   = Equal

 eq_hsCD env d1              d2               = NotEqual
 
 eq_ConDecl env c1 c2
 eq_hsCD env d1              d2               = NotEqual
 
 eq_ConDecl env c1 c2

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index fa91a0a..7901f7c 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -185,7 +185,8 @@ import IdInfo               ( IdInfo, CafInfo(..), WorkerInfo(..),
 import NewDemand       ( isTopSig )
 import CoreSyn
 import Class           ( classExtraBigSig, classTyCon )
 import NewDemand       ( isTopSig )
 import CoreSyn
 import Class           ( classExtraBigSig, classTyCon )

-import TyCon           ( TyCon, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon,
+import TyCon           ( TyCon, AlgTyConRhs(..), SynTyConRhs(..),
+                         isRecursiveTyCon, isForeignTyCon, 

                          isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
                          isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
                          tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon,
                          isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
                          isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
                          tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon,

@@ -1018,9 +1019,10 @@ tyThingToIfaceDecl ext (AClass clas)
 
 tyThingToIfaceDecl ext (ATyCon tycon)
   | isSynTyCon tycon
 
 tyThingToIfaceDecl ext (ATyCon tycon)
   | isSynTyCon tycon

-  = IfaceSyn { ifName   = getOccName tycon,
-               ifTyVars = toIfaceTvBndrs tyvars,
-               ifSynRhs = toIfaceType ext syn_ty }
+  = IfaceSyn { ifName    = getOccName tycon,
+               ifTyVars  = toIfaceTvBndrs tyvars,
+               ifOpenSyn = syn_isOpen,
+               ifSynRhs  = toIfaceType ext syn_tyki }

 
   | isAlgTyCon tycon
   = IfaceData {        ifName    = getOccName tycon,
 
   | isAlgTyCon tycon
   = IfaceData {        ifName    = getOccName tycon,

@@ -1048,10 +1050,16 @@ tyThingToIfaceDecl ext (ATyCon tycon)
   | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
   where
     tyvars = tyConTyVars tycon
   | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
   where
     tyvars = tyConTyVars tycon

-    syn_ty = synTyConRhs tycon
-
-    ifaceConDecls (NewTyCon { data_con = con })    = IfNewTyCon  (ifaceConDecl con)
-    ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
+    (syn_isOpen, syn_tyki) = case synTyConRhs tycon of
+                              OpenSynTyCon ki -> (True , ki)
+                              SynonymTyCon ty -> (False, ty)
+
+    ifaceConDecls (NewTyCon { data_con = con })    = 
+      IfNewTyCon  (ifaceConDecl con)
+    ifaceConDecls (DataTyCon { data_cons = cons }) = 
+      IfDataTyCon (map ifaceConDecl cons)
+    ifaceConDecls OpenDataTyCon                    = IfOpenDataTyCon
+    ifaceConDecls OpenNewTyCon                     = IfOpenNewTyCon

     ifaceConDecls AbstractTyCon                           = IfAbstractTyCon
        -- The last case happens when a TyCon has been trimmed during tidying
        -- Furthermore, tyThingToIfaceDecl is also used
     ifaceConDecls AbstractTyCon                           = IfAbstractTyCon
        -- The last case happens when a TyCon has been trimmed during tidying
        -- Furthermore, tyThingToIfaceDecl is also used

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 1f3c5d4..08dfe8c 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -19,8 +19,10 @@ import IfaceEnv              ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder,
                          extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
                          tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, 
                          newIfaceName, newIfaceNames, ifaceExportNames )
                          extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
                          tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, 
                          newIfaceName, newIfaceNames, ifaceExportNames )

-import BuildTyCl       ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
-                         mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
+import BuildTyCl       ( buildSynTyCon, buildAlgTyCon, buildDataCon,
+                         buildClass, 
+                         mkAbstractTyConRhs, mkOpenDataTyConRhs,
+                         mkOpenNewTyConRhs, mkDataTyConRhs, mkNewTyConRhs )

 import TcRnMonad
 import Type            ( liftedTypeKind, splitTyConApp, mkTyConApp,
                           liftedTypeKindTyCon, unliftedTypeKindTyCon, 
 import TcRnMonad
 import Type            ( liftedTypeKind, splitTyConApp, mkTyConApp,
                           liftedTypeKindTyCon, unliftedTypeKindTyCon, 

@@ -28,7 +30,7 @@ import Type           ( liftedTypeKind, splitTyConApp, mkTyConApp,
                           ubxTupleKindTyCon,
                          mkTyVarTys, ThetaType )
 import TypeRep         ( Type(..), PredType(..) )
                           ubxTupleKindTyCon,
                          mkTyVarTys, ThetaType )
 import TypeRep         ( Type(..), PredType(..) )

-import TyCon           ( TyCon, tyConName )
+import TyCon           ( TyCon, tyConName, SynTyConRhs(..) )

 import HscTypes                ( ExternalPackageState(..), 
                          TyThing(..), tyThingClass, tyThingTyCon, 
                          ModIface(..), ModDetails(..), HomeModInfo(..),
 import HscTypes                ( ExternalPackageState(..), 
                          TyThing(..), tyThingClass, tyThingTyCon, 
                          ModIface(..), ModDetails(..), HomeModInfo(..),

@@ -371,11 +373,13 @@ tcIfaceDecl (IfaceData {ifName = occ_name,
     }}
 
 tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
     }}
 
 tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 

-                      ifSynRhs = rdr_rhs_ty})
+                      ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty})

    = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
      { tc_name <- lookupIfaceTop occ_name
    = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
      { tc_name <- lookupIfaceTop occ_name

-     ; rhs_ty <- tcIfaceType rdr_rhs_ty
-     ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty))
+     ; rhs_tyki <- tcIfaceType rdr_rhs_ty
+     ; let rhs = if isOpen then OpenSynTyCon rhs_tyki 
+                          else SynonymTyCon rhs_tyki
+     ; return (ATyCon (buildSynTyCon tc_name tyvars rhs))

      }
 
 tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, 
      }
 
 tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, 

@@ -413,6 +417,8 @@ tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
 tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
   = case if_cons of
        IfAbstractTyCon  -> return mkAbstractTyConRhs
 tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
   = case if_cons of
        IfAbstractTyCon  -> return mkAbstractTyConRhs

+       IfOpenDataTyCon  -> return mkOpenDataTyConRhs
+       IfOpenNewTyCon   -> return mkOpenNewTyConRhs

        IfDataTyCon cons -> do  { data_cons <- mappM tc_con_decl cons
                                ; return (mkDataTyConRhs data_cons) }
        IfNewTyCon con   -> do  { data_con <- tc_con_decl con
        IfDataTyCon cons -> do  { data_cons <- mappM tc_con_decl cons
                                ; return (mkDataTyConRhs data_cons) }
        IfNewTyCon con   -> do  { data_con <- tc_con_decl con

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index be47c76..c25a617 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -109,7 +109,8 @@ module GHC (
        TyCon, 
        tyConTyVars, tyConDataCons, tyConArity,
        isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
        TyCon, 
        tyConTyVars, tyConDataCons, tyConArity,
        isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,

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

 
        -- ** Type variables
        TyVar,
 
        -- ** Type variables
        TyVar,

@@ -203,8 +204,9 @@ import Id           ( Id, idType, isImplicitId, isDeadBinder,
 import Var             ( TyVar )
 import TysPrim         ( alphaTyVars )
 import TyCon           ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
 import Var             ( TyVar )
 import TysPrim         ( alphaTyVars )
 import TyCon           ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,

-                         isPrimTyCon, isFunTyCon, tyConArity,
-                         tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs )
+                         isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity,
+                         tyConTyVars, tyConDataCons, synTyConDefn,
+                         synTyConType, synTyConResKind )

 import Class           ( Class, classSCTheta, classTvsFds, classMethods )
 import FunDeps         ( pprFundeps )
 import DataCon         ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
 import Class           ( Class, classSCTheta, classTvsFds, classMethods )
 import FunDeps         ( pprFundeps )
 import DataCon         ( DataCon, dataConWrapId, dataConSig, dataConTyCon,

diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index 6354984..4d7fd8e 100644 (file)
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -67,7 +67,7 @@ pprTyThingHdr exts (ATyCon tyCon)     = pprTyConHdr   exts tyCon
 pprTyThingHdr exts (AClass cls)       = pprClassHdr   exts cls
         
 pprTyConHdr exts tyCon =
 pprTyThingHdr exts (AClass cls)       = pprClassHdr   exts cls
         
 pprTyConHdr exts tyCon =

-  ptext keyword <+> ppr_bndr tyCon <+> hsep (map ppr vars)
+  addFamily (ptext keyword) <+> ppr_bndr tyCon <+> hsep (map ppr vars)

   where
     vars | GHC.isPrimTyCon tyCon || 
           GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars
   where
     vars | GHC.isPrimTyCon tyCon || 
           GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars

@@ -77,6 +77,10 @@ pprTyConHdr exts tyCon =
             | GHC.isNewTyCon tyCon = SLIT("newtype")
             | otherwise            = SLIT("data")
 
             | GHC.isNewTyCon tyCon = SLIT("newtype")
             | otherwise            = SLIT("data")
 

+    addFamily keytext 
+      | GHC.isOpenTyCon tyCon = keytext <> ptext SLIT(" family")
+      | otherwise             = keytext
+

 pprDataConSig exts dataCon =
   ppr_bndr dataCon <+> dcolon <+> pprType exts (GHC.dataConType dataCon)
 
 pprDataConSig exts dataCon =
   ppr_bndr dataCon <+> dcolon <+> pprType exts (GHC.dataConType dataCon)
 

@@ -109,8 +113,12 @@ pprType False ty = ppr (GHC.dropForAlls ty)
 
 pprTyCon exts tyCon
   | GHC.isSynTyCon tyCon
 
 pprTyCon exts tyCon
   | GHC.isSynTyCon tyCon

-  = let rhs_type = GHC.synTyConRhs tyCon
-    in hang (pprTyConHdr exts tyCon <+> equals) 2 (pprType exts rhs_type)
+  = if GHC.isOpenTyCon tyCon
+    then pprTyConHdr exts tyCon <+> dcolon <+> 
+        pprType exts (GHC.synTyConResKind tyCon)
+    else 
+      let rhs_type = GHC.synTyConType tyCon
+      in hang (pprTyConHdr exts tyCon <+> equals) 2 (pprType exts rhs_type)

   | otherwise
   = pprAlgTyCon exts tyCon (const True) (const True)
 
   | otherwise
   = pprAlgTyCon exts tyCon (const True) (const True)
 

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 9747c22..ea29fb1 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -35,6 +35,7 @@ import RdrHsSyn               ( findSplice )
 import PrelNames       ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN,
                          main_RDR_Unqual )
 import RdrName         ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv )
 import PrelNames       ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN,
                          main_RDR_Unqual )
 import RdrName         ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv )

+import TyCon           ( isOpenTyCon )

 import TcHsSyn         ( zonkTopDecls )
 import TcExpr          ( tcInferRho )
 import TcRnMonad
 import TcHsSyn         ( zonkTopDecls )
 import TcExpr          ( tcInferRho )
 import TcRnMonad

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 73d9b5a..a823884 100644 (file)
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -585,9 +585,12 @@ reifyTyCon tc
   | isFunTyCon tc  = return (TH.PrimTyConI (reifyName tc) 2              False)
   | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
   | isSynTyCon tc
   | isFunTyCon tc  = return (TH.PrimTyConI (reifyName tc) 2              False)
   | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
   | isSynTyCon tc

-  = do { let (tvs, rhs) = synTyConDefn tc
-       ; rhs' <- reifyType rhs
-       ; return (TH.TyConI $ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
+  = case synTyConDefn tc of
+      Nothing         -> noTH SLIT("type family") (ppr tc)
+      Just (tvs, rhs) -> 
+        do { rhs' <- reifyType rhs
+          ; return (TH.TyConI $ 
+                      TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }

 
 reifyTyCon tc
   = do         { cxt <- reifyCxt (tyConStupidTheta tc)
 
 reifyTyCon tc
   = do         { cxt <- reifyCxt (tyConStupidTheta tc)

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 8ca5b01..e87cd66 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -44,8 +44,11 @@ import Type          ( PredType(..), splitTyConApp_maybe, mkTyVarTy,
                        )
 import Generics                ( validGenericMethodType, canDoGenerics )
 import Class           ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
                        )
 import Generics                ( validGenericMethodType, canDoGenerics )
 import Class           ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )

-import TyCon           ( TyCon, AlgTyConRhs( AbstractTyCon ),
-                         tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon,
+import TyCon           ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon, 
+                                             OpenNewTyCon ), 
+                         SynTyConRhs( OpenSynTyCon, SynonymTyCon ),
+                         tyConDataCons, mkForeignTyCon, isProductTyCon,
+                         isRecursiveTyCon, isOpenTyCon,

                          tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName,
                           isNewTyCon )
 import DataCon         ( DataCon, dataConUserType, dataConName, 
                          tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName,
                           isNewTyCon )
 import DataCon         ( DataCon, dataConUserType, dataConName, 

@@ -583,7 +586,7 @@ tcSynDecl
   = tcTyVarBndrs tvs           $ \ tvs' -> do 
     { traceTc (text "tcd1" <+> ppr tc_name) 
     ; rhs_ty' <- tcHsKindedType rhs_ty
   = tcTyVarBndrs tvs           $ \ tvs' -> do 
     { traceTc (text "tcd1" <+> ppr tc_name) 
     ; rhs_ty' <- tcHsKindedType rhs_ty

-    ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty')) }
+    ; return (ATyCon (buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty'))) }

 
 --------------------
 tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM TyThing
 
 --------------------
 tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM TyThing

@@ -591,18 +594,38 @@ tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM TyThing
 tcTyClDecl calc_isrec decl
   = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl)
 
 tcTyClDecl calc_isrec decl
   = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl)
 

-  -- kind signature for a type functions
+  -- kind signature for a type function

 tcTyClDecl1 _calc_isrec 
   (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind})
 tcTyClDecl1 _calc_isrec 
   (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind})

-  = tcKindSigDecl tc_name tvs kind
+  = tcTyVarBndrs tvs  $ \ tvs' -> do 
+  { gla_exts <- doptM Opt_GlasgowExts
+
+       -- Check that we don't use kind signatures without Glasgow extensions
+  ; checkTc gla_exts $ badSigTyDecl tc_name
+
+  ; return (ATyCon (buildSynTyCon tc_name tvs' (OpenSynTyCon kind)))
+  }

 
   -- kind signature for an indexed data type
 tcTyClDecl1 _calc_isrec 
 
   -- kind signature for an indexed data type
 tcTyClDecl1 _calc_isrec 

-  (TyData {tcdCtxt = ctxt, tcdTyVars = tvs,
-          tcdLName = L _ tc_name, tcdKindSig = Just kind, tcdCons = []})
-  = do
-  { checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name
-  ; tcKindSigDecl tc_name tvs kind
+  (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
+          tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = []})
+  = tcTyVarBndrs tvs  $ \ tvs' -> do 
+  { extra_tvs <- tcDataKindSig mb_ksig
+  ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
+
+  ; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name
+  ; gla_exts <- doptM Opt_GlasgowExts
+
+       -- Check that we don't use kind signatures without Glasgow extensions
+  ; checkTc gla_exts $ badSigTyDecl tc_name
+
+  ; tycon <- buildAlgTyCon tc_name final_tvs [] 
+              (case new_or_data of
+                 DataType -> OpenDataTyCon
+                 NewType  -> OpenNewTyCon)
+              Recursive False True
+  ; return (ATyCon tycon)

   }
 
 tcTyClDecl1 calc_isrec
   }
 
 tcTyClDecl1 calc_isrec

@@ -689,28 +712,6 @@ tcTyClDecl1 calc_isrec
   = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0))
 
 -----------------------------------
   = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0))
 
 -----------------------------------

-tcKindSigDecl :: Name -> [LHsTyVarBndr Name] -> Kind -> TcM TyThing
-tcKindSigDecl tc_name tvs kind
-  = tcTyVarBndrs tvs  $ \ tvs' -> do 
-  { gla_exts <- doptM Opt_GlasgowExts
-
-       -- Check that we don't use kind signatures without Glasgow extensions
-  ; checkTc gla_exts $ badSigTyDecl tc_name
-
-    -- !!!TODO
-    -- We need to extend TyCon.TyCon with a new variant representing indexed
-    -- type constructors (ie, IdxTyCon).  We will use them for both indexed
-    -- data types as well as type functions.  In the case of indexed *data*
-    -- types, they are *abstract*; ie, won't be rewritten.  OR do we just want
-    -- to make another variant of AlgTyCon (after all synonyms are also
-    -- AlgTyCons...)
-    -- We need an additional argument to this functions, which determines
-    -- whether the type constructor is abstract.
-  ; tycon <- error "TcTyClsDecls.tcKindSigDecl: IdxTyCon not implemented yet."
-  ; return (ATyCon tycon)
-  }
-
------------------------------------

 tcConDecl :: Bool              -- True <=> -funbox-strict_fields
          -> NewOrData -> TyCon -> [TyVar]
          -> ConDecl Name -> TcM DataCon
 tcConDecl :: Bool              -- True <=> -funbox-strict_fields
          -> NewOrData -> TyCon -> [TyVar]
          -> ConDecl Name -> TcM DataCon

@@ -887,7 +888,9 @@ checkValidTyCl decl
 checkValidTyCon :: TyCon -> TcM ()
 checkValidTyCon tc 
   | isSynTyCon tc 
 checkValidTyCon :: TyCon -> TcM ()
 checkValidTyCon tc 
   | isSynTyCon tc 

-  = checkValidType syn_ctxt syn_rhs
+  = case synTyConRhs tc of
+      OpenSynTyCon _  -> return ()
+      SynonymTyCon ty -> checkValidType syn_ctxt ty

   | otherwise
   =    -- Check the context on the data decl
     checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)    `thenM_` 
   | otherwise
   =    -- Check the context on the data decl
     checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)    `thenM_` 

@@ -901,7 +904,6 @@ checkValidTyCon tc
   where
     syn_ctxt  = TySynCtxt name
     name      = tyConName tc
   where
     syn_ctxt  = TySynCtxt name
     name      = tyConName tc

-    syn_rhs   = synTyConRhs tc

     data_cons = tyConDataCons tc
 
     groups = equivClasses cmp_fld (concatMap get_fields data_cons)
     data_cons = tyConDataCons tc
 
     groups = equivClasses cmp_fld (concatMap get_fields data_cons)

diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index f45af9e..86d4a2b 100644 (file)
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -22,7 +22,7 @@ import RnHsSyn                ( extractHsTyNames )
 import Type            ( predTypeRep, tcView )
 import HscTypes                ( TyThing(..), ModDetails(..) )
 import TyCon            ( TyCon, tyConArity, tyConDataCons, tyConTyVars,
 import Type            ( predTypeRep, tcView )
 import HscTypes                ( TyThing(..), ModDetails(..) )
 import TyCon            ( TyCon, tyConArity, tyConDataCons, tyConTyVars,

-                          synTyConDefn, isSynTyCon, isAlgTyCon, 
+                          isSynTyCon, isAlgTyCon, 

                          tyConName, isNewTyCon, isProductTyCon, newTyConRhs )
 import Class           ( classTyCon )
 import DataCon          ( dataConOrigArgTys )
                          tyConName, isNewTyCon, isProductTyCon, newTyConRhs )
 import Class           ( classTyCon )
 import DataCon          ( dataConOrigArgTys )

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index a382808..a53c9ed 100644 (file)
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -169,7 +169,8 @@ import Type         (       -- Re-exports
                          pprType, pprParendType, pprTyThingCategory,
                          pprPred, pprTheta, pprThetaArrow, pprClassPred
                        )
                          pprType, pprParendType, pprTyThingCategory,
                          pprPred, pprTheta, pprThetaArrow, pprClassPred
                        )

-import TyCon           ( TyCon, isUnLiftedTyCon, isSynTyCon, synTyConDefn, tyConUnique )
+import TyCon           ( TyCon, isUnLiftedTyCon, isSynTyCon, isOpenTyCon,
+                         synTyConDefn, tyConUnique )    

 import DataCon         ( DataCon, dataConStupidTheta, dataConResTys )
 import Class           ( Class )
 import Var             ( TyVar, Id, isCoVar, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )
 import DataCon         ( DataCon, dataConStupidTheta, dataConResTys )
 import Class           ( Class )
 import Var             ( TyVar, Id, isCoVar, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )

@@ -591,8 +592,9 @@ isTauTy other                 = False
 
 isTauTyCon :: TyCon -> Bool
 -- Returns False for type synonyms whose expansion is a polytype
 
 isTauTyCon :: TyCon -> Bool
 -- Returns False for type synonyms whose expansion is a polytype

-isTauTyCon tc | isSynTyCon tc = isTauTy (snd (synTyConDefn tc))
-             | otherwise     = True
+isTauTyCon tc 
+  | isSynTyCon tc && not (isOpenTyCon tc) = isTauTy (snd (synTyConDefn tc))
+  | otherwise                             = True

 
 ---------------
 isBoxyTy :: TcType -> Bool
 
 ---------------
 isBoxyTy :: TcType -> Bool

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 83cd8f2..5ab8458 100644 (file)
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -11,10 +11,11 @@ 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,
        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
        isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
        isHiBootTyCon, isSuperKindTyCon,

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

@@ -227,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]

@@ -507,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)
 

@@ -547,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

@@ -610,7 +629,8 @@ 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
 
    = expand tvs rhs tys
 tcExpandTyCon_maybe other_tycon tys = Nothing
 

@@ -701,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}

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 2aa31eb..a7aeeec 100644 (file)
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -12,7 +12,7 @@ module Type (
 
        -- Kinds
         Kind, SimpleKind, KindVar,
 
        -- Kinds
         Kind, SimpleKind, KindVar,

-        kindFunResult, splitKindFunTys, 
+        kindFunResult, splitKindFunTys, splitKindFunTysN,

 
         liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
         argTypeKindTyCon, ubxTupleKindTyCon,
 
         liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
         argTypeKindTyCon, ubxTupleKindTyCon,

@@ -1371,6 +1371,9 @@ kindFunResult k = funResultTy k
 splitKindFunTys :: Kind -> ([Kind],Kind)
 splitKindFunTys k = splitFunTys k
 
 splitKindFunTys :: Kind -> ([Kind],Kind)
 splitKindFunTys k = splitFunTys k
 

+splitKindFunTysN :: Int -> Kind -> ([Kind],Kind)
+splitKindFunTysN k = splitFunTysN k
+

 isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool
 
 isOpenTypeKindCon tc    = tyConUnique tc == openTypeKindTyConKey
 isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool
 
 isOpenTypeKindCon tc    = tyConUnique tc == openTypeKindTyConKey