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')

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