[commit: haddock] ghc-head, wip/revert-ttg-2017-11-20, wip/ttg-2017-11-06, wip/ttg2-2017-11-10, wip/ttg3-2017-11-12, wip/ttg4-constraints-2017-11-13: Fix Haddock rendering of kind-indexed data family instances (#694) (3896bff)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/haddock

On branches: ghc-head,wip/revert-ttg-2017-11-20,wip/ttg-2017-11-06,wip/ttg2-2017-11-10,wip/ttg3-2017-11-12,wip/ttg4-constraints-2017-11-13
Link       : http://git.haskell.org/haddock.git/commitdiff/3896bff411596ef50b5ca2f2be425e89878410aa

>---------------------------------------------------------------

commit 3896bff411596ef50b5ca2f2be425e89878410aa
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Fri Oct 27 22:10:27 2017 -0700

    Fix Haddock rendering of kind-indexed data family instances (#694)


>---------------------------------------------------------------

3896bff411596ef50b5ca2f2be425e89878410aa
 haddock-api/src/Haddock/Convert.hs | 28 +++++++++++++++++++++++-----
 1 file changed, 23 insertions(+), 5 deletions(-)

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 325d9cf..96a0855 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -41,7 +41,8 @@ import TysWiredIn ( listTyConName, starKindTyConName, unitTy )
 import PrelNames ( hasKey, eqTyConKey, funTyConKey, ipClassKey
                  , tYPETyConKey, liftedRepDataConKey )
 import Unique ( getUnique )
-import Util ( compareLength, filterByList, filterOut, splitAtList )
+import Util ( chkAppend, compareLength, dropList, filterByList, filterOut
+            , splitAtList )
 import Var
 import VarSet
 
@@ -543,7 +544,7 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead
 -- Convert a family instance, this could be a type family or data family
 synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GhcRn)
 synifyFamInst fi opaque = do
-    ityp' <- ityp $ fi_flavor fi
+    ityp' <- ityp fam_flavor
     return InstHead
         { ihdClsName = fi_fam fi
         , ihdTypes = map unLoc annot_ts
@@ -552,11 +553,28 @@ synifyFamInst fi opaque = do
   where
     ityp SynFamilyInst | opaque = return $ TypeInst Nothing
     ityp SynFamilyInst =
-        return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
+        return . TypeInst . Just . unLoc $ synifyType WithinType fam_rhs
     ityp (DataFamilyInst c) =
         DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c
-    fam_tc = famInstTyCon fi
-    ts = filterOutInvisibleTypes fam_tc $ fi_tys fi
+    fam_tc     = famInstTyCon fi
+    fam_flavor = fi_flavor fi
+    fam_lhs    = fi_tys fi
+    fam_rhs    = fi_rhs fi
+
+    eta_expanded_lhs
+      -- eta-expand lhs types, because sometimes data/newtype
+      -- instances are eta-reduced; See Trac #9692
+      -- See Note [Eta reduction for data family axioms] in TcInstDcls in GHC
+      | DataFamilyInst rep_tc <- fam_flavor
+      = let (_, rep_tc_args) = splitTyConApp fam_rhs
+            etad_tyvars      = dropList rep_tc_args $ tyConTyVars rep_tc
+            etad_tys         = mkTyVarTys etad_tyvars
+            eta_exp_lhs      = fam_lhs `chkAppend` etad_tys
+        in eta_exp_lhs
+      | otherwise
+      = fam_lhs
+
+    ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs
     synifyTypes = map (synifyType WithinType)
     ts' = synifyTypes ts
     annot_ts = zipWith3 annotHsType is_poly_tvs ts ts'