aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends/Xhtml
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml')
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Decl.hs78
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Names.hs5
4 files changed, 45 insertions, 42 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index e48f9bdd..8de1b1b8 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -58,22 +58,22 @@ ppDecl :: Bool -- ^ print summary info only
-> Qualification
-> Html
ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of
- TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities loc mbDoc d splice unicode pkg qual
- TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual
- TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual
- TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual
- SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames
+ TyClD _ (FamDecl _ d) -> ppFamDecl summ False links instances fixities (locA loc) mbDoc d splice unicode pkg qual
+ TyClD _ d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs (locA loc) mbDoc d pats splice unicode pkg qual
+ TyClD _ d@(SynDecl {}) -> ppTySyn summ links fixities (locA loc) (mbDoc, fnArgsDoc) d splice unicode pkg qual
+ TyClD _ d@(ClassDecl {}) -> ppClassDecl summ links instances fixities (locA loc) mbDoc subdocs d splice unicode pkg qual
+ SigD _ (TypeSig _ lnames lty) -> ppLFunSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames
(dropWildCards lty) fixities splice unicode pkg qual
- SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames
+ SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames
lty fixities splice unicode pkg qual
- ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
+ ForD _ d -> ppFor summ links (locA loc) (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual
InstD _ _ -> noHtml
DerivD _ _ -> noHtml
_ -> error "declaration not supported by ppDecl"
ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->
- [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->
+ [LocatedN DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->
Splice -> Unicode -> Maybe Package -> Qualification -> Html
ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual =
ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities
@@ -90,7 +90,7 @@ ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg q
-- | Pretty print a pattern synonym
ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName
- -> [Located DocName] -- ^ names of patterns in declaration
+ -> [LocatedN DocName] -- ^ names of patterns in declaration
-> LHsSigType DocNameI -- ^ type of patterns in declaration
-> [(DocName, Fixity)]
-> Splice -> Unicode -> Maybe Package -> Qualification -> Html
@@ -249,7 +249,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars
sig_type = mkHsImplicitSigTypeI ltype
hdr = hsep ([keyword "type", ppBinder summary occ]
++ ppTyVars unicode qual (hsQTvExplicit ltyvars))
- full = hdr <+> equals <+> ppPatSigType unicode qual (noLoc sig_type)
+ full = hdr <+> equals <+> ppPatSigType unicode qual (noLocA sig_type)
occ = nameOccName . getName $ name
fixs
| summary = noHtml
@@ -330,7 +330,7 @@ ppPseudoFamDecl links splice
, pfdTyVars = tvs
, pfdLName = L loc name })
unicode qual =
- topDeclElem links loc splice [name] leader
+ topDeclElem links (locA loc) splice [name] leader
where
leader = hsep [ ppFamilyLeader True info
, ppAppNameTypes name (map unLoc tvs) unicode qual
@@ -361,10 +361,11 @@ ppFamHeader summary associated (FamilyDecl { fdInfo = info
injAnn = case injectivity of
Nothing -> noHtml
- Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( keyword "|"
- : ppLDocName qual Raw lhs
- : arrow unicode
- : map (ppLDocName qual Raw) rhs)
+ Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( keyword "|"
+ : ppLDocName qual Raw lhs
+ : arrow unicode
+ : map (ppLDocName qual Raw) rhs)
+ Just _ -> error "ppFamHeader:XInjectivityAnn"
-- | Print the keywords that begin the family declaration
ppFamilyLeader :: Bool -> FamilyInfo DocNameI -> Html
@@ -474,8 +475,8 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyCont
-------------------------------------------------------------------------------
-ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName
- -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])]
+ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName
+ -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI]
-> Unicode -> Qualification -> Html
ppClassHdr summ lctxt n tvs fds unicode qual =
keyword "class"
@@ -484,12 +485,13 @@ ppClassHdr summ lctxt n tvs fds unicode qual =
<+> ppFds fds unicode qual
-ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html
+ppFds :: [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html
ppFds fds unicode qual =
if null fds then noHtml else
char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))
where
- fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2
+ fundep (FunDep _ vars1 vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2
+ fundep (XFunDep _) = error "ppFds"
ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc)
ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan
@@ -572,9 +574,9 @@ ppClassDecl summary links instances fixities loc d subdocs
lookupDAT name = Map.lookup (getName name) defaultAssocTys
defaultAssocTys = Map.fromList
[ (getName name, (vs, typ))
- | L _ (TyFamInstDecl (FamEqn { feqn_rhs = typ
- , feqn_tycon = L _ name
- , feqn_pats = vs })) <- atsDefs
+ | L _ (TyFamInstDecl _ (FamEqn { feqn_rhs = typ
+ , feqn_tycon = L _ name
+ , feqn_pats = vs })) <- atsDefs
]
-- Methods
@@ -723,7 +725,7 @@ ppInstanceSigs links splice unicode qual sigs = do
L _ rtyp = dropWildCards typ
-- Instance methods signatures are synified and thus don't have a useful
-- SrcSpan value. Use the methods name location instead.
- return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp
+ return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head $ lnames) names rtyp
lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
@@ -828,7 +830,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats
[ ppSideBySideConstr subdocs subfixs unicode pkg qual c
| c <- cons
, let subfixs = filter (\(n,_) -> any (\cn -> cn == n)
- (map unLoc (getConNamesI (unLoc c)))) fixities
+ (map unL (getConNamesI (unLoc c)))) fixities
]
patternBit = subPatterns pkg qual
@@ -855,7 +857,7 @@ ppShortConstrParts summary dataInst con unicode qual
= case con of
ConDeclH98{ con_args = det
, con_ex_tvs = tyVars
- , con_forall = L _ forall_
+ , con_forall = forall_
, con_mb_cxt = cxt
} -> let context = fromMaybeContext cxt
header_ = ppConstrHdr forall_ tyVars context unicode qual
@@ -895,7 +897,7 @@ ppShortConstrParts summary dataInst con unicode qual
)
where
- occ = map (nameOccName . getName . unLoc) $ getConNamesI con
+ occ = map (nameOccName . getName . unL) $ getConNamesI con
ppOcc = hsep (punctuate comma (map (ppBinder summary) occ))
ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ))
@@ -912,10 +914,10 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
)
where
-- Find the name of a constructors in the decl (`getConName` always returns a non-empty list)
- aConName = unLoc (head (getConNamesI con))
+ aConName = unL (head (getConNamesI con))
fixity = ppFixities fixities qual
- occ = map (nameOccName . getName . unLoc) $ getConNamesI con
+ occ = map (nameOccName . getName . unL) $ getConNamesI con
ppOcc = hsep (punctuate comma (map (ppBinder False) occ))
ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ))
@@ -927,7 +929,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
decl = case con of
ConDeclH98{ con_args = det
, con_ex_tvs = tyVars
- , con_forall = L _ forall_
+ , con_forall = forall_
, con_mb_cxt = cxt
} -> let context = fromMaybeContext cxt
header_ = ppConstrHdr forall_ tyVars context unicode qual
@@ -994,7 +996,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)
-- don't use "con_doc con", in case it's reconstructed from a .hi file,
-- or also because we want Haddock to do the doc-parsing, not GHC.
- mbDoc = lookup (unLoc $ head $ getConNamesI con) subdocs >>=
+ mbDoc = lookup (unL $ head $ getConNamesI con) subdocs >>=
combineDocumentation . fst
@@ -1044,7 +1046,7 @@ ppShortField summary unicode qual (ConDeclField _ names ltype _)
-- | Pretty print an expanded pattern (for bundled patterns)
ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification
- -> [Located DocName] -- ^ pattern name(s)
+ -> [LocatedN DocName] -- ^ pattern name(s)
-> LHsSigType DocNameI -- ^ type of pattern(s)
-> DocForDecl DocName -- ^ doc map
-> SubDecl
@@ -1121,7 +1123,7 @@ sumParens = ubxSumList
-- * Rendering of HsType
--------------------------------------------------------------------------------
-ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html
+ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> LHsType 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)
@@ -1153,7 +1155,7 @@ instance RenderableBndrFlag () where
ppHsTyVarBndr _ qual (UserTyVar _ _ (L _ name)) =
ppDocName qual Raw False name
ppHsTyVarBndr unicode qual (KindedTyVar _ _ name kind) =
- parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
+ parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+>
ppLKind unicode qual kind)
instance RenderableBndrFlag Specificity where
@@ -1162,10 +1164,10 @@ instance RenderableBndrFlag Specificity where
ppHsTyVarBndr _ qual (UserTyVar _ InferredSpec (L _ name)) =
braces $ ppDocName qual Raw False name
ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) =
- parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
+ parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+>
ppLKind unicode qual kind)
ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) =
- braces (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+>
+ braces (ppDocName qual Raw False (unL name) <+> dcolon unicode <+>
ppLKind unicode qual kind)
ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html
@@ -1246,9 +1248,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e =
, arr <+> ppr_mono_lty ty2 u q e
]
where arr = case mult of
- HsLinearArrow _ -> lollipop u
+ HsLinearArrow _ _ -> lollipop u
HsUnrestrictedArrow _ -> arrow u
- HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u
+ HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u
ppr_mono_ty (HsTupleTy _ con tys) u q _ =
tupleParens con (map (ppLType u q HideEmptyContexts) tys)
@@ -1283,7 +1285,7 @@ ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _
-- `(:)` 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.
ppr_op
- | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op'
+ | (getOccString . getName . unL) op == ":" = promoQuote ppr_op'
| otherwise = ppr_op'
ppr_op' = ppLDocName qual Infix op
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 7670b193..b8f5ac0f 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -31,7 +31,7 @@ import Haddock.Doc (combineDocumentation, emptyMetaDoc,
import Text.XHtml hiding ( name, p, quote )
import Data.Maybe (fromMaybe)
-import GHC
+import GHC hiding (anchor)
import GHC.Types.Name
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
index d61d6d9b..8f04a21f 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -51,7 +51,7 @@ import Text.XHtml hiding ( name, title, quote )
import Data.Maybe (fromMaybe)
import GHC.Data.FastString ( unpackFS )
-import GHC
+import GHC hiding (anchor)
import GHC.Types.Name (nameOccName)
--------------------------------------------------------------------------------
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
index b324fa38..6dfc60fa 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs
@@ -27,7 +27,7 @@ import Text.XHtml hiding ( name, p, quote )
import qualified Data.Map as M
import Data.List ( stripPrefix )
-import GHC hiding (LexicalFixity(..))
+import GHC hiding (LexicalFixity(..), anchor)
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Data.FastString (unpackFS)
@@ -57,9 +57,10 @@ ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml
occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName
-- The Bool indicates if it is to be rendered in infix notation
-ppLDocName :: Qualification -> Notation -> Located DocName -> Html
+ppLDocName :: Qualification -> Notation -> GenLocated l DocName -> Html
ppLDocName qual notation (L _ d) = ppDocName qual notation True d
+
ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html
ppDocName qual notation insertAnchors docName =
case docName of
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 13:59:17 +0000