Commit 4efa4213 authored by Adam Gundry's avatar Adam Gundry

Permit empty closed type families

Fixes #9840 and #10306, and includes an alternative resolution to #8028.
This permits empty closed type families, and documents them in the user
guide. It updates the Haddock submodule to support the API change.

Test Plan: Added `indexed-types/should_compile/T9840` and updated
`indexed-types/should_fail/ClosedFam4` and `th/T8028`.

Reviewers: austin, simonpj, goldfire

Reviewed By: goldfire

Subscribers: bgamari, jstolarek, thomie, goldfire

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

GHC Trac Issues: #9840, #10306
parent 2f6a0ac7
...@@ -316,18 +316,20 @@ repSynDecl tc bndrs ty ...@@ -316,18 +316,20 @@ repSynDecl tc bndrs ty
; repTySyn tc bndrs ty1 } ; repTySyn tc bndrs ty1 }
repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ) repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repFamilyDecl (L loc (FamilyDecl { fdInfo = info, repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info,
fdLName = tc, fdLName = tc,
fdTyVars = tvs, fdTyVars = tvs,
fdKindSig = opt_kind })) fdKindSig = opt_kind }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; dec <- addTyClTyVarBinds tvs $ \bndrs -> ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
case (opt_kind, info) of case (opt_kind, info) of
(Nothing, ClosedTypeFamily eqns) -> (_ , ClosedTypeFamily Nothing) ->
notHandled "abstract closed type family" (ppr decl)
(Nothing, ClosedTypeFamily (Just eqns)) ->
do { eqns1 <- mapM repTyFamEqn eqns do { eqns1 <- mapM repTyFamEqn eqns
; eqns2 <- coreList tySynEqnQTyConName eqns1 ; eqns2 <- coreList tySynEqnQTyConName eqns1
; repClosedFamilyNoKind tc1 bndrs eqns2 } ; repClosedFamilyNoKind tc1 bndrs eqns2 }
(Just ki, ClosedTypeFamily eqns) -> (Just ki, ClosedTypeFamily (Just eqns)) ->
do { eqns1 <- mapM repTyFamEqn eqns do { eqns1 <- mapM repTyFamEqn eqns
; eqns2 <- coreList tySynEqnQTyConName eqns1 ; eqns2 <- coreList tySynEqnQTyConName eqns1
; ki1 <- repLKind ki ; ki1 <- repLKind ki
......
...@@ -296,14 +296,11 @@ cvtDec (TySynInstD tc eqn) ...@@ -296,14 +296,11 @@ cvtDec (TySynInstD tc eqn)
, tfid_fvs = placeHolderNames } } } , tfid_fvs = placeHolderNames } } }
cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns) cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns)
| not $ null eqns
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars
; mkind' <- cvtMaybeKind mkind ; mkind' <- cvtMaybeKind mkind
; eqns' <- mapM (cvtTySynEqn tc') eqns ; eqns' <- mapM (cvtTySynEqn tc') eqns
; returnJustL $ TyClD $ FamDecl $ ; returnJustL $ TyClD $ FamDecl $
FamilyDecl (ClosedTypeFamily eqns') tc' tvs' mkind' } FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tvs' mkind' }
| otherwise
= failWith (ptext (sLit "Illegal empty closed type family"))
cvtDec (TH.RoleAnnotD tc roles) cvtDec (TH.RoleAnnotD tc roles)
= do { tc' <- tconNameL tc = do { tc' <- tconNameL tc
......
...@@ -557,9 +557,9 @@ deriving instance (DataId id) => Data (FamilyDecl id) ...@@ -557,9 +557,9 @@ deriving instance (DataId id) => Data (FamilyDecl id)
data FamilyInfo name data FamilyInfo name
= DataFamily = DataFamily
| OpenTypeFamily | OpenTypeFamily
-- this list might be empty, if we're in an hs-boot file and the user -- | 'Nothing' if we're in an hs-boot file and the user
-- said "type family Foo x where .." -- said "type family Foo x where .."
| ClosedTypeFamily [LTyFamInstEqn name] | ClosedTypeFamily (Maybe [LTyFamInstEqn name])
deriving( Typeable ) deriving( Typeable )
deriving instance (DataId name) => Data (FamilyInfo name) deriving instance (DataId name) => Data (FamilyInfo name)
...@@ -739,11 +739,12 @@ instance (OutputableBndr name) => Outputable (FamilyDecl name) where ...@@ -739,11 +739,12 @@ instance (OutputableBndr name) => Outputable (FamilyDecl name) where
Nothing -> empty Nothing -> empty
Just kind -> dcolon <+> ppr kind Just kind -> dcolon <+> ppr kind
(pp_where, pp_eqns) = case info of (pp_where, pp_eqns) = case info of
ClosedTypeFamily eqns -> ( ptext (sLit "where") ClosedTypeFamily mb_eqns ->
, if null eqns ( ptext (sLit "where")
then ptext (sLit "..") , case mb_eqns of
else vcat $ map ppr_fam_inst_eqn eqns ) Nothing -> ptext (sLit "..")
_ -> (empty, empty) Just eqns -> vcat $ map ppr_fam_inst_eqn eqns )
_ -> (empty, empty)
pprFlavour :: FamilyInfo name -> SDoc pprFlavour :: FamilyInfo name -> SDoc
pprFlavour DataFamily = ptext (sLit "data family") pprFlavour DataFamily = ptext (sLit "data family")
......
...@@ -154,8 +154,9 @@ data IfaceTyConParent ...@@ -154,8 +154,9 @@ data IfaceTyConParent
data IfaceFamTyConFlav data IfaceFamTyConFlav
= IfaceOpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
| IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch]))
[IfaceAxBranch] -- for pretty printing purposes only -- ^ Name of associated axiom and branches for pretty printing purposes,
-- or 'Nothing' for an empty closed family without an axiom
| IfaceAbstractClosedSynFamilyTyCon | IfaceAbstractClosedSynFamilyTyCon
| IfaceBuiltInSynFamTyCon -- for pretty printing purposes only | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only
...@@ -682,13 +683,16 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars ...@@ -682,13 +683,16 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
2 (ppr kind <+> ppShowRhs ss (pp_rhs rhs)) 2 (ppr kind <+> ppShowRhs ss (pp_rhs rhs))
, ppShowRhs ss (nest 2 (pp_branches rhs)) ] , ppShowRhs ss (nest 2 (pp_branches rhs)) ]
where where
pp_rhs IfaceOpenSynFamilyTyCon = ppShowIface ss (ptext (sLit "open")) pp_rhs IfaceOpenSynFamilyTyCon
pp_rhs IfaceAbstractClosedSynFamilyTyCon = ppShowIface ss (ptext (sLit "closed, abstract")) = ppShowIface ss (ptext (sLit "open"))
pp_rhs (IfaceClosedSynFamilyTyCon _ (_:_)) = ptext (sLit "where") pp_rhs IfaceAbstractClosedSynFamilyTyCon
pp_rhs IfaceBuiltInSynFamTyCon = ppShowIface ss (ptext (sLit "built-in")) = ppShowIface ss (ptext (sLit "closed, abstract"))
pp_rhs _ = panic "pprIfaceDecl syn" pp_rhs (IfaceClosedSynFamilyTyCon _)
= ptext (sLit "where")
pp_branches (IfaceClosedSynFamilyTyCon ax brs) pp_rhs IfaceBuiltInSynFamTyCon
= ppShowIface ss (ptext (sLit "built-in"))
pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs)))
= vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs) = vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs)
$$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax) $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax)
pp_branches _ = Outputable.empty pp_branches _ = Outputable.empty
...@@ -1090,8 +1094,9 @@ freeNamesIfIdDetails _ = emptyNameSet ...@@ -1090,8 +1094,9 @@ freeNamesIfIdDetails _ = emptyNameSet
-- All other changes are handled via the version info on the tycon -- All other changes are handled via the version info on the tycon
freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet
freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon ax br) freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br)))
= unitNameSet ax &&& fnList freeNamesIfAxBranch br = unitNameSet ax &&& fnList freeNamesIfAxBranch br
freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet
freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
...@@ -1440,8 +1445,7 @@ instance Binary IfaceDecl where ...@@ -1440,8 +1445,7 @@ instance Binary IfaceDecl where
instance Binary IfaceFamTyConFlav where instance Binary IfaceFamTyConFlav where
put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0 put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0
put_ bh (IfaceClosedSynFamilyTyCon ax br) = putByte bh 1 >> put_ bh ax put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 1 >> put_ bh mb
>> put_ bh br
put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2 put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2
put_ _ IfaceBuiltInSynFamTyCon put_ _ IfaceBuiltInSynFamTyCon
= pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty
...@@ -1449,9 +1453,8 @@ instance Binary IfaceFamTyConFlav where ...@@ -1449,9 +1453,8 @@ instance Binary IfaceFamTyConFlav where
get bh = do { h <- getByte bh get bh = do { h <- getByte bh
; case h of ; case h of
0 -> return IfaceOpenSynFamilyTyCon 0 -> return IfaceOpenSynFamilyTyCon
1 -> do { ax <- get bh 1 -> do { mb <- get bh
; br <- get bh ; return (IfaceClosedSynFamilyTyCon mb) }
; return (IfaceClosedSynFamilyTyCon ax br) }
_ -> return IfaceAbstractClosedSynFamilyTyCon } _ -> return IfaceAbstractClosedSynFamilyTyCon }
instance Binary IfaceClassOp where instance Binary IfaceClassOp where
......
...@@ -1675,10 +1675,13 @@ tyConToIfaceDecl env tycon ...@@ -1675,10 +1675,13 @@ tyConToIfaceDecl env tycon
Nothing -> IfNoParent Nothing -> IfNoParent
to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
to_if_fam_flav (ClosedSynFamilyTyCon ax) = IfaceClosedSynFamilyTyCon axn ibr to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))
= IfaceClosedSynFamilyTyCon (Just (axn, ibr))
where defs = fromBranchList $ coAxiomBranches ax where defs = fromBranchList $ coAxiomBranches ax
ibr = map (coAxBranchToIfaceBranch' tycon) defs ibr = map (coAxBranchToIfaceBranch' tycon) defs
axn = coAxiomName ax axn = coAxiomName ax
to_if_fam_flav (ClosedSynFamilyTyCon Nothing)
= IfaceClosedSynFamilyTyCon Nothing
to_if_fam_flav AbstractClosedSynFamilyTyCon to_if_fam_flav AbstractClosedSynFamilyTyCon
= IfaceAbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon
......
...@@ -358,8 +358,8 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs, ...@@ -358,8 +358,8 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs,
where where
mk_doc n = ptext (sLit "Type synonym") <+> ppr n mk_doc n = ptext (sLit "Type synonym") <+> ppr n
tc_fam_flav IfaceOpenSynFamilyTyCon = return OpenSynFamilyTyCon tc_fam_flav IfaceOpenSynFamilyTyCon = return OpenSynFamilyTyCon
tc_fam_flav (IfaceClosedSynFamilyTyCon ax_name _) tc_fam_flav (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
= do { ax <- tcIfaceCoAxiom ax_name = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches
; return (ClosedSynFamilyTyCon ax) } ; return (ClosedSynFamilyTyCon ax) }
tc_fam_flav IfaceAbstractClosedSynFamilyTyCon tc_fam_flav IfaceAbstractClosedSynFamilyTyCon
= return AbstractClosedSynFamilyTyCon = return AbstractClosedSynFamilyTyCon
......
...@@ -1722,7 +1722,7 @@ extras_plus thing = thing : implicitTyThings thing ...@@ -1722,7 +1722,7 @@ extras_plus thing = thing : implicitTyThings thing
implicitCoTyCon :: TyCon -> [TyThing] implicitCoTyCon :: TyCon -> [TyThing]
implicitCoTyCon tc implicitCoTyCon tc
| Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co] | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co]
| Just co <- isClosedSynFamilyTyCon_maybe tc | Just co <- isClosedSynFamilyTyConWithAxiom_maybe tc
= [ACoAxiom co] = [ACoAxiom co]
| otherwise = [] | otherwise = []
......
...@@ -1009,17 +1009,17 @@ where_type_family :: { Located ([AddAnn],FamilyInfo RdrName) } ...@@ -1009,17 +1009,17 @@ where_type_family :: { Located ([AddAnn],FamilyInfo RdrName) }
: {- empty -} { noLoc ([],OpenTypeFamily) } : {- empty -} { noLoc ([],OpenTypeFamily) }
| 'where' ty_fam_inst_eqn_list | 'where' ty_fam_inst_eqn_list
{ sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)
,ClosedTypeFamily (reverse (snd $ unLoc $2))) } ,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) }
ty_fam_inst_eqn_list :: { Located ([AddAnn],[LTyFamInstEqn RdrName]) } ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn RdrName]) }
: '{' ty_fam_inst_eqns '}' { sLL $1 $> ([moc $1,mcc $3] : '{' ty_fam_inst_eqns '}' { sLL $1 $> ([moc $1,mcc $3]
,unLoc $2) } ,Just (unLoc $2)) }
| vocurly ty_fam_inst_eqns close { let L loc _ = $2 in | vocurly ty_fam_inst_eqns close { let L loc _ = $2 in
L loc ([],unLoc $2) } L loc ([],Just (unLoc $2)) }
| '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2 | '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2
,mcc $3],[]) } ,mcc $3],Nothing) }
| vocurly '..' close { let L loc _ = $2 in | vocurly '..' close { let L loc _ = $2 in
L loc ([mj AnnDotdot $2],[]) } L loc ([mj AnnDotdot $2],Nothing) }
ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] } ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] }
: ty_fam_inst_eqns ';' ty_fam_inst_eqn : ty_fam_inst_eqns ';' ty_fam_inst_eqn
...@@ -1028,6 +1028,7 @@ ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] } ...@@ -1028,6 +1028,7 @@ ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] }
| ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2) | ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2)
>> return (sLL $1 $> (unLoc $1)) } >> return (sLL $1 $> (unLoc $1)) }
| ty_fam_inst_eqn { sLL $1 $> [$1] } | ty_fam_inst_eqn { sLL $1 $> [$1] }
| {- empty -} { noLoc [] }
ty_fam_inst_eqn :: { LTyFamInstEqn RdrName } ty_fam_inst_eqn :: { LTyFamInstEqn RdrName }
: type '=' ctype : type '=' ctype
......
...@@ -772,7 +772,7 @@ anyTy = mkTyConTy anyTyCon ...@@ -772,7 +772,7 @@ anyTy = mkTyConTy anyTyCon
anyTyCon :: TyCon anyTyCon :: TyCon
anyTyCon = mkFamilyTyCon anyTyConName kind [kKiVar] anyTyCon = mkFamilyTyCon anyTyConName kind [kKiVar]
AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon Nothing)
NoParentTyCon NoParentTyCon
where where
kind = ForAllTy kKiVar (mkTyVarTy kKiVar) kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
......
...@@ -1214,10 +1214,12 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars ...@@ -1214,10 +1214,12 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
fmly_doc = TyFamilyCtx tycon fmly_doc = TyFamilyCtx tycon
kvs = extractRdrKindSigVars kind kvs = extractRdrKindSigVars kind
rn_info (ClosedTypeFamily eqns) rn_info (ClosedTypeFamily (Just eqns))
= do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
-- no class context, -- no class context,
; return (ClosedTypeFamily eqns', fvs) } ; return (ClosedTypeFamily (Just eqns'), fvs) }
rn_info (ClosedTypeFamily Nothing)
= return (ClosedTypeFamily Nothing, emptyFVs)
rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs) rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
rn_info DataFamily = return (DataFamily, emptyFVs) rn_info DataFamily = return (DataFamily, emptyFVs)
......
...@@ -1036,8 +1036,11 @@ checkBootTyCon tc1 tc2 ...@@ -1036,8 +1036,11 @@ checkBootTyCon tc1 tc2
pname1 = quotes (ppr name1) pname1 = quotes (ppr name1)
pname2 = quotes (ppr name2) pname2 = quotes (ppr name2)
eqClosedFamilyAx (CoAxiom { co_ax_branches = branches1 }) eqClosedFamilyAx Nothing Nothing = True
(CoAxiom { co_ax_branches = branches2 }) eqClosedFamilyAx Nothing (Just _) = False
eqClosedFamilyAx (Just _) Nothing = False
eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 }))
(Just (CoAxiom { co_ax_branches = branches2 }))
= brListLength branches1 == brListLength branches2 = brListLength branches1 == brListLength branches2
&& (and $ brListZipWith eqClosedFamilyBranch branches1 branches2) && (and $ brListZipWith eqClosedFamilyBranch branches1 branches2)
......
...@@ -1336,14 +1336,15 @@ reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) ...@@ -1336,14 +1336,15 @@ reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
reifyFamFlavour :: TyCon -> TcM (Either TH.FamFlavour [TH.TySynEqn]) reifyFamFlavour :: TyCon -> TcM (Either TH.FamFlavour [TH.TySynEqn])
reifyFamFlavour tc reifyFamFlavour tc
| isOpenTypeFamilyTyCon tc = return $ Left TH.TypeFam | isOpenTypeFamilyTyCon tc = return $ Left TH.TypeFam
| isDataFamilyTyCon tc = return $ Left TH.DataFam | isDataFamilyTyCon tc = return $ Left TH.DataFam
| Just flav <- famTyConFlav_maybe tc = case flav of
-- this doesn't really handle abstract closed families, but let's not worry OpenSynFamilyTyCon -> return $ Left TH.TypeFam
-- about that now AbstractClosedSynFamilyTyCon -> return $ Right []
| Just ax <- isClosedSynFamilyTyCon_maybe tc BuiltInSynFamTyCon _ -> return $ Right []
= do { eqns <- brListMapM reifyAxBranch $ coAxiomBranches ax ClosedSynFamilyTyCon Nothing -> return $ Right []
; return $ Right eqns } ClosedSynFamilyTyCon (Just ax)
-> do { eqns <- brListMapM reifyAxBranch $ coAxiomBranches ax
; return $ Right eqns }
| otherwise | otherwise
= panic "TcSplice.reifyFamFlavour: not a type family" = panic "TcSplice.reifyFamFlavour: not a type family"
......
...@@ -492,7 +492,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs ...@@ -492,7 +492,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs
-- do anything here -- do anything here
kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name
, fdTyVars = hs_tvs , fdTyVars = hs_tvs
, fdInfo = ClosedTypeFamily eqns })) , fdInfo = ClosedTypeFamily (Just eqns) }))
= do { tc_kind <- kcLookupKind fam_tc_name = do { tc_kind <- kcLookupKind fam_tc_name
; let fam_tc_shape = ( fam_tc_name, length (hsQTvBndrs hs_tvs), tc_kind) ; let fam_tc_shape = ( fam_tc_name, length (hsQTvBndrs hs_tvs), tc_kind)
; mapM_ (kcTyFamInstEqn fam_tc_shape) eqns } ; mapM_ (kcTyFamInstEqn fam_tc_shape) eqns }
...@@ -673,11 +673,10 @@ tcFamDecl1 parent ...@@ -673,11 +673,10 @@ tcFamDecl1 parent
; return [ATyCon tycon] } ; return [ATyCon tycon] }
tcFamDecl1 parent tcFamDecl1 parent
(FamilyDecl { fdInfo = ClosedTypeFamily eqns (FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns
, fdLName = lname@(L _ tc_name), fdTyVars = tvs }) , fdLName = lname@(L _ tc_name), fdTyVars = tvs })
-- Closed type families are a little tricky, because they contain the definition -- Closed type families are a little tricky, because they contain the definition
-- of both the type family and the equations for a CoAxiom. -- of both the type family and the equations for a CoAxiom.
-- Note: eqns might be empty, in a hs-boot file!
= do { traceTc "closed type family:" (ppr tc_name) = do { traceTc "closed type family:" (ppr tc_name)
-- the variables in the header have no scope: -- the variables in the header have no scope:
; (tvs', kind) <- tcTyClTyVars tc_name tvs $ \ tvs' kind -> ; (tvs', kind) <- tcTyClTyVars tc_name tvs $ \ tvs' kind ->
...@@ -685,6 +684,14 @@ tcFamDecl1 parent ...@@ -685,6 +684,14 @@ tcFamDecl1 parent
; checkFamFlag tc_name -- make sure we have -XTypeFamilies ; checkFamFlag tc_name -- make sure we have -XTypeFamilies
-- If Nothing, this is an abstract family in a hs-boot file;
-- but eqns might be empty in the Just case as well
; case mb_eqns of
Nothing -> do { tycon <- buildFamilyTyCon tc_name tvs'
AbstractClosedSynFamilyTyCon kind parent
; return [ATyCon tycon] }
Just eqns -> do {
-- Process the equations, creating CoAxBranches -- Process the equations, creating CoAxBranches
; tc_kind <- kcLookupKind tc_name ; tc_kind <- kcLookupKind tc_name
; let fam_tc_shape = (tc_name, length (hsQTvBndrs tvs), tc_kind) ; let fam_tc_shape = (tc_name, length (hsQTvBndrs tvs), tc_kind)
...@@ -705,20 +712,15 @@ tcFamDecl1 parent ...@@ -705,20 +712,15 @@ tcFamDecl1 parent
; loc <- getSrcSpanM ; loc <- getSrcSpanM
; co_ax_name <- newFamInstAxiomName loc tc_name [] ; co_ax_name <- newFamInstAxiomName loc tc_name []
-- mkBranchedCoAxiom will fail on an empty list of branches, but -- mkBranchedCoAxiom will fail on an empty list of branches
-- we'll never look at co_ax in this case ; let mb_co_ax
; let co_ax = mkBranchedCoAxiom co_ax_name fam_tc branches | null eqns = Nothing
| otherwise = Just $ mkBranchedCoAxiom co_ax_name fam_tc branches
-- now, finally, build the TyCon -- now, finally, build the TyCon
; let syn_rhs = if null eqns ; tycon <- buildFamilyTyCon tc_name tvs'
then AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon mb_co_ax) kind parent
else ClosedSynFamilyTyCon co_ax ; return $ ATyCon tycon : maybeToList (fmap ACoAxiom mb_co_ax) } }
; tycon <- buildFamilyTyCon tc_name tvs' syn_rhs kind parent
; let result = if null eqns
then [ATyCon tycon]
else [ATyCon tycon, ACoAxiom co_ax]
; return result }
-- We check for instance validity later, when doing validity checking for -- We check for instance validity later, when doing validity checking for
-- the tycon -- the tycon
...@@ -1446,11 +1448,12 @@ checkValidTyCon tc ...@@ -1446,11 +1448,12 @@ checkValidTyCon tc
| Just fam_flav <- famTyConFlav_maybe tc | Just fam_flav <- famTyConFlav_maybe tc
= case fam_flav of = case fam_flav of
{ ClosedSynFamilyTyCon ax -> checkValidClosedCoAxiom ax { ClosedSynFamilyTyCon (Just ax) -> checkValidClosedCoAxiom ax
; ClosedSynFamilyTyCon Nothing -> return ()
; AbstractClosedSynFamilyTyCon -> ; AbstractClosedSynFamilyTyCon ->
do { hsBoot <- tcIsHsBootOrSig do { hsBoot <- tcIsHsBootOrSig
; checkTc hsBoot $ ; checkTc hsBoot $
ptext (sLit "You may omit the equations in a closed type family") $$ ptext (sLit "You may define an abstract closed type family") $$
ptext (sLit "only in a .hs-boot file") } ptext (sLit "only in a .hs-boot file") }
; OpenSynFamilyTyCon -> return () ; OpenSynFamilyTyCon -> return ()
; BuiltInSynFamTyCon _ -> return () } ; BuiltInSynFamTyCon _ -> return () }
......
...@@ -815,7 +815,7 @@ reduceTyFamApp_maybe envs role tc tys ...@@ -815,7 +815,7 @@ reduceTyFamApp_maybe envs role tc tys
ty = pSnd (coercionKind co) ty = pSnd (coercionKind co)
in Just (co, ty) in Just (co, ty)
| Just ax <- isClosedSynFamilyTyCon_maybe tc | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc
, Just (ind, inst_tys) <- chooseBranch ax tys , Just (ind, inst_tys) <- chooseBranch ax tys
= let co = mkAxInstCo role ax ind inst_tys = let co = mkAxInstCo role ax ind inst_tys
ty = pSnd (coercionKind co) ty = pSnd (coercionKind co)
......
...@@ -46,7 +46,7 @@ module TyCon( ...@@ -46,7 +46,7 @@ module TyCon(
isNewTyCon, isAbstractTyCon, isNewTyCon, isAbstractTyCon,
isFamilyTyCon, isOpenFamilyTyCon, isFamilyTyCon, isOpenFamilyTyCon,
isTypeFamilyTyCon, isDataFamilyTyCon, isTypeFamilyTyCon, isDataFamilyTyCon,
isOpenTypeFamilyTyCon, isClosedSynFamilyTyCon_maybe, isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe,
isBuiltInSynFamTyCon_maybe, isBuiltInSynFamTyCon_maybe,
isUnLiftedTyCon, isUnLiftedTyCon,
isGadtSyntaxTyCon, isDistinctTyCon, isDistinctAlgRhs, isGadtSyntaxTyCon, isDistinctTyCon, isDistinctAlgRhs,
...@@ -699,8 +699,8 @@ data FamTyConFlav ...@@ -699,8 +699,8 @@ data FamTyConFlav
-- | A closed type synonym family e.g. -- | A closed type synonym family e.g.
-- @type family F x where { F Int = Bool }@ -- @type family F x where { F Int = Bool }@
| ClosedSynFamilyTyCon | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched))
(CoAxiom Branched) -- The one axiom for this family -- See Note [Closed type families]
-- | A closed type synonym family declared in an hs-boot file with -- | A closed type synonym family declared in an hs-boot file with
-- type family F a where .. -- type family F a where ..
...@@ -718,6 +718,11 @@ Note [Closed type families] ...@@ -718,6 +718,11 @@ Note [Closed type families]
* In a closed type family you can only put equations where the family * In a closed type family you can only put equations where the family
is defined. is defined.
A non-empty closed type family has a single axiom with multiple
branches, stored in the 'ClosedSynFamilyTyCon' constructor. A closed
type family with no equations does not have an axiom, because there is
nothing for the axiom to prove!
Note [Promoted data constructors] Note [Promoted data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -1361,11 +1366,12 @@ isOpenTypeFamilyTyCon :: TyCon -> Bool ...@@ -1361,11 +1366,12 @@ isOpenTypeFamilyTyCon :: TyCon -> Bool
isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True
isOpenTypeFamilyTyCon _ = False isOpenTypeFamilyTyCon _ = False
-- leave out abstract closed families here -- | Is this a non-empty closed type family? Returns 'Nothing' for
isClosedSynFamilyTyCon_maybe :: TyCon -> Maybe (CoAxiom Branched) -- abstract or empty closed families.
isClosedSynFamilyTyCon_maybe isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched)
(FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon ax}) = Just ax isClosedSynFamilyTyConWithAxiom_maybe
isClosedSynFamilyTyCon_maybe _ = Nothing (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb
isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing
isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily
isBuiltInSynFamTyCon_maybe isBuiltInSynFamTyCon_maybe
......
...@@ -6032,7 +6032,18 @@ type family F a where ...@@ -6032,7 +6032,18 @@ type family F a where
<para> <para>
A closed type family's equations have the same restrictions as the A closed type family's equations have the same restrictions as the
equations for an open type family instances. equations for open type family instances.
</para>
<para>
A closed type family may be declared with no equations. Such
closed type families are opaque type-level definitions that will
never reduce, are not necessarily injective (unlike empty data
types), and cannot be given any instances. This is different
from omitting the equations of a closed type family in a
<filename>hs-boot</filename> file, which uses the syntax
<literal>where ..</literal>, as in that case there may or may
not be equations given in the <filename>hs</filename> file.
</para> </para>
</sect3> </sect3>
...@@ -6053,6 +6064,7 @@ type family H a where -- OK! ...@@ -6053,6 +6064,7 @@ type family H a where -- OK!
H Bool = Bool H Bool = Bool
H a = String H a = String
type instance H Char = Char -- WRONG: cannot have instances of closed family type instance H Char = Char -- WRONG: cannot have instances of closed family
type family K a where -- OK!
type family G a b :: * -> * type family G a b :: * -> *
type instance G Int = (,) -- WRONG: must be two type parameters type instance G Int = (,) -- WRONG: must be two type parameters
......
{-# LANGUAGE TypeFamilies #-}
module T9840 where
import T9840a
type family X :: * -> * where
type family F (a :: * -> *) where
foo :: G (F X) -> G (F X)
foo x = x