aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-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
-rw-r--r--src/Haddock/Interface/Rename.hs1
-rw-r--r--src/Haddock/Interface/Rn.hs35
-rw-r--r--src/Haddock/InterfaceFile.hs6
-rw-r--r--src/Haddock/Types.hs38
-rw-r--r--src/Haddock/Utils.hs103
-rw-r--r--src/Main.hs7
11 files changed, 217 insertions, 148 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)
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index 2c10146d..35ff8542 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -174,6 +174,7 @@ renameDoc d = case d of
DocIdentifier x -> do
x' <- rename x
return (DocIdentifier x')
+ DocIdentifierUnchecked x -> return (DocIdentifierUnchecked x)
DocModule str -> return (DocModule str)
DocEmphasis doc -> do
doc' <- renameDoc doc
diff --git a/src/Haddock/Interface/Rn.hs b/src/Haddock/Interface/Rn.hs
index 57704db7..0b5efe4b 100644
--- a/src/Haddock/Interface/Rn.hs
+++ b/src/Haddock/Interface/Rn.hs
@@ -4,7 +4,7 @@ import Haddock.Types
import RnEnv ( dataTcOccs )
-import RdrName ( RdrName, gre_name, GlobalRdrEnv, lookupGRE_RdrName )
+import RdrName
import Name ( Name, isTyConName )
import Outputable ( ppr, showSDoc )
@@ -36,14 +36,20 @@ rnDoc gre = unId . do_rn
DocIdentifier x -> do
let choices = dataTcOccs x
- let gres = concatMap (\rdrName ->
- map gre_name (lookupGRE_RdrName rdrName gre)) choices
- return $ case gres of
- [] -> DocMonospaced (DocString (showSDoc $ ppr x)) -- TODO: DocIdentifierRdrName
- [a] -> DocIdentifier a
- a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b
- -- If an id can refer to multiple things, we give precedence to type
- -- constructors.
+ let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices
+ return $
+ case names of
+ [] ->
+ case choices of
+ [] -> DocMonospaced (DocString (showSDoc $ ppr x))
+ [a] -> outOfScope a
+ a:b:_ | isRdrTc a -> outOfScope a | otherwise -> outOfScope b
+ [a] -> DocIdentifier a
+ a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b
+ -- If an id can refer to multiple things, we give precedence to type
+ -- constructors.
+
+ DocIdentifierUnchecked x -> return (DocIdentifierUnchecked x)
DocModule str -> return (DocModule str)
@@ -81,3 +87,14 @@ rnDoc gre = unId . do_rn
DocAName str -> return (DocAName str)
DocExamples e -> return (DocExamples e)
+
+
+outOfScope :: RdrName -> Doc a
+outOfScope x =
+ case x of
+ Unqual occ -> monospaced occ
+ Qual mdl occ -> DocIdentifierUnchecked (mdl, occ)
+ Orig _ occ -> monospaced occ
+ Exact name -> monospaced name -- Shouldn't happen since x is out of scope
+ where
+ monospaced a = DocMonospaced (DocString (showSDoc $ ppr a))
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index c1b54b1b..1da46662 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -460,6 +460,9 @@ instance (Binary id) => Binary (Doc id) where
put_ bh (DocExamples ao) = do
putByte bh 15
put_ bh ao
+ put_ bh (DocIdentifierUnchecked x) = do
+ putByte bh 16
+ put_ bh x
get bh = do
h <- getByte bh
case h of
@@ -511,6 +514,9 @@ instance (Binary id) => Binary (Doc id) where
15 -> do
ao <- get bh
return (DocExamples ao)
+ 16 -> do
+ x <- get bh
+ return (DocIdentifierUnchecked x)
_ -> fail "invalid binary data found"
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 4989a067..fbaf89c5 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -26,6 +26,7 @@ import Data.Typeable
import Data.Map (Map)
import qualified Data.Map as Map
import GHC hiding (NoLink)
+import OccName
-----------------------------------------------------------------------------
@@ -276,7 +277,7 @@ data Doc id
| DocString String
| DocParagraph (Doc id)
| DocIdentifier id
--- | DocIdentifierOutOfScope [RdrName]
+ | DocIdentifierUnchecked (ModuleName, OccName)
| DocModule String
| DocEmphasis (Doc id)
| DocMonospaced (Doc id)
@@ -288,7 +289,7 @@ data Doc id
| DocPic String
| DocAName String
| DocExamples [Example]
- deriving (Eq, Show, Functor)
+ deriving (Eq, Functor)
unrenameDoc :: Doc DocName -> Doc Name
@@ -307,22 +308,23 @@ exampleToString (Example expression result) =
data DocMarkup id a = Markup
- { markupEmpty :: a
- , markupString :: String -> a
- , markupParagraph :: a -> a
- , markupAppend :: a -> a -> a
- , markupIdentifier :: id -> a
- , markupModule :: String -> a
- , markupEmphasis :: a -> a
- , markupMonospaced :: a -> a
- , markupUnorderedList :: [a] -> a
- , markupOrderedList :: [a] -> a
- , markupDefList :: [(a,a)] -> a
- , markupCodeBlock :: a -> a
- , markupURL :: String -> a
- , markupAName :: String -> a
- , markupPic :: String -> a
- , markupExample :: [Example] -> a
+ { markupEmpty :: a
+ , markupString :: String -> a
+ , markupParagraph :: a -> a
+ , markupAppend :: a -> a -> a
+ , markupIdentifier :: id -> a
+ , markupIdentifierUnchecked :: (ModuleName, OccName) -> a
+ , markupModule :: String -> a
+ , markupEmphasis :: a -> a
+ , markupMonospaced :: a -> a
+ , markupUnorderedList :: [a] -> a
+ , markupOrderedList :: [a] -> a
+ , markupDefList :: [(a,a)] -> a
+ , markupCodeBlock :: a -> a
+ , markupURL :: String -> a
+ , markupAName :: String -> a
+ , markupPic :: String -> a
+ , markupExample :: [Example] -> a
}
diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs
index 478025d8..de97ef85 100644
--- a/src/Haddock/Utils.hs
+++ b/src/Haddock/Utils.hs
@@ -17,7 +17,7 @@ module Haddock.Utils (
toDescription, toInstalledDescription,
-- * Filename utilities
- moduleHtmlFile,
+ moduleHtmlFile, moduleHtmlFile',
contentsHtmlFile, indexHtmlFile,
frameIndexHtmlFile,
moduleIndexFrameName, mainFrameName, synopsisFrameName,
@@ -25,7 +25,7 @@ module Haddock.Utils (
jsFile, framesFile,
-- * Anchor and URL utilities
- moduleNameUrl, moduleUrl,
+ moduleNameUrl, moduleNameUrl', moduleUrl,
nameAnchorId,
makeAnchorId,
@@ -33,7 +33,7 @@ module Haddock.Utils (
getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
-- * HTML cross reference mapping
- html_xrefs_ref,
+ html_xrefs_ref, html_xrefs_ref',
-- * Doc markup
markup,
@@ -172,15 +172,24 @@ restrictATs names ats = [ at | at <- ats , tcdName (unL at) `elem` names ]
--------------------------------------------------------------------------------
+baseName :: ModuleName -> FilePath
+baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString
+
+
moduleHtmlFile :: Module -> FilePath
moduleHtmlFile mdl =
case Map.lookup mdl html_xrefs of
- Nothing -> mdl' ++ ".html"
- Just fp0 -> HtmlPath.joinPath [fp0, mdl' ++ ".html"]
+ Nothing -> baseName mdl' ++ ".html"
+ Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl' ++ ".html"]
where
- mdl' = map (\c -> if c == '.' then '-' else c)
- (moduleNameString (moduleName mdl))
+ mdl' = moduleName mdl
+
+moduleHtmlFile' :: ModuleName -> FilePath
+moduleHtmlFile' mdl =
+ case Map.lookup mdl html_xrefs' of
+ Nothing -> baseName mdl ++ ".html"
+ Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"]
contentsHtmlFile, indexHtmlFile :: String
@@ -229,6 +238,10 @@ moduleNameUrl :: Module -> OccName -> String
moduleNameUrl mdl n = moduleUrl mdl ++ '#' : nameAnchorId n
+moduleNameUrl' :: ModuleName -> OccName -> String
+moduleNameUrl' mdl n = moduleHtmlFile' mdl ++ '#' : nameAnchorId n
+
+
nameAnchorId :: OccName -> String
nameAnchorId name = makeAnchorId (prefix : ':' : occNameString name)
where prefix | isValOcc name = 'v'
@@ -353,11 +366,21 @@ html_xrefs_ref :: IORef (Map Module FilePath)
html_xrefs_ref = unsafePerformIO (newIORef (error "module_map"))
+{-# NOINLINE html_xrefs_ref' #-}
+html_xrefs_ref' :: IORef (Map ModuleName FilePath)
+html_xrefs_ref' = unsafePerformIO (newIORef (error "module_map"))
+
+
{-# NOINLINE html_xrefs #-}
html_xrefs :: Map Module FilePath
html_xrefs = unsafePerformIO (readIORef html_xrefs_ref)
+{-# NOINLINE html_xrefs' #-}
+html_xrefs' :: Map ModuleName FilePath
+html_xrefs' = unsafePerformIO (readIORef html_xrefs_ref')
+
+
-----------------------------------------------------------------------------
-- * List utils
-----------------------------------------------------------------------------
@@ -380,22 +403,23 @@ spanWith p xs@(a:as)
markup :: DocMarkup id a -> Doc id -> a
-markup m DocEmpty = markupEmpty m
-markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
-markup m (DocString s) = markupString m s
-markup m (DocParagraph d) = markupParagraph m (markup m d)
-markup m (DocIdentifier x) = markupIdentifier m x
-markup m (DocModule mod0) = markupModule m mod0
-markup m (DocEmphasis d) = markupEmphasis m (markup m d)
-markup m (DocMonospaced d) = markupMonospaced m (markup m d)
-markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
-markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
-markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds)
-markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
-markup m (DocURL url) = markupURL m url
-markup m (DocAName ref) = markupAName m ref
-markup m (DocPic img) = markupPic m img
-markup m (DocExamples e) = markupExample m e
+markup m DocEmpty = markupEmpty m
+markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
+markup m (DocString s) = markupString m s
+markup m (DocParagraph d) = markupParagraph m (markup m d)
+markup m (DocIdentifier x) = markupIdentifier m x
+markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x
+markup m (DocModule mod0) = markupModule m mod0
+markup m (DocEmphasis d) = markupEmphasis m (markup m d)
+markup m (DocMonospaced d) = markupMonospaced m (markup m d)
+markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
+markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
+markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds)
+markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
+markup m (DocURL url) = markupURL m url
+markup m (DocAName ref) = markupAName m ref
+markup m (DocPic img) = markupPic m img
+markup m (DocExamples e) = markupExample m e
markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a)
@@ -405,22 +429,23 @@ markupPair m (a,b) = (markup m a, markup m b)
-- | The identity markup
idMarkup :: DocMarkup a (Doc a)
idMarkup = Markup {
- markupEmpty = DocEmpty,
- markupString = DocString,
- markupParagraph = DocParagraph,
- markupAppend = DocAppend,
- markupIdentifier = DocIdentifier,
- markupModule = DocModule,
- markupEmphasis = DocEmphasis,
- markupMonospaced = DocMonospaced,
- markupUnorderedList = DocUnorderedList,
- markupOrderedList = DocOrderedList,
- markupDefList = DocDefList,
- markupCodeBlock = DocCodeBlock,
- markupURL = DocURL,
- markupAName = DocAName,
- markupPic = DocPic,
- markupExample = DocExamples
+ markupEmpty = DocEmpty,
+ markupString = DocString,
+ markupParagraph = DocParagraph,
+ markupAppend = DocAppend,
+ markupIdentifier = DocIdentifier,
+ markupIdentifierUnchecked = DocIdentifierUnchecked,
+ markupModule = DocModule,
+ markupEmphasis = DocEmphasis,
+ markupMonospaced = DocMonospaced,
+ markupUnorderedList = DocUnorderedList,
+ markupOrderedList = DocOrderedList,
+ markupDefList = DocDefList,
+ markupCodeBlock = DocCodeBlock,
+ markupURL = DocURL,
+ markupAName = DocAName,
+ markupPic = DocPic,
+ markupExample = DocExamples
}
diff --git a/src/Main.hs b/src/Main.hs
index f78ace69..0a3c9ffc 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -228,7 +228,7 @@ render flags ifaces installedIfaces srcMap = do
when (Flag_GenContents `elem` flags) $ do
ppHtmlContents odir title pkgStr
themes opt_index_url sourceUrls' opt_wiki_urls
- allVisibleIfaces True prologue pretty
+ allVisibleIfaces True prologue pretty opt_qualification
copyHtmlBits odir libDir themes
when (Flag_Html `elem` flags) $ do
@@ -393,10 +393,13 @@ shortcutFlags flags = do
updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()
-updateHTMLXRefs packages = writeIORef html_xrefs_ref (Map.fromList mapping)
+updateHTMLXRefs packages = do
+ writeIORef html_xrefs_ref (Map.fromList mapping)
+ writeIORef html_xrefs_ref' (Map.fromList mapping')
where
mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages
, iface <- ifInstalledIfaces ifaces ]
+ mapping' = [ (moduleName m, html) | (m, html) <- mapping ]
getPrologue :: [Flag] -> IO (Maybe (Doc RdrName))
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 01:25:31 +0000