From 1345132fd141b8d9b12e858ccc0765272f703e49 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sat, 26 Nov 2011 17:01:06 +0100 Subject: Allow doc comments to link to out-of-scope things (#78). (A bug that should have been fixed long ago.) --- src/Haddock/Backends/Hoogle.hs | 33 +++++----- src/Haddock/Backends/LaTeX.hs | 37 ++++++------ src/Haddock/Backends/Xhtml.hs | 38 ++++++------ src/Haddock/Backends/Xhtml/DocMarkup.hs | 53 ++++++++-------- src/Haddock/Backends/Xhtml/Names.hs | 14 ++++- src/Haddock/Interface/Rename.hs | 1 + src/Haddock/Interface/Rn.hs | 35 ++++++++--- src/Haddock/InterfaceFile.hs | 6 ++ src/Haddock/Types.hs | 38 ++++++------ src/Haddock/Utils.hs | 103 ++++++++++++++++++++------------ src/Main.hs | 7 ++- 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)) -- cgit v1.2.3