diff options
| author | Jan Stolarek <jan.stolarek@p.lodz.pl> | 2014-11-19 22:03:05 +0100 |
|---|---|---|
| committer | Jan Stolarek <jan.stolarek@p.lodz.pl> | 2014-11-20 18:56:36 +0100 |
| commit | 696fc4ba5b36f478d8daec56656ebf7d99e18159 (patch) | |
| tree | 17837c1712b5b042cc92f8ca8687f5d08f5c84aa | |
| parent | 64cb49686457c233d0f58e5cfa324ad28a5453a3 (diff) | |
| download | haskell-696fc4ba5b36f478d8daec56656ebf7d99e18159.tar.gz | |
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
29 files changed, 489 insertions, 342 deletions
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index f6bb1a280e..7a050a801b 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -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 diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 106a15fc9a..094ae3ecde 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -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 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 49d645d32b..4241f078eb 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -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,11 +1470,17 @@ 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 a5 <- get bh a6 <- get bh a7 <- 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 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 95fe479447..ece0644292 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -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 diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 85ea0f94cc..4950f5e47f 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -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, diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 9ab52ebf1d..41066a5147 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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 diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index e2d081a32f..e130fe57b7 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -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] diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index 93fc9cd71e..a0fdf78d34 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -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 diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 2b5efc3a6e..9b93815672 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -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 diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 6b81c29631..c662b18b20 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -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 } diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 0ce397a5d7..f9168aca3c 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -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 diff --git a/compiler/typecheck/TcFlatten.lhs b/compiler/typecheck/TcFlatten.lhs index 2d41ff8464..fbb4729432 100644 --- a/compiler/typecheck/TcFlatten.lhs +++ b/compiler/typecheck/TcFlatten.lhs @@ -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 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index b6c0da1e8b..3a6cca091b 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -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 diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 1cb3c453be..0febaf3486 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -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] diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 0b1601bc3a..ca6df13a99 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -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) diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 15be2a6212..6f00b8609d 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -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 diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index decbb4ff2b..b756fbc0e9 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -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" $ diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index b13fdedc14..8ec3591767 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -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 diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index f2efb2ae58..3302d028a5 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -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 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index e08f26934c..d5bc8b10d7 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -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 then [ATyCon tycon] @@ -752,8 +750,7 @@ tcTySynRhs rec_info tc_name tvs kind hs_ty ; rhs_ty <- tcCheckLHsType hs_ty kind ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty ; let roles = rti_roles rec_info tc_name - ; tycon <- buildSynTyCon tc_name tvs roles (SynonymTyCon rhs_ty) - kind NoParentTyCon + ; tycon <- buildSynonymTyCon tc_name tvs roles rhs_ty kind ; return [ATyCon tycon] } tcDataDefn :: RecTyInfo -> Name @@ -873,7 +870,7 @@ tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name tcAddFamInstCtxt (ptext (sLit "default type instance")) tc_name $ tcTyClTyVars tc_name hs_tvs $ \ tvs rhs_kind -> do { traceTc "tcDefaultAssocDecl" (ppr tc_name) - ; checkTc (isSynFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) ; let (fam_name, fam_pat_arity, _) = famTyConShape fam_tc ; ASSERT( fam_name == tc_name ) checkTc (length (hsQTvBndrs hs_tvs) == fam_pat_arity) @@ -1394,7 +1391,10 @@ checkValidTyCon tc = checkValidClass cl | Just syn_rhs <- synTyConRhs_maybe tc - = case syn_rhs of + = checkValidType syn_ctxt syn_rhs + + | Just fam_flav <- famTyConFlav_maybe tc + = case fam_flav of { ClosedSynFamilyTyCon ax -> checkValidClosedCoAxiom ax ; AbstractClosedSynFamilyTyCon -> do { hsBoot <- tcIsHsBootOrSig @@ -1402,7 +1402,6 @@ checkValidTyCon tc ptext (sLit "You may omit the equations in a closed type family") $$ ptext (sLit "only in a .hs-boot file") } ; OpenSynFamilyTyCon -> return () - ; SynonymTyCon ty -> checkValidType syn_ctxt ty ; BuiltInSynFamTyCon _ -> return () } | otherwise @@ -1763,7 +1762,7 @@ checkValidRoles tc | isAlgTyCon tc -- tyConDataCons returns an empty list for data families = mapM_ check_dc_roles (tyConDataCons tc) - | Just (SynonymTyCon rhs) <- synTyConRhs_maybe tc + | Just rhs <- synTyConRhs_maybe tc = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs | otherwise = return () @@ -2175,8 +2174,8 @@ wrongKindOfFamily family = ptext (sLit "Wrong category of family instance; declaration was for a") <+> kindOfFamily where - kindOfFamily | isSynTyCon family = ptext (sLit "type synonym") - | isAlgTyCon family = ptext (sLit "data type") + kindOfFamily | isTypeSynonymTyCon family = text "type synonym" + | isAlgTyCon family = text "data type" | otherwise = pprPanic "wrongKindOfFamily" (ppr family) wrongNumberOfParmsErr :: Arity -> SDoc @@ -2234,7 +2233,7 @@ addTyThingCtxt thing flav = case thing of ATyCon tc | isClassTyCon tc -> ptext (sLit "class") - | isSynFamilyTyCon tc -> ptext (sLit "type family") + | isTypeFamilyTyCon tc -> ptext (sLit "type family") | isDataFamilyTyCon tc -> ptext (sLit "data family") | isTypeSynonymTyCon tc -> ptext (sLit "type") | isNewTyCon tc -> ptext (sLit "newtype") diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index f2c2395200..381201310d 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -709,7 +709,7 @@ irTyCon tc mapM_ (irType emptyVarSet) (tyConStupidTheta tc) -- See #8958 ; mapM_ (irDataCon tc_name) (visibleDataCons $ algTyConRhs tc) }} - | Just (SynonymTyCon ty) <- synTyConRhs_maybe tc + | Just ty <- synTyConRhs_maybe tc = addRoleInferenceInfo tc_name (tyConTyVars tc) $ irType emptyVarSet ty diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index dba1be8964..74406c0033 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -67,7 +67,6 @@ module TcType ( isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, isIntegerTy, isBoolTy, isUnitTy, isCharTy, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, - isSynFamilyTyConApp, isPredTy, isTyVarClassPred, --------------------------------- @@ -554,7 +553,7 @@ tcTyFamInsts ty | Just exp_ty <- tcView ty = tcTyFamInsts exp_ty tcTyFamInsts (TyVarTy _) = [] tcTyFamInsts (TyConApp tc tys) - | isSynFamilyTyCon tc = [(tc, tys)] + | isTypeFamilyTyCon tc = [(tc, tys)] | otherwise = concat (map tcTyFamInsts tys) tcTyFamInsts (LitTy {}) = [] tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 @@ -1357,17 +1356,6 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of Nothing -> False \end{code} -\begin{code} --- NB: Currently used in places where we have already expanded type synonyms; --- hence no 'coreView'. This could, however, be changed without breaking --- any code. -isSynFamilyTyConApp :: TcTauType -> Bool -isSynFamilyTyConApp (TyConApp tc tys) = isSynFamilyTyCon tc && - length tys == tyConArity tc -isSynFamilyTyConApp _other = False -\end{code} - - %************************************************************************ %* * \subsection{Misc} diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs index 8f02c9abca..9815958da7 100644 --- a/compiler/typecheck/TcTypeNats.hs +++ b/compiler/typecheck/TcTypeNats.hs @@ -15,7 +15,7 @@ module TcTypeNats import Type import Pair import TcType ( TcType, tcEqType ) -import TyCon ( TyCon, SynTyConRhs(..), mkSynTyCon, TyConParent(..) ) +import TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon, TyConParent(..) ) import Coercion ( Role(..) ) import TcRnTypes ( Xi ) import CoAxiom ( CoAxiomRule(..), BuiltInSynFamily(..) ) @@ -104,10 +104,9 @@ typeNatExpTyCon = mkTypeNatFunTyCon2 name typeNatLeqTyCon :: TyCon typeNatLeqTyCon = - mkSynTyCon name + mkFamilyTyCon name (mkArrowKinds [ typeNatKind, typeNatKind ] boolKind) (take 2 $ tyVarList typeNatKind) - [Nominal,Nominal] (BuiltInSynFamTyCon ops) NoParentTyCon @@ -122,10 +121,9 @@ typeNatLeqTyCon = typeNatCmpTyCon :: TyCon typeNatCmpTyCon = - mkSynTyCon name + mkFamilyTyCon name (mkArrowKinds [ typeNatKind, typeNatKind ] orderingKind) (take 2 $ tyVarList typeNatKind) - [Nominal,Nominal] (BuiltInSynFamTyCon ops) NoParentTyCon @@ -140,10 +138,9 @@ typeNatCmpTyCon = typeSymbolCmpTyCon :: TyCon typeSymbolCmpTyCon = - mkSynTyCon name + mkFamilyTyCon name (mkArrowKinds [ typeSymbolKind, typeSymbolKind ] orderingKind) (take 2 $ tyVarList typeSymbolKind) - [Nominal,Nominal] (BuiltInSynFamTyCon ops) NoParentTyCon @@ -163,10 +160,9 @@ typeSymbolCmpTyCon = -- Make a binary built-in constructor of kind: Nat -> Nat -> Nat mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon mkTypeNatFunTyCon2 op tcb = - mkSynTyCon op + mkFamilyTyCon op (mkArrowKinds [ typeNatKind, typeNatKind ] typeNatKind) (take 2 $ tyVarList typeNatKind) - [Nominal,Nominal] (BuiltInSynFamTyCon tcb) NoParentTyCon diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 421d076dbf..f103fd7128 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -612,9 +612,9 @@ uType origin orig_ty1 orig_ty2 -- Always defer if a type synonym family (type function) -- is involved. (Data families behave rigidly.) go ty1@(TyConApp tc1 _) ty2 - | isSynFamilyTyCon tc1 = uType_defer origin ty1 ty2 + | isTypeFamilyTyCon tc1 = uType_defer origin ty1 ty2 go ty1 ty2@(TyConApp tc2 _) - | isSynFamilyTyCon tc2 = uType_defer origin ty1 ty2 + | isTypeFamilyTyCon tc2 = uType_defer origin ty1 ty2 go (TyConApp tc1 tys1) (TyConApp tc2 tys2) -- See Note [Mismatched type lists and application decomposition] @@ -908,7 +908,7 @@ checkTauTvUpdate dflags tv ty -- See Note [Conservative unification check] defer_me (LitTy {}) = False defer_me (TyVarTy tv') = tv == tv' - defer_me (TyConApp tc tys) = isSynFamilyTyCon tc || any defer_me tys + defer_me (TyConApp tc tys) = isTypeFamilyTyCon tc || any defer_me tys defer_me (FunTy arg res) = defer_me arg || defer_me res defer_me (AppTy fun arg) = defer_me fun || defer_me arg defer_me (ForAllTy _ ty) = not impredicative || defer_me ty diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs index 8381533a28..97d62d1f4f 100644 --- a/compiler/typecheck/TcValidity.lhs +++ b/compiler/typecheck/TcValidity.lhs @@ -294,7 +294,8 @@ check_type ctxt rank (AppTy ty1 ty2) ; check_arg_type ctxt rank ty2 } check_type ctxt rank ty@(TyConApp tc tys) - | isSynTyCon tc = check_syn_tc_app ctxt rank ty tc tys + | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc + = check_syn_tc_app ctxt rank ty tc tys | isUnboxedTupleTyCon tc = check_ubx_tuple ctxt ty tys | otherwise = mapM_ (check_arg_type ctxt rank) tys @@ -303,7 +304,7 @@ check_type _ _ (LitTy {}) = return () check_type _ _ ty = pprPanic "check_type" (ppr ty) ---------------------------------------- -check_syn_tc_app :: UserTypeCtxt -> Rank -> KindOrType +check_syn_tc_app :: UserTypeCtxt -> Rank -> KindOrType -> TyCon -> [KindOrType] -> TcM () -- Used for type synonyms and type synonym families, -- which must be saturated, @@ -318,7 +319,7 @@ check_syn_tc_app ctxt rank ty tc tys -- f :: Foo a b -> ... = do { -- See Note [Liberal type synonyms] ; liberal <- xoptM Opt_LiberalTypeSynonyms - ; if not liberal || isSynFamilyTyCon tc then + ; if not liberal || isTypeFamilyTyCon tc then -- For H98 and synonym families, do check the type args mapM_ check_arg tys @@ -334,12 +335,12 @@ check_syn_tc_app ctxt rank ty tc tys | otherwise = failWithTc (arityErr flavour (tyConName tc) tc_arity n_args) where - flavour | isSynFamilyTyCon tc = "Type family" - | otherwise = "Type synonym" + flavour | isTypeFamilyTyCon tc = "Type family" + | otherwise = "Type synonym" n_args = length tys tc_arity = tyConArity tc - check_arg | isSynFamilyTyCon tc = check_arg_type ctxt rank - | otherwise = check_mono_type ctxt synArgMonoType + check_arg | isTypeFamilyTyCon tc = check_arg_type ctxt rank + | otherwise = check_mono_type ctxt synArgMonoType ---------------------------------------- check_ubx_tuple :: UserTypeCtxt -> KindOrType diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index bc21e2e1d7..feef835bb1 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -709,7 +709,7 @@ lookup_fam_inst_env' match_fun ie fam match_tys -- Deal with over-saturation -- See Note [Over-saturated matches] split_tys tpl_tys - | isSynFamilyTyCon fam + | isTypeFamilyTyCon fam = pre_rough_split_tys | otherwise @@ -812,7 +812,7 @@ reduceTyFamApp_maybe envs role tc tys | case role of Representational -> isOpenFamilyTyCon tc - _ -> isOpenSynFamilyTyCon tc + _ -> isOpenTypeFamilyTyCon tc -- If we seek a representational coercion -- (e.g. the call in topNormaliseType_maybe) then we can -- unwrap data families as well as type-synonym families; diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 39543b380b..4e399db235 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -14,7 +14,7 @@ module TyCon( AlgTyConRhs(..), visibleDataCons, TyConParent(..), isNoParent, - SynTyConRhs(..), Role(..), + FamTyConFlav(..), Role(..), -- ** Constructing TyCons mkAlgTyCon, @@ -24,7 +24,8 @@ module TyCon( mkKindTyCon, mkLiftedPrimTyCon, mkTupleTyCon, - mkSynTyCon, + mkSynonymTyCon, + mkFamilyTyCon, mkPromotedDataCon, mkPromotedTyCon, @@ -34,7 +35,7 @@ module TyCon( isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isSynTyCon, isTypeSynonymTyCon, + isTypeSynonymTyCon, isDecomposableTyCon, isPromotedDataCon, isPromotedTyCon, isPromotedDataCon_maybe, isPromotedTyCon_maybe, @@ -44,8 +45,8 @@ module TyCon( isEnumerationTyCon, isNewTyCon, isAbstractTyCon, isFamilyTyCon, isOpenFamilyTyCon, - isSynFamilyTyCon, isDataFamilyTyCon, - isOpenSynFamilyTyCon, isClosedSynFamilyTyCon_maybe, + isTypeFamilyTyCon, isDataFamilyTyCon, + isOpenTypeFamilyTyCon, isClosedSynFamilyTyCon_maybe, isBuiltInSynFamTyCon_maybe, isUnLiftedTyCon, isGadtSyntaxTyCon, isDistinctTyCon, isDistinctAlgRhs, @@ -68,7 +69,7 @@ module TyCon( tyConParent, tyConTuple_maybe, tyConClass_maybe, tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, - synTyConDefn_maybe, synTyConRhs_maybe, + synTyConDefn_maybe, synTyConRhs_maybe, famTyConFlav_maybe, algTyConRhs, newTyConRhs, newTyConEtadArity, newTyConEtadRhs, unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, @@ -125,7 +126,7 @@ Note [Type synonym families] type instance F Int = Bool ..etc... -* Reply "yes" to isSynFamilyTyCon, and isFamilyTyCon +* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon * From the user's point of view (F Int) and Bool are simply equivalent types. @@ -322,10 +323,18 @@ N. data TyCon = -- | The function type constructor, @(->)@ FunTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just + -- the return kind) + + tyConArity :: Arity -- ^ Number of arguments this TyCon must + -- receive to be considered saturated + -- (including implicit kind variables) } -- | Algebraic type constructors, which are defined to be those @@ -333,82 +342,156 @@ data TyCon -- constructors are lifted and boxed. See 'AlgTyConRhs' for more -- information. | AlgTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, - - tyConTyVars :: [TyVar], -- ^ The kind and type variables used in the type constructor. - -- Invariant: length tyvars = arity - -- Precisely, this list scopes over: - -- - -- 1. The 'algTcStupidTheta' - -- 2. The cached types in 'algTyConRhs.NewTyCon' - -- 3. The family instance types if present - -- - -- Note that it does /not/ scope over the data constructors. - tc_roles :: [Role], -- ^ The role for each type variable - -- This list has the same length as tyConTyVars - -- See also Note [TyCon Role signatures] - - tyConCType :: Maybe CType, -- The C type that should be used - -- for this type when using the FFI - -- and CAPI - - algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT syntax? - -- If so, that doesn't mean it's a true GADT; - -- only that the "where" form was used. - -- This field is used only to guide pretty-printing - - algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data type - -- (always empty for GADTs). - -- A \"stupid theta\" is the context to the left - -- of an algebraic type declaration, - -- e.g. @Eq a@ in the declaration - -- @data Eq a => T a ...@. - - algTcRhs :: AlgTyConRhs, -- ^ Contains information about the - -- data constructors of the algebraic type - - algTcRec :: RecFlag, -- ^ Tells us whether the data type is part - -- of a mutually-recursive group or not - - algTcParent :: TyConParent, -- ^ Gives the class or family declaration 'TyCon' - -- for derived 'TyCon's representing class - -- or family instances, respectively. - -- See also 'synTcParent' - - tcPromoted :: Maybe TyCon -- ^ Promoted TyCon, if any + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just + -- the return kind) + + tyConArity :: Arity, -- ^ Number of arguments this TyCon must + -- receive to be considered saturated + -- (including implicit kind variables) + + tyConTyVars :: [TyVar], -- ^ The kind and type variables used in the + -- type constructor. + -- Invariant: length tyvars = arity + -- Precisely, this list scopes over: + -- + -- 1. The 'algTcStupidTheta' + -- 2. The cached types in algTyConRhs.NewTyCon + -- 3. The family instance types if present + -- + -- Note that it does /not/ scope over the data + -- constructors. + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has the same length as tyConTyVars + -- See also Note [TyCon Role signatures] + + tyConCType :: Maybe CType,-- ^ The C type that should be used + -- for this type when using the FFI + -- and CAPI + + algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT + -- syntax? If so, that doesn't mean it's a + -- true GADT; only that the "where" form + -- was used. This field is used only to + -- guide pretty-printing + + algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data + -- type (always empty for GADTs). A + -- \"stupid theta\" is the context to + -- the left of an algebraic type + -- declaration, e.g. @Eq a@ in the + -- declaration @data Eq a => T a ...@. + + algTcRhs :: AlgTyConRhs, -- ^ Contains information about the + -- data constructors of the algebraic type + + algTcRec :: RecFlag, -- ^ Tells us whether the data type is part + -- of a mutually-recursive group or not + + algTcParent :: TyConParent, -- ^ Gives the class or family declaration + -- 'TyCon' for derived 'TyCon's representing + -- class or family instances, respectively. + -- See also 'synTcParent' + + tcPromoted :: Maybe TyCon -- ^ Promoted TyCon, if any } -- | Represents the infinite family of tuple type constructors, -- @()@, @(a,b)@, @(# a, b #)@ etc. | TupleTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, - tyConTupleSort :: TupleSort, - tyConTyVars :: [TyVar], - dataCon :: DataCon, -- ^ Corresponding tuple data constructor - tcPromoted :: Maybe TyCon -- Nothing for unboxed tuples + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just + -- the return kind) + + tyConArity :: Arity, -- ^ Number of arguments this TyCon must + -- receive to be considered saturated + -- (including implicit kind variables) + + tyConTupleSort :: TupleSort,-- ^ Is this a boxed, unboxed or constraint + -- tuple? + + tyConTyVars :: [TyVar], -- ^ List of type and kind variables in this + -- TyCon. Includes implicit kind variables. + -- Invariant: + -- length tyConTyVars = tyConArity + + dataCon :: DataCon, -- ^ Corresponding tuple data constructor + + tcPromoted :: Maybe TyCon + -- ^ Nothing for unboxed tuples } -- | Represents type synonyms - | SynTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, + | SynonymTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just + -- the return kind) + + tyConArity :: Arity, -- ^ Number of arguments this TyCon must + -- receive to be considered saturated + -- (including implicit kind variables) + + tyConTyVars :: [TyVar], -- ^ List of type and kind variables in this + -- TyCon. Includes implicit kind variables. + -- Invariant: length tyConTyVars = tyConArity + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has the same length as tyConTyVars + -- See also Note [TyCon Role signatures] + + synTcRhs :: Type -- ^ Contains information about the expansion + -- of the synonym + } - tyConTyVars :: [TyVar], -- Bound tyvars - tc_roles :: [Role], + -- | Represents type families + | FamilyTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. - synTcRhs :: SynTyConRhs, -- ^ Contains information about the - -- expansion of the synonym + tyConName :: Name, -- ^ Name of the constructor - synTcParent :: TyConParent -- ^ Gives the family declaration 'TyCon' - -- of 'TyCon's representing family instances + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just + -- the return kind) + + tyConArity :: Arity, -- ^ Number of arguments this TyCon must + -- receive to be considered saturated + -- (including implicit kind variables) + + tyConTyVars :: [TyVar], -- ^ The kind and type variables used in the + -- type constructor. + -- Invariant: length tyvars = arity + -- Precisely, this list scopes over: + -- + -- 1. The 'algTcStupidTheta' + -- 2. The cached types in 'algTyConRhs.NewTyCon' + -- 3. The family instance types if present + -- + -- Note that it does /not/ scope over the data + -- constructors. + + famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, + -- abstract, built-in. See comments for + -- FamTyConFlav + + famTcParent :: TyConParent -- ^ TyCon of enclosing class for + -- associated type families } @@ -416,30 +499,40 @@ data TyCon -- the usual suspects (such as @Int#@) as well as foreign-imported -- types and kinds | PrimTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, - tc_roles :: [Role], - - primTyConRep :: PrimRep, -- ^ Many primitive tycons are unboxed, but some are - -- boxed (represented by pointers). This 'PrimRep' - -- holds that information. - -- Only relevant if tc_kind = * - - isUnLifted :: Bool -- ^ Most primitive tycons are unlifted - -- (may not contain bottom) - -- but other are lifted, - -- e.g. @RealWorld@ + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just + -- the return kind) + + tyConArity :: Arity, -- ^ Number of arguments this TyCon must + -- receive to be considered saturated + -- (including implicit kind variables) + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has the same length as tyConTyVars + -- See also Note [TyCon Role signatures] + + primTyConRep :: PrimRep,-- ^ Many primitive tycons are unboxed, but + -- some are boxed (represented by + -- pointers). This 'PrimRep' holds that + -- information. Only relevant if tyConKind = * + + isUnLifted :: Bool -- ^ Most primitive tycons are unlifted (may + -- not contain bottom) but other are lifted, + -- e.g. @RealWorld@ } -- | Represents promoted data constructor. - | PromotedDataCon { -- See Note [Promoted data constructors] + | PromotedDataCon { -- See Note [Promoted data constructors] tyConUnique :: Unique, -- ^ Same Unique as the data constructor tyConName :: Name, -- ^ Same Name as the data constructor tyConArity :: Arity, - tc_roles :: [Role], -- ^ Roles: N for kind vars, R for type vars - tc_kind :: Kind, -- ^ Translated type of the data constructor + tyConKind :: Kind, -- ^ Translated type of the data constructor + tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars dataCon :: DataCon -- ^ Corresponding data constructor } @@ -448,7 +541,7 @@ data TyCon tyConUnique :: Unique, -- ^ Same Unique as the type constructor tyConName :: Name, -- ^ Same Name as the type constructor tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times - tc_kind :: Kind, -- ^ Always TysPrim.superKind + tyConKind :: Kind, -- ^ Always TysPrim.superKind ty_con :: TyCon -- ^ Corresponding type constructor } @@ -615,15 +708,9 @@ isNoParent _ = False -------------------- -- | Information pertaining to the expansion of a type synonym (@type@) -data SynTyConRhs - = -- | An ordinary type synonyn. - SynonymTyCon - Type -- This 'Type' is the rhs, and may mention from 'tyConTyVars'. - -- It acts as a template for the expansion when the 'TyCon' - -- is applied to some types. - - -- | An open type synonym family e.g. @type family F x y :: * -> *@ - | OpenSynFamilyTyCon +data FamTyConFlav + = -- | An open type synonym family e.g. @type family F x y :: * -> *@ + OpenSynFamilyTyCon -- | A closed type synonym family e.g. @type family F x where { F Int = Bool }@ | ClosedSynFamilyTyCon @@ -633,6 +720,7 @@ data SynTyConRhs -- type family F a where .. | AbstractClosedSynFamilyTyCon + -- | Built-in type family used by the TypeNats solver | BuiltInSynFamTyCon BuiltInSynFamily \end{code} @@ -663,7 +751,7 @@ via the PromotedTyCon alternative in TyCon. type of DataCon Just :: forall (a:*). a -> Maybe a kind of (promoted) tycon Just :: forall (a:box). a -> Maybe a The kind is not identical to the type, because of the */box - kind signature on the forall'd variable; so the tc_kind field of + kind signature on the forall'd variable; so the tyConKind field of PromotedTyCon is not identical to the dataConUserType of the DataCon. But it's the same modulo changing the variable kinds, done by DataCon.promoteType. @@ -913,7 +1001,7 @@ mkFunTyCon name kind = FunTyCon { tyConUnique = nameUnique name, tyConName = name, - tc_kind = kind, + tyConKind = kind, tyConArity = 2 } @@ -939,10 +1027,10 @@ mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_t = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, - tc_kind = kind, + tyConKind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, - tc_roles = roles, + tcRoles = roles, tyConCType = cType, algTcStupidTheta = stupid, algTcRhs = rhs, @@ -971,7 +1059,7 @@ mkTupleTyCon name kind arity tyvars con sort prom_tc = TupleTyCon { tyConUnique = nameUnique name, tyConName = name, - tc_kind = kind, + tyConKind = kind, tyConArity = arity, tyConTupleSort = sort, tyConTyVars = tyvars, @@ -999,27 +1087,41 @@ mkPrimTyCon' name kind roles rep is_unlifted = PrimTyCon { tyConName = name, tyConUnique = nameUnique name, - tc_kind = kind, + tyConKind = kind, tyConArity = length roles, - tc_roles = roles, + tcRoles = roles, primTyConRep = rep, isUnLifted = is_unlifted } -- | Create a type synonym 'TyCon' -mkSynTyCon :: Name -> Kind -> [TyVar] -> [Role] -> SynTyConRhs -> TyConParent -> TyCon -mkSynTyCon name kind tyvars roles rhs parent - = SynTyCon { - tyConName = name, +mkSynonymTyCon :: Name -> Kind -> [TyVar] -> [Role] -> Type -> TyCon +mkSynonymTyCon name kind tyvars roles rhs + = SynonymTyCon { + tyConName = name, tyConUnique = nameUnique name, - tc_kind = kind, - tyConArity = length tyvars, + tyConKind = kind, + tyConArity = length tyvars, tyConTyVars = tyvars, - tc_roles = roles, - synTcRhs = rhs, - synTcParent = parent + tcRoles = roles, + synTcRhs = rhs } +-- | Create a type family 'TyCon' +mkFamilyTyCon:: Name -> Kind -> [TyVar] -> FamTyConFlav -> TyConParent + -> TyCon +mkFamilyTyCon name kind tyvars flav parent + = FamilyTyCon + { tyConUnique = nameUnique name + , tyConName = name + , tyConKind = kind + , tyConArity = length tyvars + , tyConTyVars = tyvars + , famTcFlav = flav + , famTcParent = parent + } + + -- | Create a promoted data constructor 'TyCon' -- Somewhat dodgily, we give it the same Name -- as the data constructor itself; when we pretty-print @@ -1030,8 +1132,8 @@ mkPromotedDataCon con name unique kind roles tyConName = name, tyConUnique = unique, tyConArity = arity, - tc_roles = roles, - tc_kind = kind, + tcRoles = roles, + tyConKind = kind, dataCon = con } where @@ -1046,7 +1148,7 @@ mkPromotedTyCon tc kind tyConName = getName tc, tyConUnique = getUnique tc, tyConArity = tyConArity tc, - tc_kind = kind, + tyConKind = kind, ty_con = tc } \end{code} @@ -1174,13 +1276,8 @@ isDataProductTyCon_maybe _ = Nothing -- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? isTypeSynonymTyCon :: TyCon -> Bool -isTypeSynonymTyCon (SynTyCon { synTcRhs = SynonymTyCon {} }) = True -isTypeSynonymTyCon _ = False - --- | Is this 'TyCon' a type synonym or type family? -isSynTyCon :: TyCon -> Bool -isSynTyCon (SynTyCon {}) = True -isSynTyCon _ = False +isTypeSynonymTyCon (SynonymTyCon {}) = True +isTypeSynonymTyCon _ = False -- As for newtypes, it is in some contexts important to distinguish between @@ -1198,8 +1295,9 @@ isDecomposableTyCon :: TyCon -> Bool -- It'd be unusual to call isDecomposableTyCon on a regular H98 -- type synonym, because you should probably have expanded it first -- But regardless, it's not decomposable -isDecomposableTyCon (SynTyCon {}) = False -isDecomposableTyCon _other = True +isDecomposableTyCon (SynonymTyCon {}) = False +isDecomposableTyCon (FamilyTyCon {}) = False +isDecomposableTyCon _other = True -- | Is this an algebraic 'TyCon' declared with the GADT syntax? isGadtSyntaxTyCon :: TyCon -> Bool @@ -1215,42 +1313,36 @@ isEnumerationTyCon _ = False -- | Is this a 'TyCon', synonym or otherwise, that defines a family? isFamilyTyCon :: TyCon -> Bool -isFamilyTyCon (SynTyCon {synTcRhs = OpenSynFamilyTyCon }) = True -isFamilyTyCon (SynTyCon {synTcRhs = ClosedSynFamilyTyCon {} }) = True -isFamilyTyCon (SynTyCon {synTcRhs = AbstractClosedSynFamilyTyCon {} }) = True -isFamilyTyCon (SynTyCon {synTcRhs = BuiltInSynFamTyCon {} }) = True -isFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True -isFamilyTyCon _ = False - --- | Is this a 'TyCon', synonym or otherwise, that defines an family with +isFamilyTyCon (FamilyTyCon {}) = True +isFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True +isFamilyTyCon _ = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family with -- instances? isOpenFamilyTyCon :: TyCon -> Bool -isOpenFamilyTyCon (SynTyCon {synTcRhs = OpenSynFamilyTyCon }) = True -isOpenFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon }) = True -isOpenFamilyTyCon _ = False +isOpenFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True +isOpenFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon }) = True +isOpenFamilyTyCon _ = False -- | Is this a synonym 'TyCon' that can have may have further instances appear? -isSynFamilyTyCon :: TyCon -> Bool -isSynFamilyTyCon (SynTyCon {synTcRhs = OpenSynFamilyTyCon {}}) = True -isSynFamilyTyCon (SynTyCon {synTcRhs = ClosedSynFamilyTyCon {}}) = True -isSynFamilyTyCon (SynTyCon {synTcRhs = AbstractClosedSynFamilyTyCon {}}) = True -isSynFamilyTyCon (SynTyCon {synTcRhs = BuiltInSynFamTyCon {}}) = True -isSynFamilyTyCon _ = False +isTypeFamilyTyCon :: TyCon -> Bool +isTypeFamilyTyCon (FamilyTyCon {}) = True +isTypeFamilyTyCon _ = False -isOpenSynFamilyTyCon :: TyCon -> Bool -isOpenSynFamilyTyCon (SynTyCon {synTcRhs = OpenSynFamilyTyCon }) = True -isOpenSynFamilyTyCon _ = False +isOpenTypeFamilyTyCon :: TyCon -> Bool +isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True +isOpenTypeFamilyTyCon _ = False -- leave out abstract closed families here isClosedSynFamilyTyCon_maybe :: TyCon -> Maybe (CoAxiom Branched) isClosedSynFamilyTyCon_maybe - (SynTyCon {synTcRhs = ClosedSynFamilyTyCon ax}) = Just ax -isClosedSynFamilyTyCon_maybe _ = Nothing + (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon ax}) = Just ax +isClosedSynFamilyTyCon_maybe _ = Nothing isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily isBuiltInSynFamTyCon_maybe - SynTyCon {synTcRhs = BuiltInSynFamTyCon ops } = Just ops -isBuiltInSynFamTyCon_maybe _ = Nothing + (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops +isBuiltInSynFamTyCon_maybe _ = Nothing -- | Is this a synonym 'TyCon' that can have may have further instances appear? isDataFamilyTyCon :: TyCon -> Bool @@ -1357,10 +1449,11 @@ isImplicitTyCon (TupleTyCon {}) = True isImplicitTyCon (PrimTyCon {}) = True isImplicitTyCon (PromotedDataCon {}) = True isImplicitTyCon (PromotedTyCon {}) = True -isImplicitTyCon (AlgTyCon { algTcParent = AssocFamilyTyCon {} }) = True -isImplicitTyCon (AlgTyCon {}) = False -isImplicitTyCon (SynTyCon { synTcParent = AssocFamilyTyCon {} }) = True -isImplicitTyCon (SynTyCon {}) = False +isImplicitTyCon (AlgTyCon { algTcParent = AssocFamilyTyCon {} }) = True +isImplicitTyCon (AlgTyCon {}) = False +isImplicitTyCon (FamilyTyCon { famTcParent = AssocFamilyTyCon {} }) = True +isImplicitTyCon (FamilyTyCon {}) = False +isImplicitTyCon (SynonymTyCon {}) = False tyConCType_maybe :: TyCon -> Maybe CType tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc @@ -1384,8 +1477,8 @@ tcExpandTyCon_maybe, coreExpandTyCon_maybe -- ^ Used to create the view the /typechecker/ has on 'TyCon's. -- We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe' -tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, - synTcRhs = SynonymTyCon rhs }) tys +tcExpandTyCon_maybe (SynonymTyCon { tyConTyVars = tvs + , synTcRhs = rhs }) tys = expand tvs rhs tys tcExpandTyCon_maybe _ _ = Nothing @@ -1411,9 +1504,6 @@ expand tvs rhs tys \end{code} \begin{code} -tyConKind :: TyCon -> Kind -tyConKind = tc_kind - -- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no constructors -- could be found tyConDataCons :: TyCon -> [DataCon] @@ -1452,13 +1542,14 @@ tyConRoles :: TyCon -> [Role] -- See also Note [TyCon Role signatures] tyConRoles tc = case tc of - { FunTyCon {} -> const_role Representational - ; AlgTyCon { tc_roles = roles } -> roles - ; TupleTyCon {} -> const_role Representational - ; SynTyCon { tc_roles = roles } -> roles - ; PrimTyCon { tc_roles = roles } -> roles - ; PromotedDataCon { tc_roles = roles } -> roles - ; PromotedTyCon {} -> const_role Nominal + { FunTyCon {} -> const_role Representational + ; AlgTyCon { tcRoles = roles } -> roles + ; TupleTyCon {} -> const_role Representational + ; SynonymTyCon { tcRoles = roles } -> roles + ; FamilyTyCon {} -> const_role Nominal + ; PrimTyCon { tcRoles = roles } -> roles + ; PromotedDataCon { tcRoles = roles } -> roles + ; PromotedTyCon {} -> const_role Nominal } where const_role r = replicate (tyConArity tc) r @@ -1512,17 +1603,24 @@ tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) \end{code} \begin{code} --- | Extract the 'TyVar's bound by a vanilla type synonym (not familiy) +-- | Extract the 'TyVar's bound by a vanilla type synonym -- and the corresponding (unsubstituted) right hand side. synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) -synTyConDefn_maybe (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty}) +synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty}) = Just (tyvars, ty) synTyConDefn_maybe _ = Nothing --- | Extract the information pertaining to the right hand side of a type synonym (@type@) declaration. -synTyConRhs_maybe :: TyCon -> Maybe SynTyConRhs -synTyConRhs_maybe (SynTyCon {synTcRhs = rhs}) = Just rhs -synTyConRhs_maybe _ = Nothing +-- | Extract the information pertaining to the right hand side of a type synonym +-- (@type@) declaration. +synTyConRhs_maybe :: TyCon -> Maybe Type +synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs +synTyConRhs_maybe _ = Nothing + +-- | Extract the flavour of a type family (with all the extra information that +-- it carries) +famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav +famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav +famTyConFlav_maybe _ = Nothing \end{code} \begin{code} @@ -1562,9 +1660,9 @@ tyConTuple_maybe _ = Nothing ---------------------------------------------------------------------------- tyConParent :: TyCon -> TyConParent -tyConParent (AlgTyCon {algTcParent = parent}) = parent -tyConParent (SynTyCon {synTcParent = parent}) = parent -tyConParent _ = NoParentTyCon +tyConParent (AlgTyCon {algTcParent = parent}) = parent +tyConParent (FamilyTyCon {famTcParent = parent}) = parent +tyConParent _ = NoParentTyCon ---------------------------------------------------------------------------- -- | Is this 'TyCon' that for a data family instance? diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index b73d094a65..4643810a24 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -234,7 +234,8 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls -- warn the user about unvectorised type constructors ; let explanation = ptext (sLit "(They use unsupported language extensions") $$ ptext (sLit "or depend on type constructors that are not vectorised)") - drop_tcs_nosyn = filter (not . isSynTyCon) drop_tcs + drop_tcs_nosyn = filter (not . isTypeFamilyTyCon) . + filter (not . isTypeSynonymTyCon) $ drop_tcs ; unless (null drop_tcs_nosyn) $ emitVt "Warning: cannot vectorise these type constructors:" $ pprQuotedList drop_tcs_nosyn $$ explanation @@ -356,7 +357,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls origName = tyConName origTyCon vectName = tyConName vectTyCon - mkSyn canonName ty = mkSynTyCon canonName (typeKind ty) [] [] (SynonymTyCon ty) NoParentTyCon + mkSyn canonName ty = mkSynonymTyCon canonName (typeKind ty) [] [] ty defDataCons | isAbstract = return () diff --git a/utils/haddock b/utils/haddock -Subproject bf80e2f594777c0c32fae092454bff0c13ae618 +Subproject 19409126be62383bc64d79698b265ffaf96269a |