From 2a5fc0ad50c857098558461434c29abd478ea0a1 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Wed, 23 Oct 2019 09:42:20 -0400
Subject: Reify oversaturated data family instances correctly (#1103)
This fixes #1103 by adapting the corresponding patch for GHC (see
https://gitlab.haskell.org/ghc/ghc/issues/17296 and
https://gitlab.haskell.org/ghc/ghc/merge_requests/1877).
---
haddock-api/src/Haddock/Convert.hs | 38 +++++++++++++++++++++++---------------
1 file changed, 23 insertions(+), 15 deletions(-)
(limited to 'haddock-api/src/Haddock')
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index d22efc9a..5dc3a508 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -150,8 +150,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
= let name = synifyName tc
args_types_only = filterOutInvisibleTypes tc args
typats = map (synifyType WithinType []) args_types_only
- annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs)
- args_types_only typats
+ annot_typats = zipWith3 annotHsType args_poly args_types_only typats
hs_rhs = synifyType WithinType [] rhs
in HsIB { hsib_ext = map tyVarName tkvs
, hsib_body = FamEqn { feqn_ext = noExt
@@ -162,7 +161,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })
, feqn_fixity = synifyFixity name
, feqn_rhs = hs_rhs } }
where
- fam_tvs = tyConVisibleTyVars tc
+ args_poly = tyConArgsPolyKinded tc
synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn)
synifyAxiom ax@(CoAxiom { co_ax_tc = tc })
@@ -472,17 +471,26 @@ annotHsType True ty hs_ty
in noLoc (HsKindSig noExt hs_ty hs_ki)
annotHsType _ _ hs_ty = hs_ty
--- | For every type variable in the input,
--- report whether or not the tv is poly-kinded. This is used to eventually
--- feed into 'annotHsType'.
-mkIsPolyTvs :: [TyVar] -> [Bool]
-mkIsPolyTvs = map is_poly_tv
+-- | For every argument type that a type constructor accepts,
+-- report whether or not the argument is poly-kinded. This is used to
+-- eventually feed into 'annotThType'.
+tyConArgsPolyKinded :: TyCon -> [Bool]
+tyConArgsPolyKinded tc =
+ map (is_poly_ty . tyVarKind) tc_vis_tvs
+ ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs
+ ++ repeat True
where
- is_poly_tv tv = not $
+ is_poly_ty :: Type -> Bool
+ is_poly_ty ty = not $
isEmptyVarSet $
filterVarSet isTyVar $
- tyCoVarsOfType $
- tyVarKind tv
+ tyCoVarsOfType ty
+
+ tc_vis_tvs :: [TyVar]
+ tc_vis_tvs = tyConVisibleTyVars tc
+
+ tc_res_kind_vis_bndrs :: [TyCoBinder]
+ tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc
--states of what to do with foralls:
data SynifyTypeState
@@ -787,8 +795,8 @@ synifyInstHead (vs, preds, cls, types) = specializeInstHead $ InstHead
cls_tycon = classTyCon cls
ts = filterOutInvisibleTypes cls_tycon types
ts' = map (synifyType WithinType vs) ts
- annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'
- is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon)
+ annot_ts = zipWith3 annotHsType args_poly ts ts'
+ args_poly = tyConArgsPolyKinded cls_tycon
synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs
-- Convert a family instance, this could be a type family or data family
@@ -827,8 +835,8 @@ synifyFamInst fi opaque = do
ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs
synifyTypes = map (synifyType WithinType [])
ts' = synifyTypes ts
- annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'
- is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc)
+ annot_ts = zipWith3 annotHsType args_poly ts ts'
+ args_poly = tyConArgsPolyKinded fam_tc
{-
Note [Invariant: Never expand type synonyms]
--
cgit v1.2.3