diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 1f7b70f79243d3cf2109cbaf16af79783d9f96ff..9eb37a9c1e5a852a775a453946311bf507abfdc1 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -316,18 +316,20 @@ repSynDecl tc bndrs ty
; repTySyn tc bndrs ty1 }
repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
-repFamilyDecl (L loc (FamilyDecl { fdInfo = info,
- fdLName = tc,
- fdTyVars = tvs,
- fdKindSig = opt_kind }))
+repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info,
+ fdLName = tc,
+ fdTyVars = tvs,
+ fdKindSig = opt_kind }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; dec <- addTyClTyVarBinds tvs $ \bndrs ->
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
; eqns2 <- coreList tySynEqnQTyConName eqns1
; repClosedFamilyNoKind tc1 bndrs eqns2 }
- (Just ki, ClosedTypeFamily eqns) ->
+ (Just ki, ClosedTypeFamily (Just eqns)) ->
do { eqns1 <- mapM repTyFamEqn eqns
; eqns2 <- coreList tySynEqnQTyConName eqns1
; ki1 <- repLKind ki
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 6c30e2dab30637e258151f864d75c987da15bc34..031a340a0bf87c6e5876d60b42d7dd4c0cef0d84 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -296,14 +296,11 @@ cvtDec (TySynInstD tc eqn)
, tfid_fvs = placeHolderNames } } }
cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns)
- | not $ null eqns
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars
; mkind' <- cvtMaybeKind mkind
; eqns' <- mapM (cvtTySynEqn tc') eqns
; returnJustL $ TyClD $ FamDecl $
- FamilyDecl (ClosedTypeFamily eqns') tc' tvs' mkind' }
- | otherwise
- = failWith (ptext (sLit "Illegal empty closed type family"))
+ FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tvs' mkind' }
cvtDec (TH.RoleAnnotD tc roles)
= do { tc' <- tconNameL tc
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 87c2587049458350955ca8c191b873141fddb26b..48cc8356c4cd7a676eb2508df76198cf9ecd9508 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -557,9 +557,9 @@ deriving instance (DataId id) => Data (FamilyDecl id)
data FamilyInfo name
= DataFamily
| 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 .."
- | ClosedTypeFamily [LTyFamInstEqn name]
+ | ClosedTypeFamily (Maybe [LTyFamInstEqn name])
deriving( Typeable )
deriving instance (DataId name) => Data (FamilyInfo name)
@@ -739,11 +739,12 @@ instance (OutputableBndr name) => Outputable (FamilyDecl name) where
Nothing -> empty
Just kind -> dcolon <+> ppr kind
(pp_where, pp_eqns) = case info of
- ClosedTypeFamily eqns -> ( ptext (sLit "where")
- , if null eqns
- then ptext (sLit "..")
- else vcat $ map ppr_fam_inst_eqn eqns )
- _ -> (empty, empty)
+ ClosedTypeFamily mb_eqns ->
+ ( ptext (sLit "where")
+ , case mb_eqns of
+ Nothing -> ptext (sLit "..")
+ Just eqns -> vcat $ map ppr_fam_inst_eqn eqns )
+ _ -> (empty, empty)
pprFlavour :: FamilyInfo name -> SDoc
pprFlavour DataFamily = ptext (sLit "data family")
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 9a0598ed28b9146c1ab2a23a17ff618a4740543a..0838cb8468436c7b9969730dfeefd7f4706f18ed 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -154,8 +154,9 @@ data IfaceTyConParent
data IfaceFamTyConFlav
= IfaceOpenSynFamilyTyCon
- | IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom
- [IfaceAxBranch] -- for pretty printing purposes only
+ | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch]))
+ -- ^ Name of associated axiom and branches for pretty printing purposes,
+ -- or 'Nothing' for an empty closed family without an axiom
| IfaceAbstractClosedSynFamilyTyCon
| IfaceBuiltInSynFamTyCon -- for pretty printing purposes only
@@ -682,13 +683,16 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
2 (ppr kind <+> ppShowRhs ss (pp_rhs rhs))
, ppShowRhs ss (nest 2 (pp_branches rhs)) ]
where
- pp_rhs IfaceOpenSynFamilyTyCon = ppShowIface ss (ptext (sLit "open"))
- pp_rhs IfaceAbstractClosedSynFamilyTyCon = ppShowIface ss (ptext (sLit "closed, abstract"))
- pp_rhs (IfaceClosedSynFamilyTyCon _ (_:_)) = ptext (sLit "where")
- pp_rhs IfaceBuiltInSynFamTyCon = ppShowIface ss (ptext (sLit "built-in"))
- pp_rhs _ = panic "pprIfaceDecl syn"
-
- pp_branches (IfaceClosedSynFamilyTyCon ax brs)
+ pp_rhs IfaceOpenSynFamilyTyCon
+ = ppShowIface ss (ptext (sLit "open"))
+ pp_rhs IfaceAbstractClosedSynFamilyTyCon
+ = ppShowIface ss (ptext (sLit "closed, abstract"))
+ pp_rhs (IfaceClosedSynFamilyTyCon _)
+ = ptext (sLit "where")
+ pp_rhs IfaceBuiltInSynFamTyCon
+ = ppShowIface ss (ptext (sLit "built-in"))
+
+ pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs)))
= vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs)
$$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax)
pp_branches _ = Outputable.empty
@@ -1090,8 +1094,9 @@ freeNamesIfIdDetails _ = emptyNameSet
-- All other changes are handled via the version info on the tycon
freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet
freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet
-freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon ax br)
+freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br)))
= unitNameSet ax &&& fnList freeNamesIfAxBranch br
+freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet
freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet
@@ -1440,8 +1445,7 @@ instance Binary IfaceDecl 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 (IfaceClosedSynFamilyTyCon mb) = putByte bh 1 >> put_ bh mb
put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2
put_ _ IfaceBuiltInSynFamTyCon
= pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty
@@ -1449,9 +1453,8 @@ instance Binary IfaceFamTyConFlav where
get bh = do { h <- getByte bh
; case h of
0 -> return IfaceOpenSynFamilyTyCon
- 1 -> do { ax <- get bh
- ; br <- get bh
- ; return (IfaceClosedSynFamilyTyCon ax br) }
+ 1 -> do { mb <- get bh
+ ; return (IfaceClosedSynFamilyTyCon mb) }
_ -> return IfaceAbstractClosedSynFamilyTyCon }
instance Binary IfaceClassOp where
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 7e17a13348491174aab670b9438cb63cef710323..49f86fd58b6d30614489c5543f89ad8cef3aac77 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1675,10 +1675,13 @@ tyConToIfaceDecl env tycon
Nothing -> IfNoParent
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
ibr = map (coAxBranchToIfaceBranch' tycon) defs
axn = coAxiomName ax
+ to_if_fam_flav (ClosedSynFamilyTyCon Nothing)
+ = IfaceClosedSynFamilyTyCon Nothing
to_if_fam_flav AbstractClosedSynFamilyTyCon
= IfaceAbstractClosedSynFamilyTyCon
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 40543b711cf8f0a9243740037465f7ff1c22e68a..1beae57cc7c673f14cfc5d50f82831f9f20bdfa1 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -358,8 +358,8 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs,
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
+ tc_fam_flav (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
+ = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches
; return (ClosedSynFamilyTyCon ax) }
tc_fam_flav IfaceAbstractClosedSynFamilyTyCon
= return AbstractClosedSynFamilyTyCon
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 6105cce0ccab5e55b07dc835b527f121d0b29907..961c3a34ccb759df4944789dba2a55c1d03e7386 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -1722,7 +1722,7 @@ extras_plus thing = thing : implicitTyThings thing
implicitCoTyCon :: TyCon -> [TyThing]
implicitCoTyCon tc
| Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co]
- | Just co <- isClosedSynFamilyTyCon_maybe tc
+ | Just co <- isClosedSynFamilyTyConWithAxiom_maybe tc
= [ACoAxiom co]
| otherwise = []
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 48bc637d87a27dc05063fc164402e14152d8c574..f7ca79e94f22b1da31166b7678decab6d4dcc2f9 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1009,17 +1009,17 @@ where_type_family :: { Located ([AddAnn],FamilyInfo RdrName) }
: {- empty -} { noLoc ([],OpenTypeFamily) }
| 'where' ty_fam_inst_eqn_list
{ 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]
- ,unLoc $2) }
+ ,Just (unLoc $2)) }
| 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
- ,mcc $3],[]) }
+ ,mcc $3],Nothing) }
| 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 ';' ty_fam_inst_eqn
@@ -1028,6 +1028,7 @@ ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] }
| ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2)
>> return (sLL $1 $> (unLoc $1)) }
| ty_fam_inst_eqn { sLL $1 $> [$1] }
+ | {- empty -} { noLoc [] }
ty_fam_inst_eqn :: { LTyFamInstEqn RdrName }
: type '=' ctype
diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs
index 19c64ef9cd61062a13070ecd2d30d1ba1d1a9728..d45c6880a07f8993679f1bd3eda85ad414b05202 100644
--- a/compiler/prelude/TysPrim.hs
+++ b/compiler/prelude/TysPrim.hs
@@ -772,7 +772,7 @@ anyTy = mkTyConTy anyTyCon
anyTyCon :: TyCon
anyTyCon = mkFamilyTyCon anyTyConName kind [kKiVar]
- AbstractClosedSynFamilyTyCon
+ (ClosedSynFamilyTyCon Nothing)
NoParentTyCon
where
kind = ForAllTy kKiVar (mkTyVarTy kKiVar)
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 4142188c2f81faa2f70ffb266c56fa95e81e718e..d7c135eabae3118ba1b721c290b45e0c41dcd1a0 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -1214,10 +1214,12 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
fmly_doc = TyFamilyCtx tycon
kvs = extractRdrKindSigVars kind
- rn_info (ClosedTypeFamily eqns)
+ rn_info (ClosedTypeFamily (Just eqns))
= do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
-- 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 DataFamily = return (DataFamily, emptyFVs)
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index f75ca64c25528348c65c8aae3550b2db9a9ee46e..311f7c819550ad1885b049e7a87ba9e774730d48 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1036,8 +1036,11 @@ checkBootTyCon tc1 tc2
pname1 = quotes (ppr name1)
pname2 = quotes (ppr name2)
- eqClosedFamilyAx (CoAxiom { co_ax_branches = branches1 })
- (CoAxiom { co_ax_branches = branches2 })
+ eqClosedFamilyAx Nothing Nothing = True
+ 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
&& (and $ brListZipWith eqClosedFamilyBranch branches1 branches2)
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 544950ef7bd0e6b8779f97a9af7c703edcdb26e6..b73f20b283edc857521a8aa9dd526ee7e90b3de9 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -1336,14 +1336,15 @@ reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
reifyFamFlavour :: TyCon -> TcM (Either TH.FamFlavour [TH.TySynEqn])
reifyFamFlavour tc
| 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
- -- about that now
- | Just ax <- isClosedSynFamilyTyCon_maybe tc
- = do { eqns <- brListMapM reifyAxBranch $ coAxiomBranches ax
- ; return $ Right eqns }
-
+ | isDataFamilyTyCon tc = return $ Left TH.DataFam
+ | Just flav <- famTyConFlav_maybe tc = case flav of
+ OpenSynFamilyTyCon -> return $ Left TH.TypeFam
+ AbstractClosedSynFamilyTyCon -> return $ Right []
+ BuiltInSynFamTyCon _ -> return $ Right []
+ ClosedSynFamilyTyCon Nothing -> return $ Right []
+ ClosedSynFamilyTyCon (Just ax)
+ -> do { eqns <- brListMapM reifyAxBranch $ coAxiomBranches ax
+ ; return $ Right eqns }
| otherwise
= panic "TcSplice.reifyFamFlavour: not a type family"
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 2f9d336dbfb2ad20198254e0217a8c9461c01d8c..6ac87206bd426ccf02179c6602a80000eb4d9c04 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -492,7 +492,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs
-- do anything here
kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name
, fdTyVars = hs_tvs
- , fdInfo = ClosedTypeFamily eqns }))
+ , fdInfo = ClosedTypeFamily (Just eqns) }))
= do { tc_kind <- kcLookupKind fam_tc_name
; let fam_tc_shape = ( fam_tc_name, length (hsQTvBndrs hs_tvs), tc_kind)
; mapM_ (kcTyFamInstEqn fam_tc_shape) eqns }
@@ -673,11 +673,10 @@ tcFamDecl1 parent
; return [ATyCon tycon] }
tcFamDecl1 parent
- (FamilyDecl { fdInfo = ClosedTypeFamily eqns
+ (FamilyDecl { fdInfo = ClosedTypeFamily mb_eqns
, fdLName = lname@(L _ tc_name), fdTyVars = tvs })
-- Closed type families are a little tricky, because they contain the definition
-- 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)
-- the variables in the header have no scope:
; (tvs', kind) <- tcTyClTyVars tc_name tvs $ \ tvs' kind ->
@@ -685,6 +684,14 @@ tcFamDecl1 parent
; 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
; tc_kind <- kcLookupKind tc_name
; let fam_tc_shape = (tc_name, length (hsQTvBndrs tvs), tc_kind)
@@ -705,20 +712,15 @@ tcFamDecl1 parent
; loc <- getSrcSpanM
; co_ax_name <- newFamInstAxiomName loc tc_name []
- -- mkBranchedCoAxiom will fail on an empty list of branches, but
- -- we'll never look at co_ax in this case
- ; let co_ax = mkBranchedCoAxiom co_ax_name fam_tc branches
+ -- mkBranchedCoAxiom will fail on an empty list of branches
+ ; let mb_co_ax
+ | null eqns = Nothing
+ | otherwise = Just $ mkBranchedCoAxiom co_ax_name fam_tc branches
-- now, finally, build the TyCon
- ; let syn_rhs = if null eqns
- then AbstractClosedSynFamilyTyCon
- else ClosedSynFamilyTyCon 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 }
+ ; tycon <- buildFamilyTyCon tc_name tvs'
+ (ClosedSynFamilyTyCon mb_co_ax) kind parent
+ ; return $ ATyCon tycon : maybeToList (fmap ACoAxiom mb_co_ax) } }
-- We check for instance validity later, when doing validity checking for
-- the tycon
@@ -1446,11 +1448,12 @@ checkValidTyCon tc
| Just fam_flav <- famTyConFlav_maybe tc
= case fam_flav of
- { ClosedSynFamilyTyCon ax -> checkValidClosedCoAxiom ax
+ { ClosedSynFamilyTyCon (Just ax) -> checkValidClosedCoAxiom ax
+ ; ClosedSynFamilyTyCon Nothing -> return ()
; AbstractClosedSynFamilyTyCon ->
do { hsBoot <- tcIsHsBootOrSig
; 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") }
; OpenSynFamilyTyCon -> return ()
; BuiltInSynFamTyCon _ -> return () }
diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs
index 72e6490a4bd6af564f70cf7bed065f3bf7820d4a..930d05903ddd6c971b562a2fe9b9b502afa7321c 100644
--- a/compiler/types/FamInstEnv.hs
+++ b/compiler/types/FamInstEnv.hs
@@ -815,7 +815,7 @@ reduceTyFamApp_maybe envs role tc tys
ty = pSnd (coercionKind co)
in Just (co, ty)
- | Just ax <- isClosedSynFamilyTyCon_maybe tc
+ | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc
, Just (ind, inst_tys) <- chooseBranch ax tys
= let co = mkAxInstCo role ax ind inst_tys
ty = pSnd (coercionKind co)
diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs
index 74799b8d2729d8fba7f24fcfb213dda137062729..186134363e8f7dff945cc522ec89b3f539a787eb 100644
--- a/compiler/types/TyCon.hs
+++ b/compiler/types/TyCon.hs
@@ -46,7 +46,7 @@ module TyCon(
isNewTyCon, isAbstractTyCon,
isFamilyTyCon, isOpenFamilyTyCon,
isTypeFamilyTyCon, isDataFamilyTyCon,
- isOpenTypeFamilyTyCon, isClosedSynFamilyTyCon_maybe,
+ isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe,
isBuiltInSynFamTyCon_maybe,
isUnLiftedTyCon,
isGadtSyntaxTyCon, isDistinctTyCon, isDistinctAlgRhs,
@@ -699,8 +699,8 @@ data FamTyConFlav
-- | A closed type synonym family e.g.
-- @type family F x where { F Int = Bool }@
- | ClosedSynFamilyTyCon
- (CoAxiom Branched) -- The one axiom for this family
+ | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched))
+ -- See Note [Closed type families]
-- | A closed type synonym family declared in an hs-boot file with
-- type family F a where ..
@@ -718,6 +718,11 @@ Note [Closed type families]
* In a closed type family you can only put equations where the family
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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1361,11 +1366,12 @@ isOpenTypeFamilyTyCon :: TyCon -> Bool
isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True
isOpenTypeFamilyTyCon _ = False
--- leave out abstract closed families here
-isClosedSynFamilyTyCon_maybe :: TyCon -> Maybe (CoAxiom Branched)
-isClosedSynFamilyTyCon_maybe
- (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon ax}) = Just ax
-isClosedSynFamilyTyCon_maybe _ = Nothing
+-- | Is this a non-empty closed type family? Returns 'Nothing' for
+-- abstract or empty closed families.
+isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched)
+isClosedSynFamilyTyConWithAxiom_maybe
+ (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb
+isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing
isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily
isBuiltInSynFamTyCon_maybe
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 151de0d44c1aca0c2a70857ed3156b7492fbf980..20204ca1644ed0c6f5abe8b77f545951f3f4f262 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -6032,7 +6032,18 @@ type family F a where
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.
+
+
+
+ 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
+ hs-boot file, which uses the syntax
+ where .., as in that case there may or may
+ not be equations given in the hs file.
@@ -6053,6 +6064,7 @@ type family H a where -- OK!
H Bool = Bool
H a = String
type instance H Char = Char -- WRONG: cannot have instances of closed family
+type family K a where -- OK!
type family G a b :: * -> *
type instance G Int = (,) -- WRONG: must be two type parameters
diff --git a/testsuite/tests/indexed-types/should_compile/T9840.hs b/testsuite/tests/indexed-types/should_compile/T9840.hs
new file mode 100644
index 0000000000000000000000000000000000000000..2584be6a99bc916a1a73ac45d5bdcfc62954723d
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T9840.hs
@@ -0,0 +1,12 @@
+{-# 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
diff --git a/testsuite/tests/indexed-types/should_compile/T9840.hs-boot b/testsuite/tests/indexed-types/should_compile/T9840.hs-boot
new file mode 100644
index 0000000000000000000000000000000000000000..36fb05892ecc182563ff0650cb60f27d83b6f131
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T9840.hs-boot
@@ -0,0 +1,10 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module T9840 where
+
+-- X is an abstract type family (it might be empty or not, though it
+-- will turn out to be empty when we check the hs file)
+type family X :: * -> * where ..
+
+-- F is known to be empty in the hs-boot file
+type family F (a :: * -> *) where
diff --git a/testsuite/tests/indexed-types/should_compile/T9840a.hs b/testsuite/tests/indexed-types/should_compile/T9840a.hs
new file mode 100644
index 0000000000000000000000000000000000000000..dab6e044f505dfb3c0836d95b84bd4af8db42145
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T9840a.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module T9840a where
+
+import {-# SOURCE #-} T9840
+
+type family G a where
+
+bar :: X a -> X a
+bar = id
diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T
index 20f2c0a07bf369ff63c4bbab4e72ad7f612c0245..27bb8532b5fced659d5741555c91b4cabdc70a3b 100644
--- a/testsuite/tests/indexed-types/should_compile/all.T
+++ b/testsuite/tests/indexed-types/should_compile/all.T
@@ -249,6 +249,10 @@ test('Sock', normal, compile, [''])
test('T9211', normal, compile, [''])
test('T9747', normal, compile, [''])
test('T9582', normal, compile, [''])
+test('T9840',
+ extra_clean(['T9840.hi-boot', 'T9840.o-boot', 'T9840a.hi', 'T9840a.o']),
+ multimod_compile,
+ ['T9840', '-v0'])
test('T9090', normal, compile, [''])
test('T10020', normal, compile, [''])
test('T10079', normal, compile, [''])
diff --git a/testsuite/tests/indexed-types/should_fail/ClosedFam4.hs b/testsuite/tests/indexed-types/should_fail/ClosedFam4.hs
index 348278ecb29103a16164360e4fb0bf05011ea564..a170cfa2ad857e59755ea5f6086bfed01a0e5a39 100644
--- a/testsuite/tests/indexed-types/should_fail/ClosedFam4.hs
+++ b/testsuite/tests/indexed-types/should_fail/ClosedFam4.hs
@@ -2,4 +2,4 @@
module ClosedFam4 where
-type family Foo a where ..
\ No newline at end of file
+type family Foo a where ..
diff --git a/testsuite/tests/indexed-types/should_fail/ClosedFam4.stderr b/testsuite/tests/indexed-types/should_fail/ClosedFam4.stderr
index 2ba73e19ab384fe1e38dd9422f4e634ed74179c0..ac68f1acde0eed46decd8ab78cd09f52715bbe2e 100644
--- a/testsuite/tests/indexed-types/should_fail/ClosedFam4.stderr
+++ b/testsuite/tests/indexed-types/should_fail/ClosedFam4.stderr
@@ -1,5 +1,5 @@
ClosedFam4.hs:5:1:
- You may omit the equations in a closed type family
+ You may define an abstract closed type family
only in a .hs-boot file
In the type family declaration for ‘Foo’
diff --git a/testsuite/tests/th/T10306.hs b/testsuite/tests/th/T10306.hs
new file mode 100644
index 0000000000000000000000000000000000000000..b93114b61c1b46087bb1ede62e2eb694b75da542
--- /dev/null
+++ b/testsuite/tests/th/T10306.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
+
+module T10306 where
+
+import Language.Haskell.TH
+import GHC.TypeLits
+
+-- Attempting to reify a built-in type family like (+) previously
+-- caused a crash, because it has no equations
+$(do x <- reify ''(+)
+ case x of
+ FamilyI (ClosedTypeFamilyD _ _ _ []) _ -> return []
+ _ -> error $ show x
+ )
diff --git a/testsuite/tests/th/T8028.hs b/testsuite/tests/th/T8028.hs
index fec993a5965a9ea842692d9be3798193cc88f66d..6145428aafecef2fca0b72e1a87e0fb4d8badf40 100644
--- a/testsuite/tests/th/T8028.hs
+++ b/testsuite/tests/th/T8028.hs
@@ -1,7 +1,17 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
module T8028 where
import T8028a
-$(x)
\ No newline at end of file
+import Language.Haskell.TH
+
+$(x)
+
+-- Check that the empty closed type family F produced by $(x) can
+-- subsequently be reified
+$(do f <- reify ''F
+ case f of
+ FamilyI (ClosedTypeFamilyD _ _ _ []) _ -> return []
+ _ -> error $ show f
+ )
diff --git a/testsuite/tests/th/T8028.stderr b/testsuite/tests/th/T8028.stderr
deleted file mode 100644
index 20cf1c7cf25e88dff41656a4a772ea9ec8b8b411..0000000000000000000000000000000000000000
--- a/testsuite/tests/th/T8028.stderr
+++ /dev/null
@@ -1,4 +0,0 @@
-
-T8028.hs:7:3:
- Illegal empty closed type family
- When splicing a TH declaration: type family F_0 where
diff --git a/testsuite/tests/th/TH_abstractFamily.hs b/testsuite/tests/th/TH_abstractFamily.hs
new file mode 100644
index 0000000000000000000000000000000000000000..78d7e43931e1745461ccfafe7f7bd9cb02839286
--- /dev/null
+++ b/testsuite/tests/th/TH_abstractFamily.hs
@@ -0,0 +1,11 @@
+module TH_abstractFamily where
+
+import Language.Haskell.TH
+
+-- Empty closed type families are okay...
+ds1 :: Q [Dec]
+ds1 = [d| type family F a where |]
+
+-- ...but abstract ones should result in a type error
+ds2 :: Q [Dec]
+ds2 = [d| type family G a where .. |]
diff --git a/testsuite/tests/th/TH_abstractFamily.stderr b/testsuite/tests/th/TH_abstractFamily.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..c0aa8d274b71e6dd68a85a98331745342022076e
--- /dev/null
+++ b/testsuite/tests/th/TH_abstractFamily.stderr
@@ -0,0 +1,5 @@
+
+TH_abstractFamily.hs:11:7:
+ abstract closed type family not (yet) handled by Template Haskell
+ type family G a where
+ ..
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 3bc738667d1911ed017afc16df2f189757e7f4b6..b7c241990ab537c4745e0e1dba7d83f11fc6d43c 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -285,7 +285,7 @@ test('ClosedFam2TH', normal, compile, ['-v0'])
test('T8028',
extra_clean(['T8028a.hi', 'T8028a.o']),
- multimod_compile_fail,
+ multimod_compile,
['T8028', '-v0 ' + config.ghc_th_way_flags])
test('TH_Roles1', normal, compile_fail, ['-v0'])
@@ -360,3 +360,6 @@ test('T8624', normal, run_command, ['$MAKE -s --no-print-directory T8624'])
test('TH_Lift', normal, compile, ['-v0'])
test('T10047', normal, ghci_script, ['T10047.script'])
test('T10019', normal, ghci_script, ['T10019.script'])
+test('T10306', normal, compile, ['-v0'])
+
+test('TH_abstractFamily', normal, compile_fail, [''])
diff --git a/utils/haddock b/utils/haddock
index 5bbae8b9bc17d2166c7e03d5f42f2b12fadf70b7..26a590c009005d77fbee9e2c79286bd93f7955f5 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit 5bbae8b9bc17d2166c7e03d5f42f2b12fadf70b7
+Subproject commit 26a590c009005d77fbee9e2c79286bd93f7955f5