Vladislav Zavialov pushed to branch wip/int-index/tyop at Glasgow Haskell Compiler / GHC Commits: cb514db5 by Vladislav Zavialov at 2026-03-02T11:26:22+03:00 WIP: Update haddock backends - - - - - 2 changed files: - utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs Changes: ===================================== utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs ===================================== @@ -1345,17 +1345,15 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode = hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode] ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode = hsep [ppr_mono_lty fun_ty unicode, atSign <> ppr_mono_lty arg_ki unicode] -ppr_mono_ty (HsOpTy _ ty1 (L _ (HsTyVar _ prom op)) ty2) unicode = - ppr_mono_lty ty1 unicode <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode +ppr_mono_ty (HsOpTy _ ty1 tyop ty2) unicode + | Just pp_op <- ppr_infix_ty tyop + = pp_ty1 <+> pp_op <+> pp_ty2 + | otherwise + = let pp_op = ppr_mono_lty tyop unicode + in hsep [hsep [pp_op, pp_ty1], pp_ty2] where - ppr_op_prom - | isPromoted prom = - char '\'' <> ppr_op - | otherwise = - ppr_op - ppr_op - | isSymOcc (getOccName op) = ppLDocName op - | otherwise = char '`' <> ppLDocName op <> char '`' + pp_ty1 = ppr_mono_lty ty1 unicode + pp_ty2 = ppr_mono_lty ty2 unicode ppr_mono_ty (HsParTy _ ty) unicode = parens (ppr_mono_lty ty unicode) -- = ppr_mono_lty ty unicode @@ -1367,6 +1365,18 @@ ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) ppr_mono_ty (XHsType HsRedacted{}) _ = error "ppr_mono_ty: HsRedacted can't be used here" +ppr_infix_ty :: LHsType DocNameI -> Maybe LaTeX +ppr_infix_ty (L _ (HsTyVar _ prom op)) = Just pp_op_prom + where + pp_op_prom + | isPromoted prom = char '\'' <> pp_op + | otherwise = pp_op + pp_op + | isSymOcc (getOccName op) = ppLDocName op + | otherwise = char '`' <> ppLDocName op <> char '`' +ppr_infix_ty (L _ (HsWildCardTy _)) = Just (text "`_`") +ppr_infix_ty _ = Nothing + ppr_tylit :: HsLit DocNameI -> Bool -> LaTeX ppr_tylit (HsNatural _ n) _ = integer (il_value n) ppr_tylit (HsString _ s) _ = text (show s) ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs ===================================== @@ -1863,15 +1863,15 @@ ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode qual _ = [ ppr_mono_lty fun_ty unicode qual HideEmptyContexts , atSign <> ppr_mono_lty arg_ki unicode qual HideEmptyContexts ] -ppr_mono_ty (HsOpTy _ ty1 (L _ (HsTyVar _ prom op)) ty2) unicode qual _ = - ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts +ppr_mono_ty (HsOpTy _ ty1 tyop ty2) unicode qual _ + | Just pp_op <- ppr_infix_ty tyop qual + = pp_ty1 <+> pp_op <+> pp_ty2 + | otherwise + = let pp_op = ppr_mono_lty tyop unicode qual HideEmptyContexts + in hsep [hsep [pp_op, pp_ty1], pp_ty2] where - ppr_op_prom - | isPromoted prom = - promoQuote ppr_op - | otherwise = - ppr_op - ppr_op = ppLDocName qual Infix op + pp_ty1 = ppr_mono_lty ty1 unicode qual HideEmptyContexts + pp_ty2 = ppr_mono_lty ty2 unicode qual HideEmptyContexts ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts = parens (ppr_mono_lty ty unicode qual emptyCtxts) -- = parens (ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts) @@ -1882,6 +1882,16 @@ ppr_mono_ty (HsWildCardTy _) _ _ _ = char '_' ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n ppr_mono_ty (XHsType HsRedacted{}) _ _ _ = error "ppr_mono_ty: HsRedacted can't be used here" +ppr_infix_ty :: LHsType DocNameI -> Qualification -> Maybe Html +ppr_infix_ty (L _ (HsTyVar _ prom op)) qual = Just pp_op_prom + where + pp_op_prom + | isPromoted prom = promoQuote pp_op + | otherwise = pp_op + pp_op = ppLDocName qual Infix op +ppr_infix_ty (L _ (HsWildCardTy _)) _ = Just (toHtml ("`_`" :: LText)) +ppr_infix_ty _ _ = Nothing + ppr_tylit :: HsLit DocNameI -> Html ppr_tylit (HsNatural _ n) = toHtml (show (il_value n)) ppr_tylit (HsString _ s) = toHtml (show s) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb514db547b052b29c2d1fed1d4c939a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb514db547b052b29c2d1fed1d4c939a... You're receiving this email because of your account on gitlab.haskell.org.