From d4375d8ec96991de2578fd65c79d0487f6a440d8 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Tue, 24 Oct 2017 07:07:15 -0400 Subject: Overhaul Haddock's rendering of kind signatures (#681) * Overhaul Haddock's rendering of kind signatures * Strip off kind signatures when specializing As an added bonus, this lets us remove an ugly hack specifically for `(->)`. Yay! * Update due to 0390e4a0f61e37bd1dcc24a36d499e92f2561b67 * @alexbiehl's suggestions * Import injectiveVarsOfBinder from GHC --- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) (limited to 'haddock-api/src/Haddock/Backends/Xhtml') diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 3b53b1eb..3b85f96c 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -286,7 +286,7 @@ ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI -> Html ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) = ppFamilyInfo True pfdInfo <+> - ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+> + ppAppNameTypes (unLoc pfdLName) (map unLoc pfdTyVars) unicode qual <+> ppResultSig (unLoc pfdKindSig) unicode qual ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocNameI -> Html @@ -321,7 +321,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode ppTyFamEqn :: TyFamInstEqn DocNameI -> SubDecl ppTyFamEqn (HsIB { hsib_body = FamEqn { feqn_tycon = n, feqn_rhs = rhs , feqn_pats = ts } }) - = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual + = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing, [] ) @@ -368,29 +368,28 @@ ppDataBinderWithVars summ unicode qual decl = ppAppDocNameTyVarBndrs :: Bool -> Unicode -> Qualification -> DocName -> [LHsTyVarBndr DocNameI] -> Html ppAppDocNameTyVarBndrs summ unicode qual n vs = - ppTypeApp n [] vs ppDN (ppHsTyVarBndr unicode qual . unLoc) + ppTypeApp n vs ppDN (ppHsTyVarBndr unicode qual . unLoc) where ppDN notation = ppBinderFixity notation summ . nameOccName . getName ppBinderFixity Infix = ppBinderInfix ppBinderFixity _ = ppBinder --- | Print an application of a 'DocName' and two lists of 'HsTypes' (kinds, types) -ppAppNameTypes :: DocName -> [HsType DocNameI] -> [HsType DocNameI] - -> Unicode -> Qualification -> Html -ppAppNameTypes n ks ts unicode qual = - ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts) +-- | Print an application of a 'DocName' to its list of 'HsType's +ppAppNameTypes :: DocName -> [HsType DocNameI] -> Unicode -> Qualification -> Html +ppAppNameTypes n ts unicode qual = + ppTypeApp n ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts) -- | General printing of type applications -ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html -ppTypeApp n [] (t1:t2:rest) ppDN ppT +ppTypeApp :: DocName -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html +ppTypeApp n (t1:t2:rest) ppDN ppT | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) | operator = opApp where operator = isNameSym . getName $ n opApp = ppT t1 <+> ppDN Infix n <+> ppT t2 -ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts) +ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts) ------------------------------------------------------------------------------- @@ -621,7 +620,7 @@ ppInstHead links splice unicode qual mdoc origin orphan no ihd@(InstHead {..}) = pdecl = pdata <+> ppShortDataDecl False True dd [] unicode qual where iid = instanceId origin no orphan ihd - typ = ppAppNameTypes ihdClsName ihdKinds ihdTypes unicode qual + typ = ppAppNameTypes ihdClsName ihdTypes unicode qual ppInstanceAssocTys :: LinksInfo -> Splice -> Unicode -> Qualification -- cgit v1.2.3