diff options
Diffstat (limited to 'compiler')
28 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 () |