- 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>
module HsDecls (
HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl,
InstDecl(..), LInstDecl, DerivDecl(..), LDerivDecl, NewOrData(..),
+ FamilyFlavour(..),
RuleDecl(..), LRuleDecl, RuleBndr(..),
DefaultDecl(..), LDefaultDecl, SpliceDecl(..),
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
DeprecDecl(..), LDeprecDecl,
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups,
tcdName, tyClDeclNames, tyClDeclTyVars,
- isClassDecl, isTFunDecl, isSynDecl, isDataDecl, isKindSigDecl,
- isIdxTyDecl,
+ isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
+ isFamInstDecl,
countTyClDecls,
conDetailsTys,
instDeclATs,
\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:
-- 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
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
-- 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
-- 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,
- -- 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
}
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}
-isTFunDecl, isDataDecl, isSynDecl, isClassDecl, isKindSigDecl, isIdxTyDecl ::
+isDataDecl, isTypeDecl, isSynDecl, isClassDecl, isFamilyDecl, isFamInstDecl ::
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
--- 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
-- 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 (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
\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
- = (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
- 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}
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
- 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})
("FixityDecls ", fixity_sigs),
("DefaultDecls ", default_ds),
("TypeDecls ", type_ds),
- ("TypeFunDecls ", type_fun_ds),
- ("TypeEquations ", type_equs),
("DataDecls ", data_ds),
("NewTypeDecls ", newt_ds),
+ ("TypeFamilyDecls ", type_fam_ds),
+ ("FamilyInstDecls ", fam_inst_ds),
("DataConstrs ", data_constrs),
("DataDerivings ", data_derivs),
("ClassDecls ", class_ds),
-- 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]
| ITccallconv
| ITdotnet
| ITmdo
- | ITiso
| ITfamily
-- Pragmas
isSpecial ITccallconv = True
isSpecial ITstdcallconv = True
isSpecial ITmdo = True
-isSpecial ITiso = True
isSpecial ITfamily = True
isSpecial _ = False
,("∀", 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).
import Maybes ( orElse )
import Outputable
-import Control.Monad ( when )
+import Control.Monad ( unless )
import GHC.Exts
import Data.Char
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
'threadsafe' { L _ ITthreadsafe }
'unsafe' { L _ ITunsafe }
'mdo' { L _ ITmdo }
- 'iso' { L _ ITiso }
'family' { L _ ITfamily }
'stdcall' { L _ ITstdcallconv }
'ccall' { L _ ITccallconv }
-- 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
-- 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)
- (TyFunction tc tvs False kind))
+ (TyFamily TypeFamily tc tvs (unLoc $4)))
} }
-- type instance declarations
-- 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)
- (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
-- 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)
- (TyFunction tc tvs False kind))
+ (TyFamily TypeFamily tc tvs (unLoc $3)))
} }
-- default type instance
-- 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)
- (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing)
- (Just kind) [] Nothing) } }
+ (TyFamily (DataFamily (unLoc $1)) tc tvs
+ (unLoc $3))
+ } }
-- Associate type instances
--
(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 }
: 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 }
-- 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
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,
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"
import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl,
ForeignDecl(..), HsGroup(..), HsValBinds(..),
Sig(..), collectHsBindLocatedBinders, tyClDeclNames,
- instDeclATs, isIdxTyDecl,
+ instDeclATs, isFamInstDecl,
LIE )
import RnEnv
import RnHsDoc ( rnHsDoc )
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) }
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
- rnATInst tydecl@TyFunction {} =
- do
- addErr noKindSig
- rnTyClDecl tydecl
+ rnATInst tydecl@TyData {} = 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
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})
- | 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' ->
- 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
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
- 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)
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))
}
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' ->
- 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
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))
}
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.
--
-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 =
- 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
- ; 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)
} }
+ 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)
--
--- * 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
- 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
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))]
-- (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
-- !!!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)
; (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
\begin{code}
module TcTyClsDecls (
- tcTyAndClassDecls, tcIdxTyInstDecl
+ tcTyAndClassDecls, tcFamInstDecl
) where
#include "HsVersions.h"
import DynFlags
import Data.List ( partition, elemIndex )
+import Control.Monad ( mplus )
\end{code}
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
%************************************************************************
%* *
-\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}
-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 $
- 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?
- ; 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
- ; 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) $
; 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 ||
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
-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}
-- 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
-- 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)
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
-- 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
-kcTyClDecl decl@(TyFunction {})
+kcTyClDecl decl@(TyFamily {tcdKind = kind})
= 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' ->
tcTyClDecl calc_isrec decl
= tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl)
- -- kind signature for a type function
+ -- "type family" declarations
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)
- ; 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)]
}
- -- kind signature for an indexed data type
+ -- "newtype family" or "data family" declaration
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)
- ; extra_tvs <- tcDataKindSig (Just ksig)
+ ; extra_tvs <- tcDataKindSig mb_kind
; 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
; 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})
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)
- , 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)
- , 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
- = ptext SLIT("Indexed type instance has too many parameters:") <+>
+ = ptext SLIT("Family instance has too many parameters:") <+>
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)
-badBootTyIdxDeclErr =
- ptext SLIT("Illegal indexed type instance in hs-boot file")
+badBootFamInstDeclErr =
+ ptext SLIT("Illegal family instance in hs-boot file")
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")