HsSyn clean up for indexed types

- This patch cleans up the HsSyn representation of type family declarations.
- The new representation is not only less delicate, it also simplified teh code
  a bit.
- I took the opportunity of stream lining the terminology and function names
  at the same time.
- I also updated the description on the wiki at
  <http://hackage.haskell.org/trac/ghc/wiki/TypeFunctionsSyntax>

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 09d8d0a..2b97668 100644 (file)
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -12,6 +12,7 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
 module HsDecls (
        HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl, 
        InstDecl(..), LInstDecl, DerivDecl(..), LDerivDecl, NewOrData(..),
 module HsDecls (
        HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl, 
        InstDecl(..), LInstDecl, DerivDecl(..), LDerivDecl, NewOrData(..),

+       FamilyFlavour(..),

        RuleDecl(..), LRuleDecl, RuleBndr(..),
        DefaultDecl(..), LDefaultDecl, SpliceDecl(..),
        ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
        RuleDecl(..), LRuleDecl, RuleBndr(..),
        DefaultDecl(..), LDefaultDecl, SpliceDecl(..),
        ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),

@@ -21,8 +22,8 @@ module HsDecls (
        DeprecDecl(..),  LDeprecDecl,
        HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups,
        tcdName, tyClDeclNames, tyClDeclTyVars,
        DeprecDecl(..),  LDeprecDecl,
        HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups,
        tcdName, tyClDeclNames, tyClDeclTyVars,

-       isClassDecl, isTFunDecl, isSynDecl, isDataDecl, isKindSigDecl,
-       isIdxTyDecl,
+       isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
+       isFamInstDecl, 

        countTyClDecls,
        conDetailsTys,
        instDeclATs,
        countTyClDecls,
        conDetailsTys,
        instDeclATs,

@@ -346,13 +347,9 @@ Interface file code:
 \begin{code}
 -- Representation of indexed types
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
 -- Representation of indexed types
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

--- Kind signatures of indexed types come in two flavours:
---
--- * kind signatures for type functions: variant `TyFunction' and
---
--- * kind signatures for indexed data types and newtypes : variant `TyData'
---   iff a kind is present in `tcdKindSig' and there are no constructors in
---   `tcdCons'.
+-- Family kind signatures are represented by the variant `TyFamily'.  It
+-- covers "type family", "newtype family", and "data family" declarations,
+-- distinguished by the value of the field `tcdFlavour'.

 --
 -- Indexed types are represented by 'TyData' and 'TySynonym' using the field
 -- 'tcdTyPats::Maybe [LHsType name]', with the following meaning:
 --
 -- Indexed types are represented by 'TyData' and 'TySynonym' using the field
 -- 'tcdTyPats::Maybe [LHsType name]', with the following meaning:

@@ -361,7 +358,7 @@ Interface file code:
 --     synonym declaration and 'tcdVars' contains the type parameters of the
 --     type constructor.
 --
 --     synonym declaration and 'tcdVars' contains the type parameters of the
 --     type constructor.
 --

---   * If it is 'Just pats', we have the definition of an indexed type Then,
+--   * If it is 'Just pats', we have the definition of an indexed type.  Then,

 --     'pats' are type patterns for the type-indexes of the type constructor
 --     and 'tcdVars' are the variables in those patterns.  Hence, the arity of
 --     the indexed type (ie, the number of indexes) is 'length tcdTyPats' and
 --     'pats' are type patterns for the type-indexes of the type constructor
 --     and 'tcdVars' are the variables in those patterns.  Hence, the arity of
 --     the indexed type (ie, the number of indexes) is 'length tcdTyPats' and

@@ -376,7 +373,13 @@ data TyClDecl name
                tcdLName    :: Located name,
                tcdExtName  :: Maybe FastString,
                tcdFoType   :: FoType
                tcdLName    :: Located name,
                tcdExtName  :: Maybe FastString,
                tcdFoType   :: FoType

-  }
+    }
+
+  | TyFamily {  tcdFlavour:: FamilyFlavour,            -- type, new, or data
+               tcdLName  :: Located name,              -- type constructor
+               tcdTyVars :: [LHsTyVarBndr name],       -- type variables
+               tcdKind   :: Maybe Kind                 -- result kind
+    }

 
   | TyData {   tcdND     :: NewOrData,
                tcdCtxt   :: LHsContext name,           -- Context
 
   | TyData {   tcdND     :: NewOrData,
                tcdCtxt   :: LHsContext name,           -- Context

@@ -390,12 +393,8 @@ data TyClDecl name
                        -- Nothing for everything else
 
                tcdKindSig:: Maybe Kind,                -- Optional kind sig 
                        -- Nothing for everything else
 
                tcdKindSig:: Maybe Kind,                -- Optional kind sig 

-                       -- (Just k) for a
-                       --      (a) GADT-style 'data', or 'data instance' decl 
-                       --              with explicit kind sig
-                       --      (b) 'data family' decl, whether or not 
-                       --              there is an explicit kind sig
-                       --              (this is how we distinguish a data family decl)
+                       -- (Just k) for a GADT-style 'data', or 'data
+                       -- instance' decl with explicit kind sig

 
                tcdCons   :: [LConDecl name],           -- Data constructors
                        -- For data T a = T1 | T2 a          the LConDecls all have ResTyH98
 
                tcdCons   :: [LConDecl name],           -- Data constructors
                        -- For data T a = T1 | T2 a          the LConDecls all have ResTyH98

@@ -409,18 +408,9 @@ data TyClDecl name
                        -- Typically the foralls and ty args are empty, but they
                        -- are non-empty for the newtype-deriving case
     }
                        -- Typically the foralls and ty args are empty, but they
                        -- are non-empty for the newtype-deriving case
     }

-       -- data family:   tcdPats = Nothing, tcdCons = [], tcdKindSig = Just k
-       --

        -- data instance: tcdPats = Just tys
        --
        -- data:          tcdPats = Nothing, 
        -- data instance: tcdPats = Just tys
        --
        -- data:          tcdPats = Nothing, 

-       --                tcdCons is non-empty *or* tcdKindSig = Nothing
-
-  | TyFunction {tcdLName  :: Located name,             -- type constructor
-               tcdTyVars :: [LHsTyVarBndr name],       -- type variables
-               tcdIso    :: Bool,                      -- injective type?
-               tcdKind   :: Kind                       -- result kind
-    }

 
   | TySynonym {        tcdLName  :: Located name,              -- type constructor
                tcdTyVars :: [LHsTyVarBndr name],       -- type variables
 
   | TySynonym {        tcdLName  :: Located name,              -- type constructor
                tcdTyVars :: [LHsTyVarBndr name],       -- type variables

@@ -445,46 +435,46 @@ data TyClDecl name
     }
 
 data NewOrData
     }
 
 data NewOrData

-  = NewType    -- "newtype Blah ..."
-  | DataType   -- "data Blah ..."
-  deriving( Eq )       -- Needed because Demand derives Eq
+  = NewType                    -- "newtype Blah ..."
+  | DataType                   -- "data Blah ..."
+  deriving( Eq )               -- Needed because Demand derives Eq
+
+data FamilyFlavour
+  = TypeFamily                 -- "type family ..."
+  | DataFamily NewOrData       -- "newtype family ..." or "data family ..."

 \end{code}
 
 Simple classifiers
 
 \begin{code}
 \end{code}
 
 Simple classifiers
 
 \begin{code}

-isTFunDecl, isDataDecl, isSynDecl, isClassDecl, isKindSigDecl, isIdxTyDecl ::
+isDataDecl, isTypeDecl, isSynDecl, isClassDecl, isFamilyDecl, isFamInstDecl :: 

   TyClDecl name -> Bool
 
   TyClDecl name -> Bool
 

--- type function kind signature
-isTFunDecl (TyFunction {}) = True
-isTFunDecl other          = False
-
--- vanilla Haskell type synonym
-isSynDecl (TySynonym {tcdTyPats = Nothing}) = True
-isSynDecl other                                    = False
+-- data/newtype or data/newtype instance declaration
+isDataDecl (TyData {}) = True
+isDataDecl _other      = False

 
 

--- type equation (of a type function)
-isTEqnDecl (TySynonym {tcdTyPats = Just _}) = True
-isTEqnDecl other                           = False
+-- type or type instance declaration
+isTypeDecl (TySynonym {}) = True
+isTypeDecl _other        = False

 
 

-isDataDecl (TyData {}) = True
-isDataDecl other       = False
+-- vanilla Haskell type synonym (ie, not a type instance)
+isSynDecl (TySynonym {tcdTyPats = Nothing}) = True
+isSynDecl _other                           = False

 
 

+-- type class

 isClassDecl (ClassDecl {}) = True
 isClassDecl other         = False
 
 isClassDecl (ClassDecl {}) = True
 isClassDecl other         = False
 

--- kind signature (for an indexed type)
-isKindSigDecl (TyFunction {}                   ) = True
-isKindSigDecl (TyData     {tcdKindSig = Just _,
-                          tcdCons    = []    }) = True
-isKindSigDecl other                              = False
-
--- definition of an instance of an indexed type
-isIdxTyDecl tydecl
-   | isTEqnDecl tydecl = True
-   | isDataDecl tydecl = isJust (tcdTyPats tydecl)
-   | otherwise        = False
+-- type family declaration
+isFamilyDecl (TyFamily {}) = True
+isFamilyDecl _other        = False
+
+-- family instance (types, newtypes, and data types)
+isFamInstDecl tydecl
+   | isTypeDecl tydecl
+     || isDataDecl tydecl = isJust (tcdTyPats tydecl)
+   | otherwise           = False

 \end{code}
 
 Dealing with names
 \end{code}
 
 Dealing with names

@@ -499,7 +489,7 @@ tyClDeclNames :: Eq name => TyClDecl name -> [Located name]
 -- For record fields, the first one counts as the SrcLoc
 -- We use the equality to filter out duplicate field names
 
 -- For record fields, the first one counts as the SrcLoc
 -- We use the equality to filter out duplicate field names
 

-tyClDeclNames (TyFunction  {tcdLName = name})    = [name]
+tyClDeclNames (TyFamily    {tcdLName = name})    = [name]

 tyClDeclNames (TySynonym   {tcdLName = name})    = [name]
 tyClDeclNames (ForeignType {tcdLName = name})    = [name]
 
 tyClDeclNames (TySynonym   {tcdLName = name})    = [name]
 tyClDeclNames (ForeignType {tcdLName = name})    = [name]
 

@@ -510,7 +500,7 @@ tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
 tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons})
   = tc_name : conDeclsNames (map unLoc cons)
 
 tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons})
   = tc_name : conDeclsNames (map unLoc cons)
 

-tyClDeclTyVars (TyFunction  {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (TyFamily    {tcdTyVars = tvs}) = tvs

 tyClDeclTyVars (TySynonym   {tcdTyVars = tvs}) = tvs
 tyClDeclTyVars (TyData      {tcdTyVars = tvs}) = tvs
 tyClDeclTyVars (ClassDecl   {tcdTyVars = tvs}) = tvs
 tyClDeclTyVars (TySynonym   {tcdTyVars = tvs}) = tvs
 tyClDeclTyVars (TyData      {tcdTyVars = tvs}) = tvs
 tyClDeclTyVars (ClassDecl   {tcdTyVars = tvs}) = tvs

@@ -519,21 +509,20 @@ tyClDeclTyVars (ForeignType {})                  = []
 
 \begin{code}
 countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int)
 
 \begin{code}
 countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int)

-       -- class, synonym decls, type function signatures,
-       -- type function equations, data, newtype
+       -- class, synonym decls, data, newtype, family decls, family instances

 countTyClDecls decls 
 countTyClDecls decls 

- = (count isClassDecl     decls,
-    count isSynDecl       decls,
-    count isTFunDecl      decls,
-    count isTEqnDecl      decls,
-    count isDataTy        decls,
-    count isNewTy         decls) 
+ = (count isClassDecl    decls,
+    count isSynDecl      decls,  -- excluding...
+    count isDataTy       decls,  -- ...family...
+    count isNewTy        decls,  -- ...instances
+    count isFamilyDecl   decls,
+    count isFamInstDecl  decls)

  where
  where

-   isDataTy TyData{tcdND=DataType} = True
-   isDataTy _                      = False
+   isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True
+   isDataTy _                                             = False

    
    

-   isNewTy TyData{tcdND=NewType} = True
-   isNewTy _                     = False
+   isNewTy TyData{tcdND = NewType, tcdTyPats = Nothing} = True
+   isNewTy _                                            = False

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -543,14 +532,18 @@ instance OutputableBndr name
     ppr (ForeignType {tcdLName = ltycon})
        = hsep [ptext SLIT("foreign import type dotnet"), ppr ltycon]
 
     ppr (ForeignType {tcdLName = ltycon})
        = hsep [ptext SLIT("foreign import type dotnet"), ppr ltycon]
 

-    ppr (TyFunction {tcdLName = ltycon, tcdTyVars = tyvars, tcdIso = iso, 
-                    tcdKind = kind})
-      = typeMaybeIso <+> pp_decl_head [] ltycon tyvars Nothing <+> 
-       dcolon <+> pprKind kind
+    ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon, 
+                  tcdTyVars = tyvars, tcdKind = mb_kind})
+      = pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind

         where
         where

-         typeMaybeIso = if iso 
-                        then ptext SLIT("type family iso") 
-                        else ptext SLIT("type family")
+         pp_flavour = case flavour of
+                        TypeFamily          -> ptext SLIT("type family")
+                        DataFamily NewType  -> ptext SLIT("newtype family")
+                        DataFamily DataType -> ptext SLIT("data family")
+
+          pp_kind = case mb_kind of
+                     Nothing   -> empty
+                     Just kind -> dcolon <+> pprKind kind

 
     ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
                    tcdSynRhs = mono_ty})
 
     ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
                    tcdSynRhs = mono_ty})

diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs
index ee8717f..0327cce 100644 (file)
--- a/compiler/main/HscStats.lhs
+++ b/compiler/main/HscStats.lhs
@@ -38,10 +38,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _ _ _))
                ("FixityDecls      ", fixity_sigs),
                ("DefaultDecls     ", default_ds),
                ("TypeDecls        ", type_ds),
                ("FixityDecls      ", fixity_sigs),
                ("DefaultDecls     ", default_ds),
                ("TypeDecls        ", type_ds),

-               ("TypeFunDecls     ", type_fun_ds),
-               ("TypeEquations    ", type_equs),

                ("DataDecls        ", data_ds),
                ("NewTypeDecls     ", newt_ds),
                ("DataDecls        ", data_ds),
                ("NewTypeDecls     ", newt_ds),

+               ("TypeFamilyDecls  ", type_fam_ds),
+               ("FamilyInstDecls  ", fam_inst_ds),

                ("DataConstrs      ", data_constrs),
                ("DataDerivings    ", data_derivs),
                ("ClassDecls       ", class_ds),
                ("DataConstrs      ", data_constrs),
                ("DataDerivings    ", data_derivs),
                ("ClassDecls       ", class_ds),

@@ -77,7 +77,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _ _ _))
                -- in class decls.  ToDo
 
     tycl_decls  = [d | TyClD d <- decls]
                -- in class decls.  ToDo
 
     tycl_decls  = [d | TyClD d <- decls]

-    (class_ds, type_ds, type_fun_ds, type_equs, data_ds, newt_ds) = 
+    (class_ds, type_ds, data_ds, newt_ds, type_fam_ds, fam_inst_ds) = 

       countTyClDecls tycl_decls
 
     inst_decls  = [d | InstD d <- decls]
       countTyClDecls tycl_decls
 
     inst_decls  = [d | InstD d <- decls]

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index bb0fc1e..49dabf0 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -422,7 +422,6 @@ data Token
   | ITccallconv
   | ITdotnet
   | ITmdo
   | ITccallconv
   | ITdotnet
   | ITmdo

-  | ITiso

   | ITfamily
 
        -- Pragmas
   | ITfamily
 
        -- Pragmas

@@ -556,7 +555,6 @@ isSpecial ITunsafe          = True
 isSpecial ITccallconv   = True
 isSpecial ITstdcallconv = True
 isSpecial ITmdo                = True
 isSpecial ITccallconv   = True
 isSpecial ITstdcallconv = True
 isSpecial ITmdo                = True

-isSpecial ITiso                = True

 isSpecial ITfamily     = True
 isSpecial _             = False
 
 isSpecial ITfamily     = True
 isSpecial _             = False
 

@@ -649,7 +647,7 @@ reservedSymsFM = listToUFM $
        ,("∀",        ITforall,       bit glaExtsBit)
        ,("→",   ITrarrow,    bit glaExtsBit)
        ,("←",   ITlarrow,    bit glaExtsBit)
        ,("∀",        ITforall,       bit glaExtsBit)
        ,("→",   ITrarrow,    bit glaExtsBit)
        ,("←",   ITlarrow,    bit glaExtsBit)

-       ,("⋯",        ITdotdot,       bit glaExtsBit)
+       ,("?",  ITdotdot,       bit glaExtsBit)

         -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
         -- form part of a large operator.  This would let us have a better
         -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
         -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
         -- form part of a large operator.  This would let us have a better
         -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 060eeac..55f8cf2 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -44,7 +44,7 @@ import FastString
 import Maybes          ( orElse )
 import Outputable
 
 import Maybes          ( orElse )
 import Outputable
 

-import Control.Monad    ( when )
+import Control.Monad    ( unless )

 import GHC.Exts
 import Data.Char
 import Control.Monad    ( mplus )
 import GHC.Exts
 import Data.Char
 import Control.Monad    ( mplus )

@@ -52,6 +52,17 @@ import Control.Monad    ( mplus )
 
 {-
 -----------------------------------------------------------------------------
 
 {-
 -----------------------------------------------------------------------------

+31 December 2006
+
+Conflicts: 34 shift/reduce
+           1 reduce/reduce
+
+The reduce/reduce conflict is weird.  It's between tyconsym and consym, and I
+would think the two should never occur in the same context.
+
+  -=chak
+
+-----------------------------------------------------------------------------

 6 December 2006
 
 Conflicts: 32 shift/reduce
 6 December 2006
 
 Conflicts: 32 shift/reduce

@@ -208,7 +219,6 @@ incorrect.
  'threadsafe'  { L _ ITthreadsafe }
  'unsafe'      { L _ ITunsafe }
  'mdo'         { L _ ITmdo }
  'threadsafe'  { L _ ITthreadsafe }
  'unsafe'      { L _ ITunsafe }
  'mdo'         { L _ ITmdo }

- 'iso'         { L _ ITiso }

  'family'      { L _ ITfamily }
  'stdcall'      { L _ ITstdcallconv }
  'ccall'        { L _ ITccallconv }
  'family'      { L _ ITfamily }
  'stdcall'      { L _ ITstdcallconv }
  'ccall'        { L _ ITccallconv }

@@ -547,7 +557,7 @@ ty_decl :: { LTyClDecl RdrName }
                -- infix type constructors to be declared 
                {% do { (tc, tvs, _) <- checkSynHdr $2 False
                      ; return (L (comb2 $1 $4) 
                -- infix type constructors to be declared 
                {% do { (tc, tvs, _) <- checkSynHdr $2 False
                      ; return (L (comb2 $1 $4) 

-                                 (TySynonym tc tvs Nothing $4)) 
+                                 (TySynonym tc tvs Nothing $4))

                       } }
 
            -- type family declarations
                       } }
 
            -- type family declarations

@@ -556,11 +566,8 @@ ty_decl :: { LTyClDecl RdrName }
                -- infix type constructors to be declared
                --
                {% do { (tc, tvs, _) <- checkSynHdr $3 False
                -- infix type constructors to be declared
                --
                {% do { (tc, tvs, _) <- checkSynHdr $3 False

-                     ; let kind = case unLoc $4 of
-                                    Nothing -> liftedTypeKind
-                                    Just ki -> ki

                      ; return (L (comb3 $1 $3 $4) 
                      ; return (L (comb3 $1 $3 $4) 

-                                 (TyFunction tc tvs False kind))
+                                 (TyFamily TypeFamily tc tvs (unLoc $4)))

                      } }
 
            -- type instance declarations
                      } }
 
            -- type instance declarations

@@ -598,14 +605,14 @@ ty_decl :: { LTyClDecl RdrName }
           -- data/newtype family
         | data_or_newtype 'family' tycl_hdr opt_kind_sig
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
           -- data/newtype family
         | data_or_newtype 'family' tycl_hdr opt_kind_sig
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}

-                      ; checkTyVars tparms    -- no type pattern
-                     ; let kind = case unLoc $4 of
-                                    Nothing -> liftedTypeKind
-                                    Just ki -> ki
+                      ; checkTyVars tparms            -- no type pattern
+                     ; unless (null (unLoc ctxt)) $  -- and no context
+                         parseError (getLoc ctxt) 
+                           "A family declaration cannot have a context"

                      ; return $
                          L (comb3 $1 $2 $4)
                      ; return $
                          L (comb3 $1 $2 $4)

-                           (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
-                             (Just kind) [] Nothing) } }
+                           (TyFamily (DataFamily (unLoc $1)) tc tvs 
+                                     (unLoc $4)) } }

 
           -- data/newtype instance declaration
        | data_or_newtype 'instance' tycl_hdr constrs deriving
 
           -- data/newtype instance declaration
        | data_or_newtype 'instance' tycl_hdr constrs deriving

@@ -645,11 +652,8 @@ at_decl_cls :: { LTyClDecl RdrName }
                -- infix type constructors to be declared
                --
                {% do { (tc, tvs, _) <- checkSynHdr $2 False
                -- infix type constructors to be declared
                --
                {% do { (tc, tvs, _) <- checkSynHdr $2 False

-                     ; let kind = case unLoc $3 of
-                                    Nothing -> liftedTypeKind
-                                    Just ki -> ki

                      ; return (L (comb3 $1 $2 $3) 
                      ; return (L (comb3 $1 $2 $3) 

-                                 (TyFunction tc tvs False kind))
+                                 (TyFamily TypeFamily tc tvs (unLoc $3)))

                      } }
 
            -- default type instance
                      } }
 
            -- default type instance

@@ -665,14 +669,15 @@ at_decl_cls :: { LTyClDecl RdrName }
           -- data/newtype family declaration
         | data_or_newtype tycl_hdr opt_kind_sig
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
           -- data/newtype family declaration
         | data_or_newtype tycl_hdr opt_kind_sig
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}

-                      ; checkTyVars tparms    -- no type pattern
-                     ; let kind = case unLoc $3 of
-                                    Nothing -> liftedTypeKind
-                                    Just ki -> ki
+                      ; checkTyVars tparms            -- no type pattern
+                     ; unless (null (unLoc ctxt)) $  -- and no context
+                         parseError (getLoc ctxt) 
+                           "A family declaration cannot have a context"

                      ; return $
                          L (comb3 $1 $2 $3)
                      ; return $
                          L (comb3 $1 $2 $3)

-                           (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
-                             (Just kind) [] Nothing) } }
+                           (TyFamily (DataFamily (unLoc $1)) tc tvs
+                                     (unLoc $3)) 
+                      } }

 
 -- Associate type instances
 --
 
 -- Associate type instances
 --

@@ -709,10 +714,6 @@ at_decl_inst :: { LTyClDecl RdrName }
                            (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
                             (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
 
                            (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
                             (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
 

-opt_iso :: { Bool }
-       :       { False }
-       | 'iso' { True  }
-

 data_or_newtype :: { Located NewOrData }
        : 'data'        { L1 DataType }
        | 'newtype'     { L1 NewType }
 data_or_newtype :: { Located NewOrData }
        : 'data'        { L1 DataType }
        | 'newtype'     { L1 NewType }

@@ -1706,7 +1707,6 @@ varid_no_unsafe :: { Located RdrName }
        : VARID                 { L1 $! mkUnqual varName (getVARID $1) }
        | special_id            { L1 $! mkUnqual varName (unLoc $1) }
        | 'forall'              { L1 $! mkUnqual varName FSLIT("forall") }
        : VARID                 { L1 $! mkUnqual varName (getVARID $1) }
        | special_id            { L1 $! mkUnqual varName (unLoc $1) }
        | 'forall'              { L1 $! mkUnqual varName FSLIT("forall") }

-       | 'iso'                 { L1 $! mkUnqual varName FSLIT("iso") }

        | 'family'              { L1 $! mkUnqual varName FSLIT("family") }
 
 qvarsym :: { Located RdrName }
        | 'family'              { L1 $! mkUnqual varName FSLIT("family") }
 
 qvarsym :: { Located RdrName }

@@ -1731,7 +1731,7 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-'
 
 -- These special_ids are treated as keywords in various places, 
 -- but as ordinary ids elsewhere.   'special_id' collects all these
 
 -- These special_ids are treated as keywords in various places, 
 -- but as ordinary ids elsewhere.   'special_id' collects all these

--- except 'unsafe', 'forall', 'family', and 'iso' whose treatment differs
+-- except 'unsafe', 'forall', and 'family' whose treatment differs

 -- depending on context 
 special_id :: { Located FastString }
 special_id
 -- depending on context 
 special_id :: { Located FastString }
 special_id

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 200ea57..687ffd2 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -311,7 +311,7 @@ add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs, hs_docs = docs})
                addl (gp { hs_tyclds = L l d : ts, 
                            hs_fixds = fsigs ++ fs,
                            hs_docs = add_doc decl docs}) ds
                addl (gp { hs_tyclds = L l d : ts, 
                            hs_fixds = fsigs ++ fs,
                            hs_docs = add_doc decl docs}) ds

-       | isIdxTyDecl d = 
+       | isFamInstDecl d = 

                addl (gp { hs_tyclds = L l d : ts }) ds
        | otherwise =
                addl (gp { hs_tyclds = L l d : ts, 
                addl (gp { hs_tyclds = L l d : ts }) ds
        | otherwise =
                addl (gp { hs_tyclds = L l d : ts, 

@@ -548,7 +548,7 @@ checkKindSigs :: [LTyClDecl RdrName] -> P ()
 checkKindSigs = mapM_ check
   where
     check (L l tydecl) 
 checkKindSigs = mapM_ check
   where
     check (L l tydecl) 

-      | isKindSigDecl tydecl
+      | isFamilyDecl tydecl

         || isSynDecl tydecl  = return ()
       | otherwise           = 
        parseError l "Type declaration in a class must be a kind signature or synonym default"
         || isSynDecl tydecl  = return ()
       | otherwise           = 
        parseError l "Type declaration in a class must be a kind signature or synonym default"

diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 05cfa96..ccdf18b 100644 (file)
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -17,7 +17,7 @@ import DynFlags               ( DynFlag(..), GhcMode(..), DynFlags(..) )
 import HsSyn           ( IE(..), ieName, ImportDecl(..), LImportDecl,
                          ForeignDecl(..), HsGroup(..), HsValBinds(..),
                          Sig(..), collectHsBindLocatedBinders, tyClDeclNames,
 import HsSyn           ( IE(..), ieName, ImportDecl(..), LImportDecl,
                          ForeignDecl(..), HsGroup(..), HsValBinds(..),
                          Sig(..), collectHsBindLocatedBinders, tyClDeclNames,

-                         instDeclATs, isIdxTyDecl,
+                         instDeclATs, isFamInstDecl,

                          LIE )
 import RnEnv
 import RnHsDoc          ( rnHsDoc )
                          LIE )
 import RnEnv
 import RnHsDoc          ( rnHsDoc )

@@ -336,7 +336,7 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs,
     for_hs_bndrs = [nm | L _ (ForeignImport nm _ _) <- foreign_decls]
 
     new_tc tc_decl 
     for_hs_bndrs = [nm | L _ (ForeignImport nm _ _) <- foreign_decls]
 
     new_tc tc_decl 

-      | isIdxTyDecl (unLoc tc_decl)
+      | isFamInstDecl (unLoc tc_decl)

        = do { main_name <- lookupFamInstDeclBndr mod main_rdr
             ; sub_names <- mappM (newTopSrcBinder mod) sub_rdrs
             ; return (AvailTC main_name sub_names) }
        = do { main_name <- lookupFamInstDeclBndr mod main_rdr
             ; sub_names <- mappM (newTopSrcBinder mod) sub_rdrs
             ; return (AvailTC main_name sub_names) }

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 9653bdc..a9d6c5d 100644 (file)
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -380,26 +380,16 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 
 Renaming of the associated types in instances.  
 
 
 Renaming of the associated types in instances.  
 

-* We raise an error if we encounter a kind signature in an instance.
-

 \begin{code}
 rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 rnATInsts atDecls = 
   mapFvRn (wrapLocFstM rnATInst) atDecls
   where
 \begin{code}
 rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 rnATInsts atDecls = 
   mapFvRn (wrapLocFstM rnATInst) atDecls
   where

-    rnATInst tydecl@TyFunction {} = 
-      do
-        addErr noKindSig
-       rnTyClDecl tydecl
+    rnATInst tydecl@TyData     {} = rnTyClDecl tydecl

     rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl
     rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl

-    rnATInst tydecl@TyData     {} = 
-      do
-        checkM (not . isKindSigDecl $ tydecl) $ addErr noKindSig
-        rnTyClDecl tydecl
-    rnATInst _                    =
-      panic "RnSource.rnATInsts: not a type declaration"
-
-noKindSig = text "Instances cannot have kind signatures"
+    rnATInst tydecl               =
+      pprPanic "RnSource.rnATInsts: invalid AT instance" 
+              (ppr (tcdName tydecl))

 \end{code}
 
 For the method bindings in class and instance decls, we extend the 
 \end{code}
 
 For the method bindings in class and instance decls, we extend the 

@@ -557,17 +547,21 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_
     returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
             emptyFVs)
 
     returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
             emptyFVs)
 

+-- all flavours of type family declarations ("type family", "newtype fanily",
+-- and "data family")
+rnTyClDecl (tydecl@TyFamily {}) =
+  rnFamily tydecl bindTyVarsRn
+
+-- "data", "newtype", "data instance, and "newtype instance" declarations

 rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, 
                           tcdLName = tycon, tcdTyVars = tyvars, 
                           tcdTyPats = typatsMaybe, tcdCons = condecls, 
                           tcdKindSig = sig, tcdDerivs = derivs})
 rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, 
                           tcdLName = tycon, tcdTyVars = tyvars, 
                           tcdTyPats = typatsMaybe, tcdCons = condecls, 
                           tcdKindSig = sig, tcdDerivs = derivs})

-  | isKindSigDecl tydecl  -- kind signature of indexed type
-  = rnTySig tydecl bindTyVarsRn

   | is_vanilla           -- Normal Haskell data type decl
   = ASSERT( isNothing sig )    -- In normal H98 form, kind signature on the 
                                -- data type is syntactically illegal
     bindTyVarsRn data_doc tyvars               $ \ tyvars' ->
   | is_vanilla           -- Normal Haskell data type decl
   = ASSERT( isNothing sig )    -- In normal H98 form, kind signature on the 
                                -- data type is syntactically illegal
     bindTyVarsRn data_doc tyvars               $ \ tyvars' ->

-    do { tycon' <- if isIdxTyDecl tydecl
+    do { tycon' <- if isFamInstDecl tydecl

                    then lookupLocatedOccRn     tycon -- may be imported family
                    else lookupLocatedTopBndrRn tycon
        ; context' <- rnContext data_doc context
                    then lookupLocatedOccRn     tycon -- may be imported family
                    else lookupLocatedTopBndrRn tycon
        ; context' <- rnContext data_doc context

@@ -583,14 +577,14 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
                   extractHsCtxtTyNames context'        `plusFV`
                   plusFVs (map conDeclFVs condecls')   `plusFV`
                   deriv_fvs                            `plusFV`
                   extractHsCtxtTyNames context'        `plusFV`
                   plusFVs (map conDeclFVs condecls')   `plusFV`
                   deriv_fvs                            `plusFV`

-                  (if isIdxTyDecl tydecl
+                  (if isFamInstDecl tydecl

                   then unitFV (unLoc tycon')   -- type instance => use
                   else emptyFVs)) 
         }
 
   | otherwise            -- GADT
   = ASSERT( none typatsMaybe )    -- GADTs cannot have type patterns for now
                   then unitFV (unLoc tycon')   -- type instance => use
                   else emptyFVs)) 
         }
 
   | otherwise            -- GADT
   = ASSERT( none typatsMaybe )    -- GADTs cannot have type patterns for now

-    do { tycon' <- if isIdxTyDecl tydecl
+    do { tycon' <- if isFamInstDecl tydecl

                    then lookupLocatedOccRn     tycon -- may be imported family
                    else lookupLocatedTopBndrRn tycon
        ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
                    then lookupLocatedOccRn     tycon -- may be imported family
                    else lookupLocatedTopBndrRn tycon
        ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)

@@ -608,7 +602,7 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
                           tcdCons = condecls', tcdDerivs = derivs'}, 
                   plusFVs (map conDeclFVs condecls') `plusFV` 
                   deriv_fvs                          `plusFV`
                           tcdCons = condecls', tcdDerivs = derivs'}, 
                   plusFVs (map conDeclFVs condecls') `plusFV` 
                   deriv_fvs                          `plusFV`

-                  (if isIdxTyDecl tydecl
+                  (if isFamInstDecl tydecl

                   then unitFV (unLoc tycon')   -- type instance => use
                   else emptyFVs))
         }
                   then unitFV (unLoc tycon')   -- type instance => use
                   else emptyFVs))
         }

@@ -631,13 +625,11 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
     rn_derivs (Just ds) = rnLHsTypes data_doc ds       `thenM` \ ds' -> 
                          returnM (Just ds', extractHsTyNames_s ds')
 
     rn_derivs (Just ds) = rnLHsTypes data_doc ds       `thenM` \ ds' -> 
                          returnM (Just ds', extractHsTyNames_s ds')
 

-rnTyClDecl (tydecl@TyFunction {}) =
-  rnTySig tydecl bindTyVarsRn
-
+-- "type" and "type instance" declarations

 rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
                              tcdTyPats = typatsMaybe, tcdSynRhs = ty})
   = bindTyVarsRn syn_doc tyvars                        $ \ tyvars' ->
 rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
                              tcdTyPats = typatsMaybe, tcdSynRhs = ty})
   = bindTyVarsRn syn_doc tyvars                        $ \ tyvars' ->

-    do { name' <- if isIdxTyDecl tydecl
+    do { name' <- if isFamInstDecl tydecl

                  then lookupLocatedOccRn     name -- may be imported family
                  else lookupLocatedTopBndrRn name
        ; typats' <- rnTyPats syn_doc typatsMaybe
                  then lookupLocatedOccRn     name -- may be imported family
                  else lookupLocatedTopBndrRn name
        ; typats' <- rnTyPats syn_doc typatsMaybe

@@ -646,7 +638,7 @@ rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
                             tcdTyPats = typats', tcdSynRhs = ty'},
                  delFVs (map hsLTyVarName tyvars') $
                  fvs                         `plusFV`
                             tcdTyPats = typats', tcdSynRhs = ty'},
                  delFVs (map hsLTyVarName tyvars') $
                  fvs                         `plusFV`

-                  (if isIdxTyDecl tydecl
+                  (if isFamInstDecl tydecl

                   then unitFV (unLoc name')    -- type instance => use
                   else emptyFVs))
        }
                   then unitFV (unLoc name')    -- type instance => use
                   else emptyFVs))
        }

@@ -808,64 +800,45 @@ rnField doc (HsRecField name ty haddock_doc)
     rnMbLHsDoc haddock_doc      `thenM` \ new_haddock_doc ->
     returnM (HsRecField new_name new_ty new_haddock_doc) 
 
     rnMbLHsDoc haddock_doc      `thenM` \ new_haddock_doc ->
     returnM (HsRecField new_name new_ty new_haddock_doc) 
 

--- Rename kind signatures (signatures of indexed data types/newtypes and
--- signatures of type functions)
+-- Rename family declarations

 --
 -- * This function is parametrised by the routine handling the index
 --   variables.  On the toplevel, these are defining occurences, whereas they
 --   are usage occurences for associated types.
 --
 --
 -- * This function is parametrised by the routine handling the index
 --   variables.  On the toplevel, these are defining occurences, whereas they
 --   are usage occurences for associated types.
 --

-rnTySig :: TyClDecl RdrName 
-        -> (SDoc -> [LHsTyVarBndr RdrName] -> 
-           ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
-           RnM (TyClDecl Name, FreeVars))
-        -> RnM (TyClDecl Name, FreeVars)
-
-rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon, 
-                       tcdTyVars = tyvars, tcdTyPats = mb_typats,
-                       tcdCons = condecls, tcdKindSig = sig, 
-                       tcdDerivs = derivs}) 
+rnFamily :: TyClDecl RdrName 
+         -> (SDoc -> [LHsTyVarBndr RdrName] -> 
+            ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
+            RnM (TyClDecl Name, FreeVars))
+         -> RnM (TyClDecl Name, FreeVars)
+
+rnFamily (tydecl@TyFamily {tcdFlavour = flavour, 
+                          tcdLName = tycon, tcdTyVars = tyvars}) 

         bindIdxVars =
         bindIdxVars =

-      ASSERT( null condecls )      -- won't have constructors
-      ASSERT( isNothing mb_typats ) -- won't have type patterns
-      ASSERT( isNothing derivs )    -- won't have deriving
-      ASSERT( isJust sig )          -- will have kind signature
-      do { bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
+      do { checkM (isDataFlavour flavour                      -- for synonyms,
+                  || not (null tyvars)) $ addErr needOneIdx  -- #indexes >= 1
+        ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {

         ; tycon' <- lookupLocatedTopBndrRn tycon
         ; tycon' <- lookupLocatedTopBndrRn tycon

-        ; context' <- rnContext (ksig_doc tycon) context
-        ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = context', 
-                           tcdLName = tycon', tcdTyVars = tyvars',
-                           tcdTyPats = Nothing, tcdKindSig = sig, 
-                           tcdCons = [], tcdDerivs = Nothing}, 
-                   delFVs (map hsLTyVarName tyvars') $
-                   extractHsCtxtTyNames context') 
-         } }
-      where
-
-rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars, 
-                           tcdKind = sig}) 
-        bindIdxVars =
-      do { checkM (not . null $ tyvars) $ addErr needOneIdx   -- #indexes >= 1
-        ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
-        ; tycon' <- lookupLocatedTopBndrRn tycon
-        ; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars',
-                               tcdIso = tcdIso tydecl, tcdKind = sig}, 
+        ; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon', 
+                             tcdTyVars = tyvars', tcdKind = tcdKind tydecl}, 

                    emptyFVs) 
          } }
                    emptyFVs) 
          } }

+      where
+        isDataFlavour (DataFamily _) = True
+       isDataFlavour _              = False

 
 

-ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon)
-needOneIdx = text "Kind signature requires at least one type index"
+family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
+needOneIdx = text "Type family declarations requires at least one type index"

 
 -- Rename associated type declarations (in classes)
 --
 
 -- Rename associated type declarations (in classes)
 --

--- * This can be kind signatures and (default) type function equations.
+-- * This can be family declarations and (default) type instances

 --
 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
   where
 --
 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
   where

-    rn_at (tydecl@TyData     {}) = rnTySig tydecl lookupIdxVars
-    rn_at (tydecl@TyFunction {}) = rnTySig tydecl lookupIdxVars
-    rn_at (tydecl@TySynonym  {}) = 
+    rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
+    rn_at (tydecl@TySynonym {}) = 

       do
         checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
         rnTyClDecl tydecl
       do
         checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
         rnTyClDecl tydecl

diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 92c7958..f43a4d7 100644 (file)
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -727,15 +727,15 @@ mkGenericInstance clas (hs_ty, binds)
 tcAddDeclCtxt decl thing_inside
   = addErrCtxt ctxt thing_inside
   where
 tcAddDeclCtxt decl thing_inside
   = addErrCtxt ctxt thing_inside
   where

-     thing = case decl of
-               ClassDecl {}              -> "class"
-               TySynonym {}              -> "type synonym"
-               TyFunction {}             -> "type function signature"
-               TyData {tcdND = NewType}  -> "newtype" ++ maybeSig
-               TyData {tcdND = DataType} -> "data type" ++ maybeSig
-
-     maybeSig | isKindSigDecl decl = " signature"
-             | otherwise          = ""
+     thing | isClassDecl decl  = "class"
+          | isTypeDecl decl   = "type synonym" ++ maybeInst
+          | isDataDecl decl   = if tcdND decl == NewType 
+                                then "newtype" ++ maybeInst
+                                else "data type" ++ maybeInst
+          | isFamilyDecl decl = "family"
+
+     maybeInst | isFamInstDecl decl = " family"
+              | otherwise          = ""

 
      ctxt = hsep [ptext SLIT("In the"), text thing, 
                  ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
 
      ctxt = hsep [ptext SLIT("In the"), text thing, 
                  ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index da18ef1..b4d3498 100644 (file)
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -147,9 +147,8 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                -- (they recover, so that we get more than one error each
                -- round) 
 
                -- (they recover, so that we get more than one error each
                -- round) 
 

-               -- (1) Do class instance declarations and instances of indexed
-               --     types 
-       ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
+               -- (1) Do class and family instance declarations
+       ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }

        ; local_info_tycons <- mappM tcLocalInstDecl1  inst_decls
        ; idx_tycons        <- mappM tcIdxTyInstDeclTL idxty_decls
 
        ; local_info_tycons <- mappM tcLocalInstDecl1  inst_decls
        ; idx_tycons        <- mappM tcIdxTyInstDeclTL idxty_decls
 

@@ -193,7 +192,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
     -- !!!TODO: Need to perform this check for the TyThing of type functions,
     --         too.
     tcIdxTyInstDeclTL ldecl@(L loc decl) =
     -- !!!TODO: Need to perform this check for the TyThing of type functions,
     --         too.
     tcIdxTyInstDeclTL ldecl@(L loc decl) =

-      do { tything <- tcIdxTyInstDecl ldecl
+      do { tything <- tcFamInstDecl ldecl

         ; setSrcSpan loc $
             when (isAssocFamily tything) $
               addErr $ assocInClassErr (tcdName decl)
         ; setSrcSpan loc $
             when (isAssocFamily tything) $
               addErr $ assocInClassErr (tcdName decl)

@@ -243,7 +242,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
        ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
        
        -- Next, process any associated types.
        ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
        
        -- Next, process any associated types.

-       ; idx_tycons <- mappM tcIdxTyInstDecl ats
+       ; idx_tycons <- mappM tcFamInstDecl ats

 
        -- Now, check the validity of the instance.
        ; (clas, inst_tys) <- checkValidInstHead tau
 
        -- Now, check the validity of the instance.
        ; (clas, inst_tys) <- checkValidInstHead tau

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 834bedc..4d0030e 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -7,7 +7,7 @@ TcTyClsDecls: Typecheck type and class declarations
 
 \begin{code}
 module TcTyClsDecls (
 
 \begin{code}
 module TcTyClsDecls (

-       tcTyAndClassDecls, tcIdxTyInstDecl
+       tcTyAndClassDecls, tcFamInstDecl

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

@@ -45,6 +45,7 @@ import Digraph
 import DynFlags
 
 import Data.List        ( partition, elemIndex )
 import DynFlags
 
 import Data.List        ( partition, elemIndex )

+import Control.Monad    ( mplus )

 \end{code}
 
 
 \end{code}
 
 

@@ -134,7 +135,7 @@ tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
 tcTyAndClassDecls boot_details allDecls
   = do {       -- Omit instances of indexed types; they are handled together
                -- with the *heads* of class instances
 tcTyAndClassDecls boot_details allDecls
   = do {       -- Omit instances of indexed types; they are handled together
                -- with the *heads* of class instances

-        ; let decls = filter (not . isIdxTyDecl . unLoc) allDecls
+        ; let decls = filter (not . isFamInstDecl . unLoc) allDecls

 
                -- First check for cyclic type synonysm or classes
                -- See notes with checkCycleErrs
 
                -- First check for cyclic type synonysm or classes
                -- See notes with checkCycleErrs

@@ -222,36 +223,36 @@ mkGlobalThings decls things
 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

-\subsection{Type checking instances of indexed types}
+\subsection{Type checking family instances}

 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-Instances of indexed types are somewhat of a hybrid.  They are processed
-together with class instance heads, but can contain data constructors and hence
-they share a lot of kinding and type checking code with ordinary algebraic
-data types (and GADTs).
+Family instances are somewhat of a hybrid.  They are processed together with
+class instance heads, but can contain data constructors and hence they share a
+lot of kinding and type checking code with ordinary algebraic data types (and
+GADTs).

 
 \begin{code}
 
 \begin{code}

-tcIdxTyInstDecl :: LTyClDecl Name -> TcM (Maybe TyThing)   -- Nothing if error
-tcIdxTyInstDecl (L loc decl)
+tcFamInstDecl :: LTyClDecl Name -> TcM (Maybe TyThing)   -- Nothing if error
+tcFamInstDecl (L loc decl)

   =    -- Prime error recovery, set source location
     recoverM (returnM Nothing)                 $
     setSrcSpan loc                             $
     tcAddDeclCtxt decl                         $
   =    -- Prime error recovery, set source location
     recoverM (returnM Nothing)                 $
     setSrcSpan loc                             $
     tcAddDeclCtxt decl                         $

-    do { -- indexed data types require -findexed-types and can't be in an
+    do { -- type families require -findexed-types and can't be in an

         -- hs-boot file
        ; gla_exts <- doptM Opt_IndexedTypes
        ; is_boot  <- tcIsHsBoot          -- Are we compiling an hs-boot file?
         -- hs-boot file
        ; gla_exts <- doptM Opt_IndexedTypes
        ; is_boot  <- tcIsHsBoot          -- Are we compiling an hs-boot file?

-       ; checkTc gla_exts      $ badIdxTyDecl (tcdLName decl)
-       ; checkTc (not is_boot) $ badBootTyIdxDeclErr
+       ; checkTc gla_exts      $ badFamInstDecl (tcdLName decl)
+       ; checkTc (not is_boot) $ badBootFamInstDeclErr

 
         -- perform kind and type checking
 
         -- perform kind and type checking

-       ; tcIdxTyInstDecl1 decl
+       ; tcFamInstDecl1 decl

        }
 
        }
 

-tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing)   -- Nothing if error
+tcFamInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing)   -- Nothing if error

 
 

-tcIdxTyInstDecl1 (decl@TySynonym {})
+tcFamInstDecl1 (decl@TySynonym {})

   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
     do { -- check that the family declaration is for a synonym
         unless (isSynTyCon family) $
   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
     do { -- check that the family declaration is for a synonym
         unless (isSynTyCon family) $

@@ -269,8 +270,8 @@ tcIdxTyInstDecl1 (decl@TySynonym {})
        ; return Nothing     -- !!!TODO: need TyThing for indexed synonym
        }}
       
        ; return Nothing     -- !!!TODO: need TyThing for indexed synonym
        }}
       

-tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
-                              tcdCons = cons})
+tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
+                            tcdCons = cons})

   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
     do { -- check that the family declaration is for the right kind
         unless (new_or_data == NewType  && isNewTyCon  family ||
   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
     do { -- check that the family declaration is for the right kind
         unless (new_or_data == NewType  && isNewTyCon  family ||

@@ -391,11 +392,11 @@ Indexed Types
 This treatment of type synonyms only applies to Haskell 98-style synonyms.
 General type functions can be recursive, and hence, appear in `alg_decls'.
 
 This treatment of type synonyms only applies to Haskell 98-style synonyms.
 General type functions can be recursive, and hence, appear in `alg_decls'.
 

-The kind of an indexed type is solely determinded by its kind signature;
+The kind of a type family is solely determinded by its kind signature;

 hence, only kind signatures participate in the construction of the initial
 kind environment (as constructed by `getInitialKind').  In fact, we ignore
 hence, only kind signatures participate in the construction of the initial
 kind environment (as constructed by `getInitialKind').  In fact, we ignore

-instances of indexed types altogether in the following.  However, we need to
-include the kind signatures of associated types into the construction of the
+instances of families altogether in the following.  However, we need to
+include the kinds of associated families into the construction of the

 initial kind environment.  (This is handled by `allDecls').
 
 \begin{code}
 initial kind environment.  (This is handled by `allDecls').
 
 \begin{code}

@@ -420,7 +421,7 @@ kcTyClDecls syn_decls alg_decls
                -- instances of indexed types yet, but leave this to
                -- `tcInstDecls1'
        { kc_alg_decls <- mappM (wrapLocM kcTyClDecl) 
                -- instances of indexed types yet, but leave this to
                -- `tcInstDecls1'
        { kc_alg_decls <- mappM (wrapLocM kcTyClDecl) 

-                           (filter (not . isIdxTyDecl . unLoc) alg_decls)
+                           (filter (not . isFamInstDecl . unLoc) alg_decls)

 
        ; return (kc_syn_decls, kc_alg_decls) }}}
   where
 
        ; return (kc_syn_decls, kc_alg_decls) }}}
   where

@@ -428,9 +429,9 @@ kcTyClDecls syn_decls alg_decls
     -- environment
     allDecls (decl@ClassDecl {tcdATs = ats}) = decl : [ at 
                                                      | L _ at <- ats
     -- environment
     allDecls (decl@ClassDecl {tcdATs = ats}) = decl : [ at 
                                                      | L _ at <- ats

-                                                     , isKindSigDecl at]
-    allDecls decl | isIdxTyDecl decl         = []
-                 | otherwise                = [decl]
+                                                     , isFamilyDecl at]
+    allDecls decl | isFamInstDecl decl = []
+                 | otherwise          = [decl]

 
 ------------------------------------------------------------------------
 getInitialKind :: TyClDecl Name -> TcM (Name, TcKind)
 
 ------------------------------------------------------------------------
 getInitialKind :: TyClDecl Name -> TcM (Name, TcKind)

@@ -445,10 +446,9 @@ getInitialKind decl
     mk_arg_kind (UserTyVar _)        = newKindVar
     mk_arg_kind (KindedTyVar _ kind) = return kind
 
     mk_arg_kind (UserTyVar _)        = newKindVar
     mk_arg_kind (KindedTyVar _ kind) = return kind
 

-    mk_res_kind (TyFunction { tcdKind    = kind      }) = return kind
-    mk_res_kind (TyData     { tcdKindSig = Just kind }) = return kind
-       -- On GADT-style and data signature declarations we allow a kind 
-       -- signature
+    mk_res_kind (TyFamily { tcdKind    = Just kind }) = return kind
+    mk_res_kind (TyData   { tcdKindSig = Just kind }) = return kind
+       -- On GADT-style declarations we allow a kind signature

        --      data T :: *->* where { ... }
     mk_res_kind other = return liftedTypeKind
 
        --      data T :: *->* where { ... }
     mk_res_kind other = return liftedTypeKind
 

@@ -490,13 +490,15 @@ kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
        -- Not used for type synonyms (see kcSynDecl)
 
 kcTyClDecl decl@(TyData {})
        -- Not used for type synonyms (see kcSynDecl)
 
 kcTyClDecl decl@(TyData {})

-  = ASSERT( not . isJust $ tcdTyPats decl )   -- must not be instance of idx ty
+  = ASSERT( not . isFamInstDecl $ decl )   -- must not be a family instance

     kcTyClDeclBody decl        $
       kcDataDecl decl
 
     kcTyClDeclBody decl        $
       kcDataDecl decl
 

-kcTyClDecl decl@(TyFunction {})
+kcTyClDecl decl@(TyFamily {tcdKind = kind})

   = kcTyClDeclBody decl $ \ tvs' ->
   = kcTyClDeclBody decl $ \ tvs' ->

-      return (decl {tcdTyVars = tvs'})
+      return (decl {tcdTyVars = tvs', 
+                   tcdKind = kind `mplus` Just liftedTypeKind})
+                   -- default result kind is '*'

 
 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
   = kcTyClDeclBody decl        $ \ tvs' ->
 
 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
   = kcTyClDeclBody decl        $ \ tvs' ->

@@ -599,33 +601,36 @@ 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 function
+  -- "type family" declarations

 tcTyClDecl1 _calc_isrec 
 tcTyClDecl1 _calc_isrec 

-  (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind})
+  (TyFamily {tcdFlavour = TypeFamily, 
+            tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = Just kind})
+                                                     -- NB: kind at latest
+                                                     --     added during
+                                                     --     kind checking

   = tcTyVarBndrs tvs  $ \ tvs' -> do 
   { traceTc (text "type family: " <+> ppr tc_name) 
   = tcTyVarBndrs tvs  $ \ tvs' -> do 
   { traceTc (text "type family: " <+> ppr tc_name) 

-  ; gla_exts <- doptM Opt_IndexedTypes
+  ; idx_tys <- doptM Opt_IndexedTypes

 
 

-       -- Check that we don't use kind signatures without Glasgow extensions
-  ; checkTc gla_exts $ badSigTyDecl tc_name
+       -- Check that we don't use families without -findexed-types
+  ; checkTc idx_tys $ badFamInstDecl tc_name

 
   ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)]
   }
 
 
   ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)]
   }
 

-  -- kind signature for an indexed data type
+  -- "newtype family" or "data family" declaration

 tcTyClDecl1 _calc_isrec 
 tcTyClDecl1 _calc_isrec 

-  (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
-          tcdLName = L _ tc_name, tcdKindSig = Just ksig, tcdCons = []})
+  (TyFamily {tcdFlavour = DataFamily new_or_data, 
+            tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})

   = tcTyVarBndrs tvs  $ \ tvs' -> do 
   { traceTc (text "data/newtype family: " <+> ppr tc_name) 
   = tcTyVarBndrs tvs  $ \ tvs' -> do 
   { traceTc (text "data/newtype family: " <+> ppr tc_name) 

-  ; extra_tvs <- tcDataKindSig (Just ksig)
+  ; extra_tvs <- tcDataKindSig mb_kind

   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
 
   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
 

-  ; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name
-  ; gla_exts <- doptM Opt_IndexedTypes
+  ; idx_tys <- doptM Opt_IndexedTypes

 
 

-       -- Check that we don't use kind signatures without Glasgow extensions
-  ; checkTc gla_exts $ badSigTyDecl tc_name
+       -- Check that we don't use families without -findexed-types
+  ; checkTc idx_tys $ badFamInstDecl tc_name

 
   ; tycon <- buildAlgTyCon tc_name final_tvs [] 
               (case new_or_data of
 
   ; tycon <- buildAlgTyCon tc_name final_tvs [] 
               (case new_or_data of

@@ -635,6 +640,7 @@ tcTyClDecl1 _calc_isrec
   ; return [ATyCon tycon]
   }
 
   ; return [ATyCon tycon]
   }
 

+  -- "newtype", "data", "newtype instance", "data instance"

 tcTyClDecl1 calc_isrec
   (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
           tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
 tcTyClDecl1 calc_isrec
   (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
           tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})

@@ -1156,36 +1162,31 @@ newtypeFieldErr con_name n_flds
 badSigTyDecl tc_name
   = vcat [ ptext SLIT("Illegal kind signature") <+>
           quotes (ppr tc_name)
 badSigTyDecl tc_name
   = vcat [ ptext SLIT("Illegal kind signature") <+>
           quotes (ppr tc_name)

-        , nest 2 (parens $ ptext SLIT("Use -findexed-types to allow indexed types")) ]
-
-badKindSigCtxt tc_name
-  = vcat [ ptext SLIT("Illegal context in kind signature") <+>
-          quotes (ppr tc_name)
-        , nest 2 (parens $ ptext SLIT("Currently, kind signatures cannot have a context")) ]
+        , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow kind signatures")) ]

 
 

-badIdxTyDecl tc_name
-  = vcat [ ptext SLIT("Illegal indexed type instance for") <+>
+badFamInstDecl tc_name
+  = vcat [ ptext SLIT("Illegal family instance for") <+>

           quotes (ppr tc_name)
           quotes (ppr tc_name)

-        , nest 2 (parens $ ptext SLIT("Use -findexed-types to allow indexed types")) ]
+        , nest 2 (parens $ ptext SLIT("Use -findexed-types to allow indexed type families")) ]

 
 badGadtIdxTyDecl tc_name
   = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+>
           quotes (ppr tc_name)
 
 badGadtIdxTyDecl tc_name
   = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+>
           quotes (ppr tc_name)

-        , nest 2 (parens $ ptext SLIT("Indexed types cannot use GADT declarations")) ]
+        , nest 2 (parens $ ptext SLIT("Family instances can not yet use GADT declarations")) ]

 
 tooManyParmsErr tc_name
 
 tooManyParmsErr tc_name

-  = ptext SLIT("Indexed type instance has too many parameters:") <+> 
+  = ptext SLIT("Family instance has too many parameters:") <+> 

     quotes (ppr tc_name)
 
 tooFewParmsErr tc_name
     quotes (ppr tc_name)
 
 tooFewParmsErr tc_name

-  = ptext SLIT("Indexed type instance has too few parameters:") <+> 
+  = ptext SLIT("Family instance has too few parameters:") <+> 

     quotes (ppr tc_name)
 
     quotes (ppr tc_name)
 

-badBootTyIdxDeclErr = 
-  ptext SLIT("Illegal indexed type instance in hs-boot file")
+badBootFamInstDeclErr = 
+  ptext SLIT("Illegal family instance in hs-boot file")

 
 wrongKindOfFamily family =
 
 wrongKindOfFamily family =

-  ptext SLIT("Wrong category of type instance; declaration was for a") <+>
+  ptext SLIT("Wrong category of family instance; declaration was for a") <+>

   kindOfFamily
   where
     kindOfFamily | isSynTyCon  family = ptext SLIT("type synonym")
   kindOfFamily
   where
     kindOfFamily | isSynTyCon  family = ptext SLIT("type synonym")