Commit 696fc4ba authored by Jan Stolarek's avatar Jan Stolarek

Split SynTyCon to SynonymTyCon and FamilyTyCon

This patch refactors internal representation of type synonyms and type families by splitting them into two separate data constructors of TyCon data type. The main motivation is is that some fields make sense only for type synonyms and some make sense only for type families. This will be even more true with the upcoming injective type families.

There is also some refactoring of names to keep the naming constistent. And thus tc_kind field has become tyConKind and tc_roles has become tcRoles. Both changes are not visible from the outside of TyCon module.

Updates haddock submodule

Reviewers: simonpj

Differential Revision: https://phabricator.haskell.org/D508

GHC Trac Issues: #9812
parent 64cb4968
......@@ -729,9 +729,8 @@ lintType ty@(TyConApp tc tys)
| Just ty' <- coreView ty
= lintType ty' -- Expand type synonyms, so that we do not bogusly complain
-- about un-saturated type synonyms
--
| isUnLiftedTyCon tc || isSynTyCon tc
| isUnLiftedTyCon tc || isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
-- See Note [The kind invariant] in TypeRep
-- Also type synonyms and type families
, length tys < tyConArity tc
......
......@@ -7,7 +7,8 @@
{-# LANGUAGE CPP #-}
module BuildTyCl (
buildSynTyCon,
buildSynonymTyCon,
buildFamilyTyCon,
buildAlgTyCon,
buildDataCon,
buildPatSyn,
......@@ -45,13 +46,22 @@ import Outputable
\begin{code}
------------------------------------------------------
buildSynTyCon :: Name -> [TyVar] -> [Role]
-> SynTyConRhs
-> Kind -- ^ Kind of the RHS
-> TyConParent
-> TcRnIf m n TyCon
buildSynTyCon tc_name tvs roles rhs rhs_kind parent
= return (mkSynTyCon tc_name kind tvs roles rhs parent)
buildSynonymTyCon :: Name -> [TyVar] -> [Role]
-> Type
-> Kind -- ^ Kind of the RHS
-> TcRnIf m n TyCon
buildSynonymTyCon tc_name tvs roles rhs rhs_kind
= return (mkSynonymTyCon tc_name kind tvs roles rhs)
where kind = mkPiKinds tvs rhs_kind
buildFamilyTyCon :: Name -> [TyVar]
-> FamTyConFlav
-> Kind -- ^ Kind of the RHS
-> TyConParent
-> TcRnIf m n TyCon
buildFamilyTyCon tc_name tvs rhs rhs_kind parent
= return (mkFamilyTyCon tc_name kind tvs rhs parent)
where kind = mkPiKinds tvs rhs_kind
......
......@@ -9,7 +9,7 @@
module IfaceSyn (
module IfaceType,
IfaceDecl(..), IfaceSynTyConRhs(..), IfaceClassOp(..), IfaceAT(..),
IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),
IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,
IfaceExpr(..), IfaceAlt, IfaceLetBndr(..),
IfaceBinding(..), IfaceConAlt(..),
......@@ -101,11 +101,18 @@ data IfaceDecl
-- or data/newtype family instance
}
| IfaceSyn { ifName :: IfaceTopBndr, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifRoles :: [Role], -- Roles
ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon)
ifSynRhs :: IfaceSynTyConRhs }
| IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifRoles :: [Role], -- Roles
ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of
-- the tycon)
ifSynRhs :: IfaceType }
| IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifFamKind :: IfaceKind, -- Kind of the *rhs* (not of
-- the tycon)
ifFamFlav :: IfaceFamTyConFlav }
| IfaceClass { ifCtxt :: IfaceContext, -- Context...
ifName :: IfaceTopBndr, -- Name of the class TyCon
......@@ -145,12 +152,11 @@ data IfaceTyConParent
IfaceTyCon
IfaceTcArgs
data IfaceSynTyConRhs
data IfaceFamTyConFlav
= IfaceOpenSynFamilyTyCon
| IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom
[IfaceAxBranch] -- for pretty printing purposes only
| IfaceAbstractClosedSynFamilyTyCon
| IfaceSynonymTyCon IfaceType
| IfaceBuiltInSynFamTyCon -- for pretty printing purposes only
data IfaceClassOp = IfaceClassOp IfaceTopBndr DefMethSpec IfaceType
......@@ -734,16 +740,16 @@ pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
| showSub ss sg = Just $ pprIfaceClassOp ss sg
| otherwise = Nothing
pprIfaceDecl ss (IfaceSyn { ifName = tc
, ifTyVars = tv
, ifSynRhs = IfaceSynonymTyCon mono_ty })
pprIfaceDecl ss (IfaceSynonym { ifName = tc
, ifTyVars = tv
, ifSynRhs = mono_ty })
= hang (ptext (sLit "type") <+> pprIfaceDeclHead [] ss tc tv <+> equals)
2 (sep [pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau])
where
(tvs, theta, tau) = splitIfaceSigmaTy mono_ty
pprIfaceDecl ss (IfaceSyn { ifName = tycon, ifTyVars = tyvars
, ifSynRhs = rhs, ifSynKind = kind })
pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
, ifFamFlav = rhs, ifFamKind = kind })
= vcat [ hang (text "type family" <+> pprIfaceDeclHead [] ss tycon tyvars <+> dcolon)
2 (ppr kind <+> ppShowRhs ss (pp_rhs rhs))
, ppShowRhs ss (nest 2 (pp_branches rhs)) ]
......@@ -1111,11 +1117,16 @@ freeNamesIfDecl d@IfaceData{} =
freeNamesIfaceTyConParent (ifParent d) &&&
freeNamesIfContext (ifCtxt d) &&&
freeNamesIfConDecls (ifCons d)
freeNamesIfDecl d@IfaceSyn{} =
freeNamesIfDecl d@IfaceSynonym{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
freeNamesIfSynRhs (ifSynRhs d) &&&
freeNamesIfType (ifSynRhs d) &&&
freeNamesIfKind (ifSynKind d) -- IA0_NOTE: because of promotion, we
-- return names in the kind signature
freeNamesIfDecl d@IfaceFamily{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
freeNamesIfFamFlav (ifFamFlav d) &&&
freeNamesIfKind (ifFamKind d) -- IA0_NOTE: because of promotion, we
-- return names in the kind signature
freeNamesIfDecl d@IfaceClass{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
freeNamesIfContext (ifCtxt d) &&&
......@@ -1147,13 +1158,12 @@ freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc
freeNamesIfIdDetails _ = emptyNameSet
-- All other changes are handled via the version info on the tycon
freeNamesIfSynRhs :: IfaceSynTyConRhs -> NameSet
freeNamesIfSynRhs (IfaceSynonymTyCon ty) = freeNamesIfType ty
freeNamesIfSynRhs IfaceOpenSynFamilyTyCon = emptyNameSet
freeNamesIfSynRhs (IfaceClosedSynFamilyTyCon ax br)
freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet
freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon ax br)
= unitNameSet ax &&& fnList freeNamesIfAxBranch br
freeNamesIfSynRhs IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
freeNamesIfSynRhs IfaceBuiltInSynFamTyCon = emptyNameSet
freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
freeNamesIfContext :: IfaceContext -> NameSet
freeNamesIfContext = fnList freeNamesIfType
......@@ -1385,7 +1395,7 @@ instance Binary IfaceDecl where
put_ bh a9
put_ bh a10
put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do
putByte bh 3
put_ bh (occNameFS a1)
put_ bh a2
......@@ -1393,8 +1403,15 @@ instance Binary IfaceDecl where
put_ bh a4
put_ bh a5
put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
put_ bh (IfaceFamily a1 a2 a3 a4) = do
putByte bh 4
put_ bh (occNameFS a1)
put_ bh a2
put_ bh a3
put_ bh a4
put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
putByte bh 5
put_ bh a1
put_ bh (occNameFS a2)
put_ bh a3
......@@ -1406,14 +1423,14 @@ instance Binary IfaceDecl where
put_ bh a9
put_ bh (IfaceAxiom a1 a2 a3 a4) = do
putByte bh 5
putByte bh 6
put_ bh (occNameFS a1)
put_ bh a2
put_ bh a3
put_ bh a4
put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
putByte bh 6
putByte bh 7
put_ bh (occNameFS name)
put_ bh a2
put_ bh a3
......@@ -1453,8 +1470,14 @@ instance Binary IfaceDecl where
a4 <- get bh
a5 <- get bh
occ <- return $! mkTcOccFS a1
return (IfaceSyn occ a2 a3 a4 a5)
return (IfaceSynonym occ a2 a3 a4 a5)
4 -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
a4 <- get bh
occ <- return $! mkTcOccFS a1
return (IfaceFamily occ a2 a3 a4)
5 -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
a4 <- get bh
......@@ -1465,13 +1488,13 @@ instance Binary IfaceDecl where
a9 <- get bh
occ <- return $! mkClsOccFS a2
return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9)
5 -> do a1 <- get bh
6 -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
a4 <- get bh
occ <- return $! mkTcOccFS a1
return (IfaceAxiom occ a2 a3 a4)
6 -> do a1 <- get bh
7 -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
a4 <- get bh
......@@ -1485,12 +1508,11 @@ instance Binary IfaceDecl where
return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9 a10)
_ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
instance Binary IfaceSynTyConRhs where
instance Binary IfaceFamTyConFlav where
put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0
put_ bh (IfaceClosedSynFamilyTyCon ax br) = putByte bh 1 >> put_ bh ax
>> put_ bh br
put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2
put_ bh (IfaceSynonymTyCon ty) = putByte bh 3 >> put_ bh ty
put_ _ IfaceBuiltInSynFamTyCon
= pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty
......@@ -1500,9 +1522,7 @@ instance Binary IfaceSynTyConRhs where
1 -> do { ax <- get bh
; br <- get bh
; return (IfaceClosedSynFamilyTyCon ax br) }
2 -> return IfaceAbstractClosedSynFamilyTyCon
_ -> do { ty <- get bh
; return (IfaceSynonymTyCon ty) } }
_ -> return IfaceAbstractClosedSynFamilyTyCon }
instance Binary IfaceClassOp where
put_ bh (IfaceClassOp n def ty) = do
......
......@@ -756,7 +756,9 @@ data IfaceDeclExtras
[AnnPayload] -- Annotations of the type itself
[IfaceIdExtras] -- For each class method: fixity, RULES and annotations
| IfaceSynExtras Fixity [IfaceInstABI] [AnnPayload]
| IfaceSynonymExtras Fixity [AnnPayload]
| IfaceFamilyExtras Fixity [IfaceInstABI] [AnnPayload]
| IfaceOtherDeclExtras
......@@ -790,7 +792,9 @@ freeNamesDeclExtras (IfaceDataExtras _ insts _ subs)
= unionManyNameSets (mkNameSet insts : map freeNamesIdExtras subs)
freeNamesDeclExtras (IfaceClassExtras _ insts _ subs)
= unionManyNameSets (mkNameSet insts : map freeNamesIdExtras subs)
freeNamesDeclExtras (IfaceSynExtras _ insts _)
freeNamesDeclExtras (IfaceSynonymExtras _ _)
= emptyNameSet
freeNamesDeclExtras (IfaceFamilyExtras _ insts _)
= mkNameSet insts
freeNamesDeclExtras IfaceOtherDeclExtras
= emptyNameSet
......@@ -801,7 +805,8 @@ freeNamesIdExtras (IdExtras _ rules _) = unionManyNameSets (map freeNamesIfRule
instance Outputable IfaceDeclExtras where
ppr IfaceOtherDeclExtras = Outputable.empty
ppr (IfaceIdExtras extras) = ppr_id_extras extras
ppr (IfaceSynExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]
ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]
ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]
ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
ppr_id_extras_s stuff]
ppr (IfaceClassExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
......@@ -825,9 +830,11 @@ instance Binary IfaceDeclExtras where
putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons
put_ bh (IfaceClassExtras fix insts anns methods) = do
putByte bh 3; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh methods
put_ bh (IfaceSynExtras fix finsts anns) = do
putByte bh 4; put_ bh fix; put_ bh finsts; put_ bh anns
put_ bh IfaceOtherDeclExtras = putByte bh 5
put_ bh (IfaceSynonymExtras fix anns) = do
putByte bh 4; put_ bh fix; put_ bh anns
put_ bh (IfaceFamilyExtras fix finsts anns) = do
putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns
put_ bh IfaceOtherDeclExtras = putByte bh 6
instance Binary IfaceIdExtras where
get _bh = panic "no get for IfaceIdExtras"
......@@ -858,7 +865,9 @@ declExtras fix_fn ann_fn rule_env inst_env fi_env decl
-- as well as instances of the class (Trac #5147)
(ann_fn n)
[id_extras op | IfaceClassOp op _ _ <- sigs]
IfaceSyn{} -> IfaceSynExtras (fix_fn n)
IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)
(ann_fn n)
IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)
(map ifFamInstAxiom (lookupOccEnvL fi_env n))
(ann_fn n)
_other -> IfaceOtherDeclExtras
......@@ -1605,11 +1614,20 @@ tyConToIfaceDecl env tycon
| Just syn_rhs <- synTyConRhs_maybe tycon
= ( tc_env1
, IfaceSyn { ifName = getOccName tycon,
ifTyVars = if_tc_tyvars,
ifRoles = tyConRoles tycon,
ifSynRhs = to_ifsyn_rhs syn_rhs,
ifSynKind = tidyToIfaceType tc_env1 (synTyConResKind tycon) })
, IfaceSynonym { ifName = getOccName tycon,
ifTyVars = if_tc_tyvars,
ifRoles = tyConRoles tycon,
ifSynRhs = if_syn_type syn_rhs,
ifSynKind = tidyToIfaceType tc_env1 (synTyConResKind tycon)
})
| Just fam_flav <- famTyConFlav_maybe tycon
= ( tc_env1
, IfaceFamily { ifName = getOccName tycon,
ifTyVars = if_tc_tyvars,
ifFamFlav = to_if_fam_flav fam_flav,
ifFamKind = tidyToIfaceType tc_env1 (synTyConResKind tycon)
})
| isAlgTyCon tycon
= ( tc_env1
......@@ -1640,6 +1658,7 @@ tyConToIfaceDecl env tycon
where
(tc_env1, tc_tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon)
if_tc_tyvars = toIfaceTvBndrs tc_tyvars
if_syn_type ty = tidyToIfaceType tc_env1 ty
funAndPrimTyVars = toIfaceTvBndrs $ take (tyConArity tycon) alphaTyVars
......@@ -1649,18 +1668,15 @@ tyConToIfaceDecl env tycon
(tidyToIfaceTcArgs tc_env1 tc ty)
Nothing -> IfNoParent
to_ifsyn_rhs OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
to_ifsyn_rhs (ClosedSynFamilyTyCon ax) = IfaceClosedSynFamilyTyCon axn ibr
to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
to_if_fam_flav (ClosedSynFamilyTyCon ax) = IfaceClosedSynFamilyTyCon axn ibr
where defs = fromBranchList $ coAxiomBranches ax
ibr = map (coAxBranchToIfaceBranch' tycon) defs
axn = coAxiomName ax
to_ifsyn_rhs AbstractClosedSynFamilyTyCon
to_if_fam_flav AbstractClosedSynFamilyTyCon
= IfaceAbstractClosedSynFamilyTyCon
to_ifsyn_rhs (SynonymTyCon ty)
= IfaceSynonymTyCon (tidyToIfaceType tc_env1 ty)
to_ifsyn_rhs (BuiltInSynFamTyCon {})
to_if_fam_flav (BuiltInSynFamTyCon {})
= IfaceBuiltInSynFamTyCon
......
......@@ -487,28 +487,41 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
; lhs_tys <- tcIfaceTcArgs arg_tys
; return (FamInstTyCon ax_unbr fam_tc lhs_tys) }
tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
ifRoles = roles,
ifSynRhs = mb_rhs_ty,
ifSynKind = kind })
tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifTyVars = tv_bndrs,
ifRoles = roles,
ifSynRhs = rhs_ty,
ifSynKind = kind })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop]
; rhs <- forkM (mk_doc tc_name) $
tc_syn_rhs mb_rhs_ty
; tycon <- buildSynTyCon tc_name tyvars roles rhs rhs_kind parent
tcIfaceType rhs_ty
; tycon <- buildSynonymTyCon tc_name tyvars roles rhs rhs_kind
; return (ATyCon tycon) }
where
mk_doc n = ptext (sLit "Type syonym") <+> ppr n
tc_syn_rhs IfaceOpenSynFamilyTyCon = return OpenSynFamilyTyCon
tc_syn_rhs (IfaceClosedSynFamilyTyCon ax_name _)
mk_doc n = ptext (sLit "Type synonym") <+> ppr n
tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs,
ifFamFlav = fam_flav,
ifFamKind = kind })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop]
; rhs <- forkM (mk_doc tc_name) $
tc_fam_flav fam_flav
; tycon <- buildFamilyTyCon tc_name tyvars rhs rhs_kind parent
; return (ATyCon tycon) }
where
mk_doc n = ptext (sLit "Type synonym") <+> ppr n
tc_fam_flav IfaceOpenSynFamilyTyCon = return OpenSynFamilyTyCon
tc_fam_flav (IfaceClosedSynFamilyTyCon ax_name _)
= do { ax <- tcIfaceCoAxiom ax_name
; return (ClosedSynFamilyTyCon ax) }
tc_syn_rhs IfaceAbstractClosedSynFamilyTyCon = return AbstractClosedSynFamilyTyCon
tc_syn_rhs (IfaceSynonymTyCon ty) = do { rhs_ty <- tcIfaceType ty
; return (SynonymTyCon rhs_ty) }
tc_syn_rhs IfaceBuiltInSynFamTyCon = pprPanic "tc_iface_decl"
(ptext (sLit "IfaceBuiltInSynFamTyCon in interface file"))
tc_fam_flav IfaceAbstractClosedSynFamilyTyCon
= return AbstractClosedSynFamilyTyCon
tc_fam_flav IfaceBuiltInSynFamTyCon
= pprPanic "tc_iface_decl"
(text "IfaceBuiltInSynFamTyCon in interface file")
tc_iface_decl _parent ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
......
......@@ -156,10 +156,12 @@ module GHC (
recordSelectorFieldLabel,
-- ** Type constructors
TyCon,
TyCon,
tyConTyVars, tyConDataCons, tyConArity,
isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
isFamilyTyCon, isOpenFamilyTyCon, tyConClass_maybe,
isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon,
isPrimTyCon, isFunTyCon,
isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon,
tyConClass_maybe,
synTyConRhs_maybe, synTyConDefn_maybe, synTyConResKind,
-- ** Type variables
......
......@@ -772,12 +772,11 @@ anyTy :: Type
anyTy = mkTyConTy anyTyCon
anyTyCon :: TyCon
anyTyCon = mkSynTyCon anyTyConName kind [kKiVar] [Nominal]
syn_rhs
NoParentTyCon
anyTyCon = mkFamilyTyCon anyTyConName kind [kKiVar]
AbstractClosedSynFamilyTyCon
NoParentTyCon
where
kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
syn_rhs = AbstractClosedSynFamilyTyCon
anyTypeOfKind :: Kind -> Type
anyTypeOfKind kind = TyConApp anyTyCon [kind]
......
......@@ -427,7 +427,7 @@ checkFunApp fun_ty arg_tys msg
else cfa False (newTyConInstRhs tc tc_args) arg_tys
| Just tc <- tyConAppTyCon_maybe fun_ty
, not (isSynFamilyTyCon tc) -- Definite error
, not (isTypeFamilyTyCon tc) -- Definite error
= (Nothing, Just msg) -- Too many args
| otherwise
......
......@@ -399,9 +399,9 @@ can_eq_nc' ev ty1 ps_ty1 ty2 ps_ty2
-- so that tv ~ F ty gets flattened
-- Otherwise F a ~ F a might not get solved!
can_eq_nc' ev (TyConApp fn1 tys1) _ ty2 ps_ty2
| isSynFamilyTyCon fn1 = can_eq_fam_nc ev NotSwapped fn1 tys1 ty2 ps_ty2
| isTypeFamilyTyCon fn1 = can_eq_fam_nc ev NotSwapped fn1 tys1 ty2 ps_ty2
can_eq_nc' ev ty1 ps_ty1 (TyConApp fn2 tys2) _
| isSynFamilyTyCon fn2 = can_eq_fam_nc ev IsSwapped fn2 tys2 ty1 ps_ty1
| isTypeFamilyTyCon fn2 = can_eq_fam_nc ev IsSwapped fn2 tys2 ty1 ps_ty1
-- Type variable on LHS or RHS are next
can_eq_nc' ev (TyVarTy tv1) _ ty2 ps_ty2
......
......@@ -561,7 +561,8 @@ deriveAutoTypeable auto_typeable done_specs tycl_decls
do_one cls (L _ decl)
= do { tc <- tcLookupTyCon (tcdName decl)
; if (isSynTyCon tc || tyConName tc `elemNameSet` done_tcs)
; if (isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
|| tyConName tc `elemNameSet` done_tcs)
-- Do not derive Typeable for type synonyms or type families
then return []
else mkPolyKindedTypeableEqn cls tc }
......
......@@ -287,7 +287,7 @@ isRigidOrSkol ty
isTyFun_maybe :: Type -> Maybe TyCon
isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
Just (tc,_) | isSynFamilyTyCon tc -> Just tc
Just (tc,_) | isTypeFamilyTyCon tc -> Just tc
_ -> Nothing
......@@ -1274,7 +1274,7 @@ quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1
; fy2 <- quickFlattenTy ty2
; return (FunTy fy1 fy2) }
quickFlattenTy (TyConApp tc tys)
| not (isSynFamilyTyCon tc)
| not (isTypeFamilyTyCon tc)
= do { fys <- mapM quickFlattenTy tys
; return (TyConApp tc fys) }
| otherwise
......
......@@ -654,7 +654,7 @@ flatten fmode (TyConApp tc tys)
| Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
, let expanded_ty = mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys'
= case fe_mode fmode of
FM_FlattenAll | anyNameEnv isSynFamilyTyCon (tyConsOfType rhs)
FM_FlattenAll | anyNameEnv isTypeFamilyTyCon (tyConsOfType rhs)
-> flatten fmode expanded_ty
| otherwise
-> flattenTyConApp fmode tc tys
......@@ -663,7 +663,7 @@ flatten fmode (TyConApp tc tys)
-- Otherwise, it's a type function application, and we have to
-- flatten it away as well, and generate a new given equality constraint
-- between the application and a newly generated flattening skolem variable.
| isSynFamilyTyCon tc
| isTypeFamilyTyCon tc
= flattenFamApp fmode tc tys
-- For * a normal data type application
......
......@@ -649,8 +649,8 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
-- (0) Check it's an open type family
; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
; checkTc (isSynFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
; checkTc (isOpenSynFamilyTyCon fam_tc) (notOpenFamily fam_tc)
; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc)
-- (1) do the work of verifying the synonym group
; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) eqn
......
......@@ -1571,8 +1571,8 @@ doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)
doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct)
doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc
, cc_tyargs = args , cc_fsk = fsk })
= ASSERT(isSynFamilyTyCon fam_tc) -- No associated data families
-- have reached this far
= ASSERT(isTypeFamilyTyCon fam_tc) -- No associated data families
-- have reached this far
ASSERT( not (isDerived old_ev) ) -- CFunEqCan is never Derived
-- Look up in top-level instances, or built-in axiom
do { match_res <- matchFam fam_tc args -- See Note [MATCHING-SYNONYMS]
......@@ -1583,7 +1583,7 @@ doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc
-- Found a top-level instance
| Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty
, isSynFamilyTyCon tc
, isTypeFamilyTyCon tc
, tc_args `lengthIs` tyConArity tc -- Short-cut
-> shortCutReduction old_ev fsk ax_co tc tc_args
-- Try shortcut; see Note [Short cut for top-level reaction]
......
......@@ -934,18 +934,22 @@ checkBootTyCon tc1 tc2
, Just syn_rhs2 <- synTyConRhs_maybe tc2
, Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
= ASSERT(tc1 == tc2)
let eqSynRhs OpenSynFamilyTyCon OpenSynFamilyTyCon = True
eqSynRhs AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
eqSynRhs (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
eqSynRhs (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
check (roles1 == roles2) roles_msg `andThenCheck`
check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say
| Just fam_flav1 <- famTyConFlav_maybe tc1
, Just fam_flav2 <- famTyConFlav_maybe tc2
= ASSERT(tc1 == tc2)
let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True
eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
= eqClosedFamilyAx ax1 ax2
eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
= eqTypeX env t1 t2
eqSynRhs (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2
eqSynRhs _ _ = False
eqFamFlav (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2
eqFamFlav _ _ = False
in
check (roles1 == roles2) roles_msg `andThenCheck`
check (eqSynRhs syn_rhs1 syn_rhs2) empty -- nothing interesting to say
check (eqFamFlav fam_flav1 fam_flav2) empty -- nothing interesting to say
| isAlgTyCon tc1 && isAlgTyCon tc2
, Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
......
......@@ -1042,7 +1042,7 @@ data Ct
| CFunEqCan { -- F xis ~ fsk
-- Invariants:
-- * isSynFamilyTyCon cc_fun
-- * isTypeFamilyTyCon cc_fun
-- * typeKind (F xis) = tyVarKind fsk
-- * always Nominal role
-- * always Given or Wanted, never Derived
......
......@@ -256,7 +256,7 @@ extendWorkListCt ct wl
= case classifyPredType (ctPred ct) of
EqPred ty1 _
| Just (tc,_) <- tcSplitTyConApp_maybe ty1
, isSynFamilyTyCon tc
, isTypeFamilyTyCon tc
-> extendWorkListFunEq ct wl
| otherwise
-> extendWorkListEq ct wl
......@@ -1939,7 +1939,7 @@ maybeSym NotSwapped co = co
matchFam :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType))
-- Given (F tys) return (ty, co), where co :: F tys ~ ty
matchFam tycon args
| isOpenSynFamilyTyCon tycon
| isOpenTypeFamilyTyCon tycon
= do { fam_envs <- getFamInstEnvs
; let mb_match = tcLookupFamInst fam_envs tycon args
; traceTcS "lookupFamInst" $
......
......@@ -22,7 +22,7 @@ import TcInteract
import Kind ( isKind, isSubKind, defaultKind_maybe )
import Inst
import Type ( classifyPredType, isIPClass, PredTree(..), getClassPredTys_maybe )
import TyCon ( isSynFamilyTyCon )
import TyCon ( isTypeFamilyTyCon )
import Class ( Class )
import Id ( idType )
import Var
......@@ -456,7 +456,7 @@ quantifyPred qtvs pred
-- over (Eq Int); the instance should kick in right here
quant_fun ty
= case tcSplitTyConApp_maybe ty of
Just (tc, tys) | isSynFamilyTyCon tc
Just (tc, tys) | isTypeFamilyTyCon tc
-> tyVarsOfTypes tys `intersectsVarSet` qtvs
_ -> False
......
......@@ -1481,7 +1481,7 @@ reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
reifyFamFlavour :: TyCon -> TcM (Either TH.FamFlavour [TH.TySynEqn])
reifyFamFlavour tc
| isOpenSynFamilyTyCon tc = return $ Left TH.TypeFam
| isOpenTypeFamilyTyCon tc = return $ Left TH.TypeFam
| isDataFamilyTyCon tc = return $ Left TH.DataFam
-- this doesn't really handle abstract closed families, but let's not worry
......
......@@ -672,8 +672,7 @@ tcFamDecl1 parent
= tcTyClTyVars tc_name tvs $ \ tvs' kind -> do
{ traceTc "open type family:" (ppr tc_name)
; checkFamFlag tc_name
; let roles = map (const Nominal) tvs'
; tycon <- buildSynTyCon tc_name tvs' roles OpenSynFamilyTyCon kind parent
; tycon <- buildFamilyTyCon tc_name tvs' OpenSynFamilyTyCon kind parent
; return [ATyCon tycon] }
tcFamDecl1 parent
......@@ -717,8 +716,7 @@ tcFamDecl1 parent
; let syn_rhs = if null eqns
then AbstractClosedSynFamilyTyCon
else ClosedSynFamilyTyCon co_ax
roles = map (const Nominal) tvs'
; tycon <- buildSynTyCon tc_name tvs' roles syn_rhs kind parent
; tycon <- buildFamilyTyCon tc_name tvs' syn_rhs kind parent
; let result = if null eqns