diff options
Diffstat (limited to 'haddock-api')
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 27 |
1 files changed, 24 insertions, 3 deletions
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 |