From 60e10eb876899165e9644013508361bf72048bdb Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Tue, 14 Nov 2017 09:21:30 -0500
Subject: Fix #548 by rendering datatype kinds more carefully (#702)

---
 haddock-api/src/Haddock/Convert.hs | 27 ++++++++++++++++++++++++---
 1 file changed, 24 insertions(+), 3 deletions(-)

(limited to 'haddock-api')

diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index fc808568..b712660f 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -164,7 +164,7 @@ synifyTyCon _coax tc
                                                     -- algebraic data nor newtype:
                                       , dd_ctxt = noLoc []
                                       , dd_cType = Nothing
-                                      , dd_kindSig = Just (synifyKindSig (tyConKind tc))
+                                      , dd_kindSig = synifyDataTyConReturnKind tc
                                                -- we have their kind accurately:
                                       , dd_cons = []  -- No constructors
                                       , dd_derivs = noLoc [] }
@@ -219,7 +219,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
@@ -244,7 +244,7 @@ synifyTyCon coax tc
   defn = HsDataDefn { 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
@@ -254,6 +254,27 @@ synifyTyCon coax tc
                  , tcdDataCusk = False, tcdFVs = 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 Name)
+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
-- 
cgit v1.2.3