Visible kind application haddock update

2 files changed, 19 insertions, 5 deletions

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 819a4747..9952721c 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -315,7 +315,7 @@ ppFamDecl summary associated links instances fixities loc doc decl splice unicod
     ppFamDeclEqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n
                                             , feqn_rhs = rhs
                                             , feqn_pats = ts } })
-      = ( ppAppNameTypes n (map unLoc ts) unicode qual
+      = ( ppAppNameTypeArgs n ts unicode qual
           <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs)
         , Nothing
         , []
@@ -418,6 +418,11 @@ ppAppNameTypes :: DocName -> [HsType DocNameI] -> Unicode -> Qualification -> Ht
 ppAppNameTypes n ts unicode qual =
     ppTypeApp n ts (\p -> ppDocName qual p True) (ppParendType unicode qual HideEmptyContexts)
 
+ppAppNameTypeArgs :: DocName -> [LHsTypeArg DocNameI] -> Unicode -> Qualification -> Html
+ppAppNameTypeArgs n args@(HsValArg _:HsValArg _:_) u q
+  = ppTypeApp n args (\p -> ppDocName q p True) (ppLHsTypeArg u q HideEmptyContexts)
+ppAppNameTypeArgs n args u q
+  = (ppDocName q Prefix True n) <+> hsep (map (ppLHsTypeArg u q HideEmptyContexts) args)
 
 -- | General printing of type applications
 ppTypeApp :: DocName -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html
@@ -430,7 +435,6 @@ ppTypeApp n (t1:t2:rest) ppDN ppT
 
 ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts)
 
-
 -------------------------------------------------------------------------------
 -- * Contexts
 -------------------------------------------------------------------------------
@@ -1103,6 +1107,11 @@ ppType       unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP
 ppParendType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_CON ty) unicode qual emptyCtxts
 ppFunLhType  unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode qual emptyCtxts
 
+ppLHsTypeArg :: Unicode -> Qualification -> HideEmptyContexts -> LHsTypeArg DocNameI -> Html
+ppLHsTypeArg unicode qual emptyCtxts (HsValArg ty) = ppLParendType unicode qual emptyCtxts ty
+ppLHsTypeArg unicode qual emptyCtxts (HsTypeArg ki) = atSign unicode <>
+                                                     ppLParendType unicode qual emptyCtxts ki
+ppLHsTypeArg _ _ _ (HsArgPar _) = toHtml ""
 ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html
 ppHsTyVarBndr _       qual (UserTyVar _ (L _ name)) =
     ppDocName qual Raw False name
@@ -1195,6 +1204,10 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode qual _
   = hsep [ ppr_mono_lty fun_ty unicode qual HideEmptyContexts
          , ppr_mono_lty arg_ty unicode qual HideEmptyContexts ]
 
+ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode qual _
+  = hsep [ppr_mono_lty fun_ty unicode qual HideEmptyContexts
+         , atSign unicode <> ppr_mono_lty arg_ki unicode qual HideEmptyContexts]
+
 ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _
   = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts
   where
@@ -1212,7 +1225,7 @@ ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts
 ppr_mono_ty (HsDocTy _ ty _) unicode qual emptyCtxts
   = ppr_mono_lty ty unicode qual emptyCtxts
 
-ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_'
+ppr_mono_ty (HsWildCardTy _) _ _ _ = char '_'
 ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n
 
 ppr_tylit :: HsTyLit -> Html
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index 62781fd0..c3acb6df 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -22,6 +22,7 @@ module Haddock.Backends.Xhtml.Utils (
 
   braces, brackets, pabrackets, parens, parenList, ubxParenList, ubxSumList,
   arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, promoQuote,
+  atSign,
 
   hsep, vcat,
 
@@ -186,12 +187,12 @@ ubxparens :: Html -> Html
 ubxparens h = toHtml "(#" <+> h <+> toHtml "#)"
 
 
-dcolon, arrow, darrow, forallSymbol :: Bool -> Html
+dcolon, arrow, darrow, forallSymbol, atSign :: Bool -> Html
 dcolon unicode = toHtml (if unicode then "∷" else "::")
 arrow  unicode = toHtml (if unicode then "→" else "->")
 darrow unicode = toHtml (if unicode then "⇒" else "=>")
 forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall"
-
+atSign unicode = toHtml (if unicode then "@" else "@")
 
 dot :: Html
 dot = toHtml "."