aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/Hoogle.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs1
-rw-r--r--haddock-api/src/Haddock/Backends/LaTeX.hs16
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs24
4 files changed, 24 insertions, 19 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index f7e1c77b..1a0cccf7 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -281,7 +281,7 @@ ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names
name = out dflags $ map unL names
con_sig_ty = HsSig noExtField outer_bndrs theta_ty where
theta_ty = case mcxt of
- Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = theta, hst_body = tau_ty })
+ Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })
Nothing -> tau_ty
tau_ty = foldr mkFunTy res_ty $
case args of PrefixConGADT pos_args -> map hsScaledThing pos_args
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 52d73265..2def35ae 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -274,6 +274,7 @@ classify tok =
ITprefixminus -> TkGlyph
ITbang -> TkGlyph
ITdot -> TkOperator
+ ITproj {} -> TkOperator
ITstar {} -> TkOperator
ITtypeApp -> TkGlyph
ITpercent -> TkGlyph
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index df1f94e6..e2e16947 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -25,7 +25,7 @@ import GHC.Utils.Ppr hiding (Doc, quote)
import qualified GHC.Utils.Ppr as Pretty
import GHC.Types.Basic ( PromotionFlag(..) )
-import GHC
+import GHC hiding (fromMaybeContext )
import GHC.Types.Name.Occurrence
import GHC.Types.Name ( nameOccName )
import GHC.Types.Name.Reader ( rdrNameOcc )
@@ -597,12 +597,12 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace
-------------------------------------------------------------------------------
-ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName
+ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName
-> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]
-> Bool -> LaTeX
ppClassHdr summ lctxt n tvs fds unicode =
keyword "class"
- <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty)
+ <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode else empty)
<+> ppAppDocNameNames summ n (tyvarNames tvs)
<+> ppFds fds unicode
@@ -806,7 +806,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =
, con_ex_tvs = tyVars
, con_forall = L _ forall_
, con_mb_cxt = cxt
- } -> let context = unLoc (fromMaybe (noLoc []) cxt)
+ } -> let context = fromMaybeContext cxt
header_ = ppConstrHdr forall_ tyVars context unicode
in case det of
-- Prefix constructor, e.g. 'Just a'
@@ -980,9 +980,11 @@ ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
-------------------------------------------------------------------------------
-ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Bool -> LaTeX
-ppLContext = ppContext . unLoc
-ppLContextNoArrow = ppContextNoArrow . unLoc
+ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Bool -> LaTeX
+ppLContext Nothing _ = empty
+ppLContext (Just ctxt) unicode = ppContext (unLoc ctxt) unicode
+ppLContextNoArrow Nothing _ = empty
+ppLContextNoArrow (Just ctxt) unicode = ppContextNoArrow (unLoc ctxt) unicode
ppContextNoLocsMaybe :: [HsType DocNameI] -> Bool -> Maybe LaTeX
ppContextNoLocsMaybe [] _ = Nothing
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index de37e42a..e48f9bdd 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -37,7 +37,7 @@ import Text.XHtml hiding ( name, title, p, quote )
import GHC.Core.Type ( Specificity(..) )
import GHC.Types.Basic (PromotionFlag(..), isPromoted)
-import GHC hiding (LexicalFixity(..))
+import GHC hiding (LexicalFixity(..), fromMaybeContext)
import GHC.Exts
import GHC.Types.Name
import GHC.Data.BooleanFormula
@@ -167,7 +167,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_sig_args 0 sep
leader' = leader <+> ppForAllPart unicode qual tele
do_args n leader (HsQualTy _ lctxt ltype)
- | null (unLoc lctxt)
+ | null (fromMaybeContext lctxt)
= do_largs n leader ltype
| otherwise
= (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, [])
@@ -435,10 +435,12 @@ ppTypeApp n ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT ts)
-------------------------------------------------------------------------------
-ppLContext, ppLContextNoArrow :: Located (HsContext DocNameI) -> Unicode
+ppLContext, ppLContextNoArrow :: Maybe (LHsContext DocNameI) -> Unicode
-> Qualification -> HideEmptyContexts -> Html
-ppLContext = ppContext . unLoc
-ppLContextNoArrow = ppContextNoArrow . unLoc
+ppLContext Nothing u q h = ppContext [] u q h
+ppLContext (Just c) u q h = ppContext (unLoc c) u q h
+ppLContextNoArrow Nothing u q h = ppContextNoArrow [] u q h
+ppLContextNoArrow (Just c) u q h = ppContextNoArrow (unLoc c) u q h
ppContextNoArrow :: HsContext DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html
ppContextNoArrow cxt unicode qual emptyCtxts = fromMaybe noHtml $
@@ -472,12 +474,12 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyCont
-------------------------------------------------------------------------------
-ppClassHdr :: Bool -> Located [LHsType DocNameI] -> DocName
+ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName
-> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]
-> Unicode -> Qualification -> Html
ppClassHdr summ lctxt n tvs fds unicode qual =
keyword "class"
- <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)
+ <+> (if not (null $ fromMaybeContext lctxt) then ppLContext lctxt unicode qual HideEmptyContexts else noHtml)
<+> ppAppDocNameTyVarBndrs summ unicode qual n (hsQTvExplicit tvs)
<+> ppFds fds unicode qual
@@ -855,7 +857,7 @@ ppShortConstrParts summary dataInst con unicode qual
, con_ex_tvs = tyVars
, con_forall = L _ forall_
, con_mb_cxt = cxt
- } -> let context = unLoc (fromMaybe (noLoc []) cxt)
+ } -> let context = fromMaybeContext cxt
header_ = ppConstrHdr forall_ tyVars context unicode qual
in case det of
@@ -927,7 +929,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
, con_ex_tvs = tyVars
, con_forall = L _ forall_
, con_mb_cxt = cxt
- } -> let context = unLoc (fromMaybe (noLoc []) cxt)
+ } -> let context = fromMaybeContext cxt
header_ = ppConstrHdr forall_ tyVars context unicode qual
in case det of
-- Prefix constructor, e.g. 'Just a'
@@ -1181,13 +1183,13 @@ patSigContext sig_typ | hasNonEmptyContext typ && isFirstContextEmpty typ = Sho
hasNonEmptyContext t =
case unLoc t of
HsForAllTy _ _ s -> hasNonEmptyContext s
- HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
+ HsQualTy _ cxt s -> if null (fromMaybeContext cxt) then hasNonEmptyContext s else True
HsFunTy _ _ _ s -> hasNonEmptyContext s
_ -> False
isFirstContextEmpty t =
case unLoc t of
HsForAllTy _ _ s -> isFirstContextEmpty s
- HsQualTy _ cxt _ -> null (unLoc cxt)
+ HsQualTy _ cxt _ -> null (fromMaybeContext cxt)
HsFunTy _ _ _ s -> isFirstContextEmpty s
_ -> False
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 02:22:51 +0000