Revert unintentional reversion of fix of #548

1 files changed, 23 insertions, 2 deletions

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 9979ebb7..3410c7ba 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -222,7 +222,7 @@ synifyTyCon coax tc
                            -- CoAxioms, not their TyCons
     _ -> synifyName tc
   tyvars = synifyTyVars (tyConVisibleTyVars tc)
-  kindSig = Just (tyConKind tc)
+  kindSig = synifyDataTyConReturnKind tc
   -- The data constructors.
   --
   -- Any data-constructors not exported from the module that *defines* the
@@ -248,7 +248,7 @@ synifyTyCon coax tc
                     , dd_ND      = alg_nd
                     , dd_ctxt    = alg_ctx
                     , dd_cType   = Nothing
-                    , dd_kindSig = fmap synifyKindSig kindSig
+                    , dd_kindSig = kindSig
                     , dd_cons    = cons
                     , dd_derivs  = alg_deriv }
  in case lefts consRaw of
@@ -258,6 +258,27 @@ synifyTyCon coax tc
                  , tcdDExt = DataDeclRn False placeHolderNamesTc }
   dataConErrs -> Left $ unlines dataConErrs
 
+-- In this module, every TyCon being considered has come from an interface
+-- file. This means that when considering a data type constructor such as:
+--
+--   data Foo (w :: *) (m :: * -> *) (a :: *)
+--
+-- Then its tyConKind will be (* -> (* -> *) -> * -> *). But beware! We are
+-- also rendering the type variables of Foo, so if we synify the tyConKind of
+-- Foo in full, we will end up displaying this in Haddock:
+--
+--   data Foo (w :: *) (m :: * -> *) (a :: *)
+--     :: * -> (* -> *) -> * -> *
+--
+-- Which is entirely wrong (#548). We only want to display the *return* kind,
+-- which this function obtains.
+synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn)
+synifyDataTyConReturnKind tc
+  = case splitFunTys (tyConKind tc) of
+      (_, ret_kind)
+        | isLiftedTypeKind ret_kind -> Nothing -- Don't bother displaying :: *
+        | otherwise                 -> Just (synifyKindSig ret_kind)
+
 synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity
                      -> Maybe (LInjectivityAnn GhcRn)
 synifyInjectivityAnn Nothing _ _            = Nothing