Fix #548 by rendering datatype kinds more carefully (#702)

Author: RyanGlScott

.gitignore

@@ -25,5 +25,7 @@ TAGS
 .cabal-sandbox
 .ghc.environment.*
 cabal.sandbox.config
+cabal.project.local
+cabal.project.local~
 
 .stack-work/

haddock-api/src/Haddock/Convert.hs

@@ -155,7 +155,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 [] }
@@ -210,7 +210,7 @@ synifyTyCon coax tc
                            -- CoAxioms, not their TyCons
     _ -> synifyName tc
   tyvars = synifyTyVars (tyConTyVars tc)
-  kindSig = Just (tyConKind tc)
+  kindSig = synifyDataTyConReturnKind tc
   -- The data constructors.
   --
   -- Any data-constructors not exported from the module that *defines* the
@@ -235,7 +235,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
@@ -245,6 +245,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 Name)
 synifyInjectivityAnn Nothing _ _            = Nothing