aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2018-06-14 17:48:00 -0400
committerBen Gamari <ben@smart-cactus.org>2018-06-14 17:48:00 -0400
commit2755526abb478c2f51c9cf4b894de287dd318868 (patch)
treeb8fd99ff255ec3a82f873d84de2b364adc61c7cd
parent97c6cb949ffe707865b9c46016f97b441d114e45 (diff)
Revert unintentional reversion of fix of #548
-rw-r--r--haddock-api/src/Haddock/Convert.hs25
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