aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs123
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs122
-rw-r--r--haddock-api/src/Haddock/GhcUtils.hs96
4 files changed, 191 insertions, 152 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 257a8d6d..37ac431a 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -89,7 +89,7 @@ dropHsDocTy = f
outHsType :: (a ~ GhcPass p, OutputableBndrId a)
=> DynFlags -> HsType a -> String
-outHsType dflags = out dflags . dropHsDocTy
+outHsType dflags = out dflags . reparenType . dropHsDocTy
dropComment :: String -> String
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index c0da1f0c..4a3e9d03 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -906,24 +906,6 @@ sumParens = ubxparens . hsep . punctuate (text " | ")
-- Stolen from Html and tweaked for LaTeX generation
-------------------------------------------------------------------------------
-
-pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int
-
-pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC
-pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC
- -- Used for LH arg of (->)
-pREC_OP = (2 :: Int) -- Used for arg of any infix operator
- -- (we don't keep their fixities around)
-pREC_CON = (3 :: Int) -- Used for arg of type applicn:
- -- always parenthesise unless atomic
-
-maybeParen :: Int -- Precedence of context
- -> Int -- Precedence of top-level operator
- -> LaTeX -> LaTeX -- Wrap in parens if (ctxt >= op)
-maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
- | otherwise = p
-
-
ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> LaTeX
ppLType unicode y = ppType unicode (unLoc y)
ppLParendType unicode y = ppParendType unicode (unLoc y)
@@ -931,72 +913,70 @@ ppLFunLhType unicode y = ppFunLhType unicode (unLoc y)
ppType, ppParendType, ppFunLhType :: Bool -> HsType DocNameI -> LaTeX
-ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode
-ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode
-ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode
+ppType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
+ppParendType unicode ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode
+ppFunLhType unicode ty = ppr_mono_ty (reparenTypePrec PREC_FUN ty) unicode
ppLKind :: Bool -> LHsKind DocNameI -> LaTeX
ppLKind unicode y = ppKind unicode (unLoc y)
ppKind :: Bool -> HsKind DocNameI -> LaTeX
-ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode
+ppKind unicode ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode
-- Drop top-level for-all type variables in user style
-- since they are implicit in Haskell
-ppr_mono_lty :: Int -> LHsType DocNameI -> Bool -> LaTeX
-ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode
-
-
-ppr_mono_ty :: Int -> HsType DocNameI -> Bool -> LaTeX
-ppr_mono_ty ctxt_prec (HsForAllTy _ tvs ty) unicode
- = maybeParen ctxt_prec pREC_FUN $
- sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot
- , ppr_mono_lty pREC_TOP ty unicode ]
-ppr_mono_ty ctxt_prec (HsQualTy _ ctxt ty) unicode
- = maybeParen ctxt_prec pREC_FUN $
- sep [ ppLContext ctxt unicode
- , ppr_mono_lty pREC_TOP ty unicode ]
-
-ppr_mono_ty _ (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty
-ppr_mono_ty _ (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
-ppr_mono_ty _ (HsTyVar _ Promoted (L _ name)) _ = char '\'' <> ppDocName name
-ppr_mono_ty ctxt_prec (HsFunTy _ ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u
-ppr_mono_ty _ (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys)
-ppr_mono_ty _ (HsSumTy _ tys) u = sumParens (map (ppLType u) tys)
-ppr_mono_ty _ (HsKindSig _ ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind)
-ppr_mono_ty _ (HsListTy _ ty) u = brackets (ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _ (HsIParamTy _ (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)
-ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
-ppr_mono_ty _ (HsRecTy {}) _ = text "{..}"
-ppr_mono_ty _ (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy _ Promoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
-ppr_mono_ty _ (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
-ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
-
-ppr_mono_ty ctxt_prec (HsAppTy _ fun_ty arg_ty) unicode
- = maybeParen ctxt_prec pREC_CON $
- hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode]
-
-ppr_mono_ty ctxt_prec (HsOpTy _ ty1 op ty2) unicode
- = maybeParen ctxt_prec pREC_FUN $
- ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode
+ppr_mono_lty :: LHsType DocNameI -> Bool -> LaTeX
+ppr_mono_lty ty unicode = ppr_mono_ty (unLoc ty) unicode
+
+
+ppr_mono_ty :: HsType DocNameI -> Bool -> LaTeX
+ppr_mono_ty (HsForAllTy _ tvs ty) unicode
+ = sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot
+ , ppr_mono_lty ty unicode ]
+ppr_mono_ty (HsQualTy _ ctxt ty) unicode
+ = sep [ ppLContext ctxt unicode
+ , ppr_mono_lty ty unicode ]
+ppr_mono_ty (HsFunTy _ ty1 ty2) u
+ = sep [ ppr_mono_lty ty1 u
+ , arrow u <+> ppr_mono_lty ty2 u ]
+
+ppr_mono_ty (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty
+ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name
+ppr_mono_ty (HsTyVar _ Promoted (L _ name)) _ = char '\'' <> ppDocName name
+ppr_mono_ty (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys)
+ppr_mono_ty (HsSumTy _ tys) u = sumParens (map (ppLType u) tys)
+ppr_mono_ty (HsKindSig _ ty kind) u = parens (ppr_mono_lty ty u <+> dcolon u <+> ppLKind u kind)
+ppr_mono_ty (HsListTy _ ty) u = brackets (ppr_mono_lty ty u)
+ppr_mono_ty (HsIParamTy _ (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty ty u)
+ppr_mono_ty (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy"
+ppr_mono_ty (HsRecTy {}) _ = text "{..}"
+ppr_mono_ty (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty (HsExplicitListTy _ Promoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys
+ppr_mono_ty (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys
+
+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 (HsOpTy _ ty1 op ty2) unicode
+ = ppr_mono_lty ty1 unicode <+> ppr_op <+> ppr_mono_lty ty2 unicode
where
ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op
occName = nameOccName . getName . unLoc $ op
-ppr_mono_ty ctxt_prec (HsParTy _ ty) unicode
--- = parens (ppr_mono_lty pREC_TOP ty)
- = ppr_mono_lty ctxt_prec ty unicode
+ppr_mono_ty (HsParTy _ ty) unicode
+ = parens (ppr_mono_lty ty unicode)
+-- = ppr_mono_lty ty unicode
-ppr_mono_ty ctxt_prec (HsDocTy _ ty _) unicode
- = ppr_mono_lty ctxt_prec ty unicode
+ppr_mono_ty (HsDocTy _ ty _) unicode
+ = ppr_mono_lty ty unicode
-ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_'
+ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ = char '_'
-ppr_mono_ty _ (HsTyLit _ t) u = ppr_tylit t u
-ppr_mono_ty _ (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)
+ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u
+ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode)
ppr_tylit :: HsTyLit -> Bool -> LaTeX
@@ -1006,15 +986,6 @@ ppr_tylit (HsStrTy _ s) _ = text (show s)
-- XXX: Do something with Unicode parameter?
-ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Bool -> LaTeX
-ppr_fun_ty ctxt_prec ty1 ty2 unicode
- = let p1 = ppr_mono_lty pREC_FUN ty1 unicode
- p2 = ppr_mono_lty pREC_TOP ty2 unicode
- in
- maybeParen ctxt_prec pREC_FUN $
- sep [p1, arrow unicode <+> p2]
-
-
-------------------------------------------------------------------------------
-- * Names
-------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index fdb80141..2f3c1ba1 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1101,38 +1101,18 @@ sumParens = ubxSumList
-- * Rendering of HsType
--------------------------------------------------------------------------------
-
-pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int
-
-pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC
-pREC_CTX = 1 :: Int -- Used for single contexts, eg. ctx => type
- -- (as opposed to (ctx1, ctx2) => type)
-pREC_FUN = 2 :: Int -- btype in ParseIface.y in GHC
- -- Used for LH arg of (->)
-pREC_OP = 3 :: Int -- Used for arg of any infix operator
- -- (we don't keep their fixities around)
-pREC_CON = 4 :: Int -- Used for arg of type applicn:
- -- always parenthesise unless atomic
-
-maybeParen :: Int -- Precedence of context
- -> Int -- Precedence of top-level operator
- -> Html -> Html -- Wrap in parens if (ctxt >= op)
-maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
- | otherwise = p
-
-
ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html
ppLType unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y)
ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y)
ppLFunLhType unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y)
ppCtxType :: Unicode -> Qualification -> HsType DocNameI -> Html
-ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual HideEmptyContexts
+ppCtxType unicode qual ty = ppr_mono_ty (reparenTypePrec PREC_CTX ty) unicode qual HideEmptyContexts
ppType, ppParendType, ppFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> HsType DocNameI -> Html
-ppType unicode qual emptyCtxts ty = ppr_mono_ty pREC_TOP ty unicode qual emptyCtxts
-ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual emptyCtxts
-ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts
+ppType unicode qual emptyCtxts ty = ppr_mono_ty (reparenTypePrec PREC_TOP ty) unicode qual emptyCtxts
+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
ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html
ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) =
@@ -1146,7 +1126,7 @@ ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html
ppLKind unicode qual y = ppKind unicode qual (unLoc y)
ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html
-ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts
+ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts
patSigContext :: LHsType name -> HideEmptyContexts
patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts
@@ -1177,57 +1157,56 @@ ppPatSigType unicode qual typ =
ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html
ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot
-ppr_mono_lty :: Int -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
-ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
+ppr_mono_lty :: LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppr_mono_lty ty = ppr_mono_ty (unLoc ty)
-ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
-ppr_mono_ty ctxt_prec (HsForAllTy _ tvs ty) unicode qual emptyCtxts
- = maybeParen ctxt_prec pREC_FUN $
- ppForAllPart unicode qual tvs <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts
+ppr_mono_ty :: HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
+ppr_mono_ty (HsForAllTy _ tvs ty) unicode qual emptyCtxts
+ = ppForAllPart unicode qual tvs <+> ppr_mono_lty ty unicode qual emptyCtxts
-ppr_mono_ty ctxt_prec (HsQualTy _ ctxt ty) unicode qual emptyCtxts
- = maybeParen ctxt_prec pREC_FUN $
- ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty pREC_TOP ty unicode qual emptyCtxts
+ppr_mono_ty (HsQualTy _ ctxt ty) unicode qual emptyCtxts
+ = ppLContext ctxt unicode qual emptyCtxts <+> ppr_mono_lty ty unicode qual emptyCtxts
-- UnicodeSyntax alternatives
-ppr_mono_ty _ (HsTyVar _ _ (L _ name)) True _ _
+ppr_mono_ty (HsTyVar _ _ (L _ name)) True _ _
| getOccString (getName name) == "(->)" = toHtml "(→)"
-ppr_mono_ty _ (HsBangTy _ b ty) u q _ =
+ppr_mono_ty (HsBangTy _ b ty) u q _ =
ppBang b +++ ppLParendType u q HideEmptyContexts ty
-ppr_mono_ty _ (HsTyVar _ _ (L _ name)) _ q _ =
+ppr_mono_ty (HsTyVar _ _ (L _ name)) _ q _ =
ppDocName q Prefix True name
-ppr_mono_ty _ (HsStarTy _ isUni) u _ _ =
+ppr_mono_ty (HsStarTy _ isUni) u _ _ =
toHtml (if u || isUni then "★" else "*")
-ppr_mono_ty ctxt_prec (HsFunTy _ ty1 ty2) u q e =
- ppr_fun_ty ctxt_prec ty1 ty2 u q e
-ppr_mono_ty _ (HsTupleTy _ con tys) u q _ =
+ppr_mono_ty (HsFunTy _ ty1 ty2) u q e =
+ hsep [ ppr_mono_lty ty1 u q HideEmptyContexts
+ , arrow u <+> ppr_mono_lty ty2 u q e
+ ]
+ppr_mono_ty (HsTupleTy _ con tys) u q _ =
tupleParens con (map (ppLType u q HideEmptyContexts) tys)
-ppr_mono_ty _ (HsSumTy _ tys) u q _ =
+ppr_mono_ty (HsSumTy _ tys) u q _ =
sumParens (map (ppLType u q HideEmptyContexts) tys)
-ppr_mono_ty _ (HsKindSig _ ty kind) u q e =
- parens (ppr_mono_lty pREC_TOP ty u q e <+> dcolon u <+> ppLKind u q kind)
-ppr_mono_ty _ (HsListTy _ ty) u q _ = brackets (ppr_mono_lty pREC_TOP ty u q HideEmptyContexts)
-ppr_mono_ty ctxt_prec (HsIParamTy _ (L _ n) ty) u q _ =
- maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q HideEmptyContexts
-ppr_mono_ty _ (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy"
-ppr_mono_ty _ (HsRecTy {}) _ _ _ = toHtml "{..}"
+ppr_mono_ty (HsKindSig _ ty kind) u q e =
+ parens (ppr_mono_lty ty u q e <+> dcolon u <+> ppLKind u q kind)
+ppr_mono_ty (HsListTy _ ty) u q _ = brackets (ppr_mono_lty ty u q HideEmptyContexts)
+ppr_mono_ty (HsIParamTy _ (L _ n) ty) u q _ =
+ ppIPName n <+> dcolon u <+> ppr_mono_lty ty u q HideEmptyContexts
+ppr_mono_ty (HsSpliceTy {}) _ _ _ = error "ppr_mono_ty HsSpliceTy"
+ppr_mono_ty (HsRecTy {}) _ _ _ = toHtml "{..}"
-- Can now legally occur in ConDeclGADT, the output here is to provide a
-- placeholder in the signature, which is followed by the field
-- declarations.
-ppr_mono_ty _ (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy"
-ppr_mono_ty _ (HsExplicitListTy _ Promoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
-ppr_mono_ty _ (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
-ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
-
-ppr_mono_ty ctxt_prec (HsAppTy _ fun_ty arg_ty) unicode qual _
- = maybeParen ctxt_prec pREC_CON $
- hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual HideEmptyContexts, ppr_mono_lty pREC_CON arg_ty unicode qual HideEmptyContexts]
-
-ppr_mono_ty ctxt_prec (HsOpTy _ ty1 op ty2) unicode qual _
- = maybeParen ctxt_prec pREC_FUN $
- ppr_mono_lty pREC_OP ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts
+ppr_mono_ty (XHsType (NHsCoreTy {})) _ _ _ = error "ppr_mono_ty HsCoreTy"
+ppr_mono_ty (HsExplicitListTy _ Promoted tys) u q _ = promoQuote $ brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty (HsExplicitListTy _ NotPromoted tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys
+ppr_mono_ty (HsExplicitTupleTy _ tys) u q _ = promoQuote $ parenList $ map (ppLType u q HideEmptyContexts) tys
+
+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 (HsOpTy _ ty1 op ty2) unicode qual _
+ = ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts
where
-- `(:)` is valid in type signature only as constructor to promoted list
-- and needs to be quoted in code so we explicitly quote it here too.
@@ -1236,24 +1215,17 @@ ppr_mono_ty ctxt_prec (HsOpTy _ ty1 op ty2) unicode qual _
| otherwise = ppr_op'
ppr_op' = ppLDocName qual Infix op
-ppr_mono_ty ctxt_prec (HsParTy _ ty) unicode qual emptyCtxts
--- = parens (ppr_mono_lty pREC_TOP ty)
- = ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts
+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)
-ppr_mono_ty ctxt_prec (HsDocTy _ ty _) unicode qual emptyCtxts
- = ppr_mono_lty ctxt_prec 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 _ (HsTyLit _ n) _ _ _ = ppr_tylit n
+ppr_mono_ty (HsWildCardTy (AnonWildCard _)) _ _ _ = char '_'
+ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n
ppr_tylit :: HsTyLit -> Html
ppr_tylit (HsNumTy _ n) = toHtml (show n)
ppr_tylit (HsStrTy _ s) = toHtml (show s)
-ppr_fun_ty :: Int -> LHsType DocNameI -> LHsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
-ppr_fun_ty ctxt_prec ty1 ty2 unicode qual emptyCtxts
- = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual HideEmptyContexts
- p2 = ppr_mono_lty pREC_TOP ty2 unicode qual emptyCtxts
- in
- maybeParen ctxt_prec pREC_FUN $
- hsep [p1, arrow unicode <+> p2]
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index b2c34bb4..e7d80969 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -31,6 +31,8 @@ import GHC
import Class
import DynFlags
+import HsTypes (HsType(..))
+
moduleString :: Module -> String
moduleString = moduleNameString . moduleName
@@ -226,6 +228,100 @@ getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG"
-- Should only be called on ConDeclGADT
getGADTConTypeG (XConDecl {}) = panic "getGADTConTypeG"
+
+-------------------------------------------------------------------------------
+-- * Parenthesization
+-------------------------------------------------------------------------------
+
+-- | Precedence level (inside the 'HsType' AST).
+data Precedence
+ = PREC_TOP -- ^ precedence of 'type' production in GHC's parser
+
+ | PREC_CTX -- ^ Used for single contexts, eg. ctx => type
+ -- (as opposed to (ctx1, ctx2) => type)
+
+ | PREC_FUN -- ^ precedence of 'btype' production in GHC's parser
+ -- (used for LH arg of (->))
+
+ | PREC_OP -- ^ arg of any infix operator
+ -- (we don't keep have fixity info)
+
+ | PREC_CON -- ^ arg of type application: always parenthesize unless atomic
+ deriving (Eq, Ord)
+
+-- | Add in extra 'HsParTy' where needed to ensure that what would be printed
+-- out using 'ppr' has enough parentheses to be re-parsed properly.
+--
+-- We cannot add parens that may be required by fixities because we do not have
+-- any fixity information to work with in the first place :(.
+reparenTypePrec :: (XParTy a ~ NoExt) => Precedence -> HsType a -> HsType a
+reparenTypePrec = go
+ where
+
+ -- Shorter name for 'reparenType'
+ go :: (XParTy a ~ NoExt) => Precedence -> HsType a -> HsType a
+ go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty)
+ go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)
+ go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys)
+ go _ (HsKindSig x ty kind) = HsKindSig x (reparenLType ty) (reparenLType kind)
+ go _ (HsListTy x ty) = HsListTy x (reparenLType ty)
+ go _ (HsRecTy x flds) = HsRecTy x (map (fmap reparenConDeclField) flds)
+ go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d
+ go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys)
+ go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)
+ go p (HsIParamTy x n ty)
+ = paren p PREC_CTX $ HsIParamTy x n (reparenLType ty)
+ go p (HsForAllTy x tvs ty)
+ = paren p PREC_CTX $ HsForAllTy x (map (fmap reparenTyVar) tvs) (reparenLType ty)
+ go p (HsQualTy x ctxt ty)
+ = paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty)
+ go p (HsFunTy x ty1 ty2)
+ = paren p PREC_FUN $ HsFunTy x (goL PREC_FUN ty1) (goL PREC_TOP ty2)
+ go p (HsAppTy x fun_ty arg_ty)
+ = paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty)
+ go p (HsOpTy x ty1 op ty2)
+ = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2)
+ go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed
+ go _ t@HsTyVar{} = t
+ go _ t@HsStarTy{} = t
+ go _ t@HsSpliceTy{} = t
+ go _ t@HsTyLit{} = t
+ go _ t@HsWildCardTy{} = t
+ go _ t@XHsType{} = t
+
+ -- Located variant of 'go'
+ goL :: (XParTy a ~ NoExt) => Precedence -> LHsType a -> LHsType a
+ goL ctxt_prec = fmap (go ctxt_prec)
+
+ -- Optionally wrap a type in parens
+ paren :: (XParTy a ~ NoExt)
+ => Precedence -- Precedence of context
+ -> Precedence -- Precedence of top-level operator
+ -> HsType a -> HsType a -- Wrap in parens if (ctxt >= op)
+ paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy NoExt . noLoc
+ | otherwise = id
+
+
+-- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')
+reparenType :: (XParTy a ~ NoExt) => HsType a -> HsType a
+reparenType = reparenTypePrec PREC_TOP
+
+-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')
+reparenLType :: (XParTy a ~ NoExt) => LHsType a -> LHsType a
+reparenLType = fmap reparenType
+
+-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
+reparenTyVar :: (XParTy a ~ NoExt) => HsTyVarBndr a -> HsTyVarBndr a
+reparenTyVar (UserTyVar x n) = UserTyVar x n
+reparenTyVar (KindedTyVar x n kind) = KindedTyVar x n (reparenLType kind)
+reparenTyVar v@XTyVarBndr{} = v
+
+-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')
+reparenConDeclField :: (XParTy a ~ NoExt) => ConDeclField a -> ConDeclField a
+reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d
+reparenConDeclField c@XConDeclField{} = c
+
+
-------------------------------------------------------------------------------
-- * Located
-------------------------------------------------------------------------------
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 12:40:55 +0000