aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src
diff options
context:
space:
mode:
authorAlec Theriault <alec.theriault@gmail.com>2018-07-20 03:01:16 -0700
committerAlexander Biehl <alexbiehl@gmail.com>2018-07-20 12:01:16 +0200
commit953e3eb86b57f468c68d6ec0c651e8b3feda1518 (patch)
tree65ea508b6730a9bf114b2210b18e4dba5b926a1b /haddock-api/src
parent9add5b561406cde1245f150deb3d2625e701399c (diff)
Refactor handling of parens in types (#874)
* Fix type parenthesization in Hoogle backend Ported the logic in the HTML and LaTeX backends for adding in parens into something top-level in 'GhcUtil'. Calling that from the Hoogle backend fixes #873. * Remove parenthesizing logic from LaTeX and XHTML backends Now, the only times that parenthesis in types are added in any backend is through the explicit 'HsParTy' constructor. Precedence is also represented as its own datatype. * List out cases explicitly vs. catch-all * Fix printing of parens for QuantifiedConstraints The priority of printing 'forall' types was just one too high. Fixes #877. * Accept HTML output for quantified contexts test
Diffstat (limited to 'haddock-api/src')
-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
-------------------------------------------------------------------------------