aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/Backends')
-rw-r--r--src/Haddock/Backends/Hoogle.hs33
-rw-r--r--src/Haddock/Backends/LaTeX.hs37
-rw-r--r--src/Haddock/Backends/Xhtml.hs38
-rw-r--r--src/Haddock/Backends/Xhtml/DocMarkup.hs53
-rw-r--r--src/Haddock/Backends/Xhtml/Names.hs14
5 files changed, 95 insertions, 80 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index ed8d4665..6e3e306a 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -228,22 +228,23 @@ str a = [Str a]
markupTag :: Outputable o => DocMarkup o [Tag]
markupTag = Markup {
- markupParagraph = box TagP,
- markupEmpty = str "",
- markupString = str,
- markupAppend = (++),
- markupIdentifier = box (TagInline "a") . str . out,
- markupModule = box (TagInline "a") . str,
- markupEmphasis = box (TagInline "i"),
- markupMonospaced = box (TagInline "tt"),
- markupPic = const $ str " ",
- markupUnorderedList = box (TagL 'u'),
- markupOrderedList = box (TagL 'o'),
- markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
- markupCodeBlock = box TagPre,
- markupURL = box (TagInline "a") . str,
- markupAName = const $ str "",
- markupExample = box TagPre . str . unlines . map exampleToString
+ markupParagraph = box TagP,
+ markupEmpty = str "",
+ markupString = str,
+ markupAppend = (++),
+ markupIdentifier = box (TagInline "a") . str . out,
+ markupIdentifierUnchecked = box (TagInline "a") . str . out . snd,
+ markupModule = box (TagInline "a") . str,
+ markupEmphasis = box (TagInline "i"),
+ markupMonospaced = box (TagInline "tt"),
+ markupPic = const $ str " ",
+ markupUnorderedList = box (TagL 'u'),
+ markupOrderedList = box (TagL 'o'),
+ markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
+ markupCodeBlock = box TagPre,
+ markupURL = box (TagInline "a") . str,
+ markupAName = const $ str "",
+ markupExample = box TagPre . str . unlines . map exampleToString
}
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index fc313888..e0a530be 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -999,34 +999,35 @@ latexMonoMunge c s = latexMunge c s
parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX)
parLatexMarkup ppId = Markup {
- markupParagraph = \p v -> p v <> text "\\par" $$ text "",
- markupEmpty = \_ -> empty,
- markupString = \s v -> text (fixString v s),
- markupAppend = \l r v -> l v <> r v,
- markupIdentifier = markupId,
- markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),
- markupEmphasis = \p v -> emph (p v),
- markupMonospaced = \p _ -> tt (p Mono),
- markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "",
- markupPic = \path _ -> parens (text "image: " <> text path),
- markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "",
- markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
- markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "",
- markupURL = \u _ -> text "\\url" <> braces (text u),
- markupAName = \_ _ -> empty,
- markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e
+ markupParagraph = \p v -> p v <> text "\\par" $$ text "",
+ markupEmpty = \_ -> empty,
+ markupString = \s v -> text (fixString v s),
+ markupAppend = \l r v -> l v <> r v,
+ markupIdentifier = markupId ppId,
+ markupIdentifierUnchecked = markupId (ppVerbOccName . snd),
+ markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),
+ markupEmphasis = \p v -> emph (p v),
+ markupMonospaced = \p _ -> tt (p Mono),
+ markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "",
+ markupPic = \path _ -> parens (text "image: " <> text path),
+ markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "",
+ markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
+ markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "",
+ markupURL = \u _ -> text "\\url" <> braces (text u),
+ markupAName = \_ _ -> empty,
+ markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e
}
where
fixString Plain s = latexFilter s
fixString Verb s = s
fixString Mono s = latexMonoFilter s
- markupId id v =
+ markupId ppId_ id v =
case v of
Verb -> theid
Mono -> theid
Plain -> text "\\haddockid" <> braces theid
- where theid = ppId id
+ where theid = ppId_ id
latexMarkup :: DocMarkup DocName (StringContext -> LaTeX)
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 9ac4211a..52bde5b6 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -83,8 +83,7 @@ ppHtml doctitle maybe_package ifaces odir prologue
themes maybe_index_url maybe_source_url maybe_wiki_url
(map toInstalledIface visible_ifaces)
False -- we don't want to display the packages in a single-package contents
- prologue
- debug
+ prologue debug qual
when (isNothing maybe_index_url) $
ppHtmlIndex odir doctitle maybe_package
@@ -224,10 +223,11 @@ ppHtmlContents
-> WikiURLs
-> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName)
-> Bool
+ -> Qualification -- ^ How to qualify names
-> IO ()
ppHtmlContents odir doctitle _maybe_package
themes maybe_index_url
- maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug = do
+ maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do
let tree = mkModuleTree showPkgs
[(instMod iface, toInstalledDescription iface) | iface <- ifaces]
html =
@@ -235,8 +235,8 @@ ppHtmlContents odir doctitle _maybe_package
bodyHtml doctitle Nothing
maybe_source_url maybe_wiki_url
Nothing maybe_index_url << [
- ppPrologue doctitle prologue,
- ppModuleTree tree
+ ppPrologue qual doctitle prologue,
+ ppModuleTree qual tree
]
createDirectoryIfMissing True odir
writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
@@ -245,27 +245,27 @@ ppHtmlContents odir doctitle _maybe_package
ppHtmlContentsFrame odir doctitle themes ifaces debug
-ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> Html
-ppPrologue _ Nothing = noHtml
-ppPrologue title (Just doc) =
- divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml doc))
+ppPrologue :: Qualification -> String -> Maybe (Doc GHC.RdrName) -> Html
+ppPrologue _ _ Nothing = noHtml
+ppPrologue qual title (Just doc) =
+ divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc))
-ppModuleTree :: [ModuleTree] -> Html
-ppModuleTree ts =
- divModuleList << (sectionName << "Modules" +++ mkNodeList [] "n" ts)
+ppModuleTree :: Qualification -> [ModuleTree] -> Html
+ppModuleTree qual ts =
+ divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts)
-mkNodeList :: [String] -> String -> [ModuleTree] -> Html
-mkNodeList ss p ts = case ts of
+mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html
+mkNodeList qual ss p ts = case ts of
[] -> noHtml
- _ -> unordList (zipWith (mkNode ss) ps ts)
+ _ -> unordList (zipWith (mkNode qual ss) ps ts)
where
ps = [ p ++ '.' : show i | i <- [(1::Int)..]]
-mkNode :: [String] -> String -> ModuleTree -> Html
-mkNode ss p (Node s leaf pkg short ts) =
+mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html
+mkNode qual ss p (Node s leaf pkg short ts) =
htmlModule +++ shortDescr +++ htmlPkg +++ subtree
where
modAttrs = case (ts, leaf) of
@@ -288,10 +288,10 @@ mkNode ss p (Node s leaf pkg short ts) =
mdl = intercalate "." (reverse (s:ss))
- shortDescr = maybe noHtml origDocToHtml short
+ shortDescr = maybe noHtml (origDocToHtml qual) short
htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg
- subtree = mkNodeList (s:ss) p ts ! collapseSection p True ""
+ subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True ""
-- | Turn a module tree into a flat list of full module names. E.g.,
diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 05ce7dbb..87d67b76 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -30,25 +30,26 @@ import Text.XHtml hiding ( name, title, p, quote )
import GHC
-parHtmlMarkup :: (a -> Html) -> DocMarkup a Html
-parHtmlMarkup ppId = Markup {
- markupEmpty = noHtml,
- markupString = toHtml,
- markupParagraph = paragraph,
- markupAppend = (+++),
- markupIdentifier = thecode . ppId,
- markupModule = \m -> let (mdl,ref) = break (=='#') m
- in ppModuleRef (mkModuleNoPackage mdl) ref,
- markupEmphasis = emphasize,
- markupMonospaced = thecode,
- markupUnorderedList = unordList,
- markupOrderedList = ordList,
- markupDefList = defList,
- markupCodeBlock = pre,
- markupURL = \url -> anchor ! [href url] << url,
- markupAName = \aname -> namedAnchor aname << "",
- markupPic = \path -> image ! [src path],
- markupExample = examplesToHtml
+parHtmlMarkup :: Qualification -> (a -> Html) -> DocMarkup a Html
+parHtmlMarkup qual ppId = Markup {
+ markupEmpty = noHtml,
+ markupString = toHtml,
+ markupParagraph = paragraph,
+ markupAppend = (+++),
+ markupIdentifier = thecode . ppId,
+ markupIdentifierUnchecked = thecode . ppUncheckedLink qual,
+ markupModule = \m -> let (mdl,ref) = break (=='#') m
+ in ppModuleRef (mkModuleNoPackage mdl) ref,
+ markupEmphasis = emphasize,
+ markupMonospaced = thecode,
+ markupUnorderedList = unordList,
+ markupOrderedList = ordList,
+ markupDefList = defList,
+ markupCodeBlock = pre,
+ markupURL = \url -> anchor ! [href url] << url,
+ markupAName = \aname -> namedAnchor aname << "",
+ markupPic = \path -> image ! [src path],
+ markupExample = examplesToHtml
}
where
examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]
@@ -64,17 +65,17 @@ parHtmlMarkup ppId = Markup {
-- ugly extra whitespace with some browsers). FIXME: Does this still apply?
docToHtml :: Qualification -> Doc DocName -> Html
docToHtml qual = markup fmt . cleanup
- where fmt = parHtmlMarkup (ppDocName qual)
+ where fmt = parHtmlMarkup qual (ppDocName qual)
-origDocToHtml :: Doc Name -> Html
-origDocToHtml = markup fmt . cleanup
- where fmt = parHtmlMarkup ppName
+origDocToHtml :: Qualification -> Doc Name -> Html
+origDocToHtml qual = markup fmt . cleanup
+ where fmt = parHtmlMarkup qual ppName
-rdrDocToHtml :: Doc RdrName -> Html
-rdrDocToHtml = markup fmt . cleanup
- where fmt = parHtmlMarkup ppRdrName
+rdrDocToHtml :: Qualification -> Doc RdrName -> Html
+rdrDocToHtml qual = markup fmt . cleanup
+ where fmt = parHtmlMarkup qual ppRdrName
docElement :: (Html -> Html) -> Html -> Html
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index c5166d7f..19efea2e 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -11,7 +11,7 @@
-- Portability : portable
-----------------------------------------------------------------------------
module Haddock.Backends.Xhtml.Names (
- ppName, ppDocName, ppLDocName, ppRdrName,
+ ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
ppBinder, ppBinder',
ppModule, ppModuleRef,
linkId
@@ -39,6 +39,10 @@ ppRdrName :: RdrName -> Html
ppRdrName = ppOccName . rdrNameOcc
+ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html
+ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName
+
+
ppLDocName :: Qualification -> Located DocName -> Html
ppLDocName qual (L _ d) = ppDocName qual d
@@ -110,6 +114,14 @@ linkIdOcc mdl mbName = anchor ! [href url]
Just name -> moduleNameUrl mdl name
+linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html
+linkIdOcc' mdl mbName = anchor ! [href url]
+ where
+ url = case mbName of
+ Nothing -> moduleHtmlFile' mdl
+ Just name -> moduleNameUrl' mdl name
+
+
ppModule :: Module -> Html
ppModule mdl = anchor ! [href (moduleUrl mdl)]
<< toHtml (moduleString mdl)
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 11:46:23 +0000