From e41c1cbe9f0476997eac7b4a3f17cbc6b2262faf Mon Sep 17 00:00:00 2001 From: Tim Baumann Date: Mon, 9 Oct 2017 18:33:09 +0200 Subject: Use
element for collapsibles (#690) * Remove unnecessary call to 'collapseSection' The call is unnecessary since there is no corresponding toggle for hiding the section of orphan instances. * Use
for collapsibles This makes them work even when JS is disabled. Closes #560. --- haddock-api/src/Haddock/Backends/Xhtml.hs | 21 ++++++++----- .../src/Haddock/Backends/Xhtml/DocMarkup.hs | 6 ++-- haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 14 +++++---- haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 35 ++++++++++------------ 4 files changed, 41 insertions(+), 35 deletions(-) (limited to 'haddock-api/src') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index e8148782..c76c0c88 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -310,11 +310,11 @@ mkNode qual ss p (Node s leaf pkg srcPkg short ts) = htmlModule <+> shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of - (_:_, False) -> collapseControl p True "module" + (_:_, False) -> collapseControl p "module" (_, _ ) -> [theclass "module"] cBtn = case (ts, leaf) of - (_:_, True) -> thespan ! collapseControl p True "" << spaceHtml + (_:_, True) -> thespan ! collapseControl p "" << spaceHtml (_, _ ) -> noHtml -- We only need an explicit collapser button when the module name -- is also a leaf, and so is a link to a module page. Indeed, the @@ -332,7 +332,12 @@ mkNode qual ss p (Node s leaf pkg srcPkg short ts) = shortDescr = maybe noHtml (origDocToHtml qual) short htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg - subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True "" + subtree = + if null ts then noHtml else + collapseDetails p DetailsOpen ( + thesummary ! [ theclass "hide-when-js-enabled" ] << "Submodules" +++ + mkNodeList qual (s:ss) p ts + ) @@ -586,10 +591,12 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual | no_doc_at_all = noHtml | otherwise = divSynopsis $ - paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ - shortDeclList ( - mapMaybe (processExport True linksInfo unicode qual) exports - ) ! (collapseSection "syn" False "" ++ collapseToggle "syn") + collapseDetails "syn" DetailsClosed ( + thesummary << "Synopsis" +++ + shortDeclList ( + mapMaybe (processExport True linksInfo unicode qual) exports + ) ! collapseToggle "syn" "" + ) -- if the documentation doesn't begin with a section header, then -- add one ("Documentation"). diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 18c8a0ff..e63667b0 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -165,9 +165,9 @@ hackMarkup fmt' h' = UntouchedDoc d -> (markup fmt $ _doc d, [_meta d]) CollapsingHeader (Header lvl titl) par n nm -> let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n - expanded = False - col' = collapseControl id_ expanded "caption" - instTable = (thediv ! collapseSection id_ expanded [] <<) + col' = collapseControl id_ "caption" + summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Expand" + instTable contents = collapseDetails id_ DetailsClosed (summary +++ contents) lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6] getHeader = fromMaybe caption (lookup lvl lvs) subCaption = getHeader ! col' << markup fmt titl diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index 6993c7f6..e020b909 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -199,10 +199,10 @@ subInstances :: Qualification -> [(SubDecl,Located DocName)] -> Html subInstances qual nm lnks splice = maybe noHtml wrap . instTable where - wrap = (subSection <<) . (subCaption +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice + wrap contents = subSection (collapseDetails id_ DetailsOpen (summary +++ contents)) + instTable = subTableSrc qual lnks splice subSection = thediv ! [theclass "subs instances"] - subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" + summary = thesummary << "Instances" id_ = makeAnchorId $ "i:" ++ nm @@ -212,7 +212,7 @@ subOrphanInstances :: Qualification subOrphanInstances qual lnks splice = maybe noHtml wrap . instTable where wrap = ((h1 << "Orphan instances") +++) - instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice + instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc qual lnks splice id_ = makeAnchorId $ "orphans" @@ -222,7 +222,7 @@ subInstHead :: String -- ^ Instance unique id (for anchor generation) subInstHead iid hdr = expander noHtml <+> hdr where - expander = thespan ! collapseControl (instAnchorId iid) False "instance" + expander = thespan ! collapseControl (instAnchorId iid) "instance" subInstDetails :: String -- ^ Instance unique id (for anchor generation) @@ -241,7 +241,9 @@ subFamInstDetails iid fi = subInstSection :: String -- ^ Instance unique id (for anchor generation) -> Html -> Html -subInstSection iid = thediv ! collapseSection (instAnchorId iid) False "inst-details" +subInstSection iid contents = collapseDetails (instAnchorId iid) DetailsClosed (summary +++ contents) + where + summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Instance details" instAnchorId :: String -> String instAnchorId iid = makeAnchorId $ "i:" ++ iid diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index a8b4a4ec..a75c4b9a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -25,7 +25,8 @@ module Haddock.Backends.Xhtml.Utils ( hsep, vcat, - collapseSection, collapseToggle, collapseControl, + DetailsState(..), collapseDetails, thesummary, + collapseToggle, collapseControl, ) where @@ -213,26 +214,22 @@ groupId g = makeAnchorId ("g:" ++ g) -- A section of HTML which is collapsible. -- --- | Attributes for an area that can be collapsed -collapseSection :: String -> Bool -> String -> [HtmlAttr] -collapseSection id_ state classes = [ identifier sid, theclass cs ] - where cs = unwords (words classes ++ [pick state "show" "hide"]) - sid = "section." ++ id_ +data DetailsState = DetailsOpen | DetailsClosed + +collapseDetails :: String -> DetailsState -> Html -> Html +collapseDetails id_ state = tag "details" ! (identifier id_ : openAttrs) + where openAttrs = case state of { DetailsOpen -> [emptyAttr "open"]; DetailsClosed -> [] } + +thesummary :: Html -> Html +thesummary = tag "summary" -- | Attributes for an area that toggles a collapsed area -collapseToggle :: String -> [HtmlAttr] -collapseToggle id_ = [ strAttr "onclick" js ] - where js = "toggleSection('" ++ id_ ++ "')"; +collapseToggle :: String -> String -> [HtmlAttr] +collapseToggle id_ classes = [ theclass cs, strAttr "data-details-id" id_ ] + where cs = unwords (words classes ++ ["details-toggle"]) -- | Attributes for an area that toggles a collapsed area, -- and displays a control. -collapseControl :: String -> Bool -> String -> [HtmlAttr] -collapseControl id_ state classes = - [ identifier cid, theclass cs ] ++ collapseToggle id_ - where cs = unwords (words classes ++ [pick state "collapser" "expander"]) - cid = "control." ++ id_ - - -pick :: Bool -> a -> a -> a -pick True t _ = t -pick False _ f = f +collapseControl :: String -> String -> [HtmlAttr] +collapseControl id_ classes = collapseToggle id_ cs + where cs = unwords (words classes ++ ["details-toggle-control"]) \ No newline at end of file -- cgit v1.2.3 From aca68f620beb07f9bdebdf52948c6ea670be4980 Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Mon, 30 Oct 2017 08:45:51 +0100 Subject: Add QuickJump version to meta.json (#696) --- haddock-api/haddock-api.cabal | 2 +- haddock-api/src/Haddock.hs | 2 +- haddock-api/src/Haddock/Backends/Meta.hs | 22 -------------------- haddock-api/src/Haddock/Backends/Xhtml/Meta.hs | 28 ++++++++++++++++++++++++++ haddock.cabal | 2 +- 5 files changed, 31 insertions(+), 25 deletions(-) delete mode 100644 haddock-api/src/Haddock/Backends/Meta.hs create mode 100644 haddock-api/src/Haddock/Backends/Xhtml/Meta.hs (limited to 'haddock-api/src') diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index 5ce35b94..9b580a56 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -86,12 +86,12 @@ library Haddock.Backends.Xhtml.Decl Haddock.Backends.Xhtml.DocMarkup Haddock.Backends.Xhtml.Layout + Haddock.Backends.Xhtml.Meta Haddock.Backends.Xhtml.Names Haddock.Backends.Xhtml.Themes Haddock.Backends.Xhtml.Types Haddock.Backends.Xhtml.Utils Haddock.Backends.LaTeX - Haddock.Backends.Meta Haddock.Backends.HaddockDB Haddock.Backends.Hoogle Haddock.Backends.Hyperlinker diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 17951068..a46e58b3 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -27,9 +27,9 @@ module Haddock ( import Data.Version import Haddock.Backends.Xhtml +import Haddock.Backends.Xhtml.Meta import Haddock.Backends.Xhtml.Themes (getThemes) import Haddock.Backends.LaTeX -import Haddock.Backends.Meta import Haddock.Backends.Hoogle import Haddock.Backends.Hyperlinker import Haddock.Interface diff --git a/haddock-api/src/Haddock/Backends/Meta.hs b/haddock-api/src/Haddock/Backends/Meta.hs deleted file mode 100644 index c62c1ae8..00000000 --- a/haddock-api/src/Haddock/Backends/Meta.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Haddock.Backends.Meta where - -import Haddock.Utils.Json -import Haddock.Version - -import Data.ByteString.Builder (hPutBuilder) -import System.FilePath (()) -import System.IO (withFile, IOMode (WriteMode)) - --- | Writes a json encoded file containing additional --- information about the generated documentation. This --- is useful for external tools (e.g. hackage). -writeHaddockMeta :: FilePath -> IO () -writeHaddockMeta odir = do - let - meta_json :: Value - meta_json = object [ - "haddock_version" .= String projectVersion - ] - - withFile (odir "meta.json") WriteMode $ \h -> - hPutBuilder h (encodeToBuilder meta_json) \ No newline at end of file diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs b/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs new file mode 100644 index 00000000..5cf03ec4 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs @@ -0,0 +1,28 @@ +module Haddock.Backends.Xhtml.Meta where + +import Haddock.Utils.Json +import Haddock.Version + +import Data.ByteString.Builder (hPutBuilder) +import System.FilePath (()) +import System.IO (withFile, IOMode (WriteMode)) + +-- | Everytime breaking changes to the Quckjump api +-- happen this needs to be modified. +quickjumpVersion :: Int +quickjumpVersion = 1 + +-- | Writes a json encoded file containing additional +-- information about the generated documentation. This +-- is useful for external tools (e.g. hackage). +writeHaddockMeta :: FilePath -> IO () +writeHaddockMeta odir = do + let + meta_json :: Value + meta_json = object [ + "haddock_version" .= String projectVersion + , "quickjump_version" .= quickjumpVersion + ] + + withFile (odir "meta.json") WriteMode $ \h -> + hPutBuilder h (encodeToBuilder meta_json) \ No newline at end of file diff --git a/haddock.cabal b/haddock.cabal index 51f71272..40ccb55e 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -120,12 +120,12 @@ executable haddock Haddock.Backends.Xhtml.Decl Haddock.Backends.Xhtml.DocMarkup Haddock.Backends.Xhtml.Layout + Haddock.Backends.Xhtml.Meta Haddock.Backends.Xhtml.Names Haddock.Backends.Xhtml.Themes Haddock.Backends.Xhtml.Types Haddock.Backends.Xhtml.Utils Haddock.Backends.LaTeX - Haddock.Backends.Meta Haddock.Backends.HaddockDB Haddock.Backends.Hoogle Haddock.Backends.Hyperlinker -- cgit v1.2.3 From 0f181c4a70ef5e4753545cd9e0734a015bb815e1 Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Mon, 30 Oct 2017 10:15:49 +0100 Subject: Put Quickjump behind --quickjump flag (#697) --- haddock-api/src/Haddock.hs | 12 +++++++----- haddock-api/src/Haddock/Backends/Xhtml.hs | 19 +++++++++++-------- haddock-api/src/Haddock/Backends/Xhtml/Meta.hs | 14 +++++++------- haddock-api/src/Haddock/Options.hs | 3 +++ 4 files changed, 28 insertions(+), 20 deletions(-) (limited to 'haddock-api/src') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index a46e58b3..7b4b8671 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -300,27 +300,29 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do prologue <- getPrologue dflags' flags themes <- getThemes libDir flags >>= either bye return + let withQuickjump = Flag_QuickJumpIndex `elem` flags + when (Flag_GenIndex `elem` flags) $ do ppHtmlIndex odir title pkgStr themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls allVisibleIfaces pretty - copyHtmlBits odir libDir themes + copyHtmlBits odir libDir themes withQuickjump when (Flag_GenContents `elem` flags) $ do ppHtmlContents dflags' odir title pkgStr themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty (makeContentsQual qual) - copyHtmlBits odir libDir themes + copyHtmlBits odir libDir themes withQuickjump when (Flag_Html `elem` flags) $ do ppHtml dflags' title pkgStr visibleIfaces odir prologue themes opt_mathjax sourceUrls' opt_wiki_urls opt_contents_url opt_index_url unicode qual - pretty - copyHtmlBits odir libDir themes - writeHaddockMeta odir + pretty withQuickjump + copyHtmlBits odir libDir themes withQuickjump + writeHaddockMeta odir withQuickjump -- TODO: we throw away Meta for both Hoogle and LaTeX right now, -- might want to fix that if/when these two get some work on them diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index c76c0c88..8205f658 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -55,7 +55,6 @@ import Module -- * Generating HTML documentation -------------------------------------------------------------------------------- - ppHtml :: DynFlags -> String -- ^ Title -> Maybe String -- ^ Package @@ -71,12 +70,13 @@ ppHtml :: DynFlags -> Bool -- ^ Whether to use unicode in output (--use-unicode) -> QualOption -- ^ How to qualify names -> Bool -- ^ Output pretty html (newlines and indenting) + -> Bool -- ^ Also write Quickjump index -> IO () ppHtml dflags doctitle maybe_package ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode - qual debug = do + qual debug withQuickjump = do let visible_ifaces = filter visible ifaces visible i = OptHide `notElem` ifaceOptions i @@ -92,24 +92,27 @@ ppHtml dflags doctitle maybe_package ifaces odir prologue ppHtmlIndex odir doctitle maybe_package themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces) debug - ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual - visible_ifaces + + when withQuickjump $ + ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual + visible_ifaces mapM_ (ppHtmlModule odir doctitle themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces -copyHtmlBits :: FilePath -> FilePath -> Themes -> IO () -copyHtmlBits odir libdir themes = do +copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO () +copyHtmlBits odir libdir themes withQuickjump = do let libhtmldir = joinPath [libdir, "html"] copyCssFile f = copyFile f (combine odir (takeFileName f)) copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f]) mapM_ copyCssFile (cssFiles themes) - copyCssFile (joinPath [libhtmldir, quickJumpCssFile]) copyLibFile haddockJsFile - copyLibFile jsQuickJumpFile + when withQuickjump $ do + copyCssFile (joinPath [libhtmldir, quickJumpCssFile]) + copyLibFile jsQuickJumpFile return () diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs b/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs index 5cf03ec4..621bdd41 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs @@ -15,14 +15,14 @@ quickjumpVersion = 1 -- | Writes a json encoded file containing additional -- information about the generated documentation. This -- is useful for external tools (e.g. hackage). -writeHaddockMeta :: FilePath -> IO () -writeHaddockMeta odir = do +writeHaddockMeta :: FilePath -> Bool -> IO () +writeHaddockMeta odir withQuickjump = do let meta_json :: Value - meta_json = object [ - "haddock_version" .= String projectVersion - , "quickjump_version" .= quickjumpVersion - ] + meta_json = object (concat [ + [ "haddock_version" .= String projectVersion ] + , [ "quickjump_version" .= quickjumpVersion | withQuickjump ] + ]) withFile (odir "meta.json") WriteMode $ \h -> - hPutBuilder h (encodeToBuilder meta_json) \ No newline at end of file + hPutBuilder h (encodeToBuilder meta_json) diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index d73d1a79..59d2c8a7 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -70,6 +70,7 @@ data Flag | Flag_WikiEntityURL String | Flag_LaTeX | Flag_LaTeXStyle String + | Flag_QuickJumpIndex | Flag_HyperlinkedSource | Flag_SourceCss String | Flag_Mathjax String @@ -126,6 +127,8 @@ options backwardsCompat = Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", Option [] ["hoogle"] (NoArg Flag_Hoogle) "output for Hoogle; you may want --package-name and --package-version too", + Option [] ["quickjump"] (NoArg Flag_QuickJumpIndex) + "generate an index for interactive documentation navigation", Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource) "generate highlighted and hyperlinked source code (for use with --html)", Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE") -- cgit v1.2.3 From aec8868cb317afb827e890faba4c80f3e1a574d7 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Wed, 10 Aug 2016 23:43:55 -0700 Subject: Supported reexported-modules via --reexport flag. Signed-off-by: Edward Z. Yang --- CHANGES.md | 5 ++++- haddock-api/src/Haddock.hs | 20 +++++++++++++++++++- haddock-api/src/Haddock/Backends/Xhtml.hs | 25 +++++++++++-------------- haddock-api/src/Haddock/ModuleTree.hs | 30 ++++++++++++++++-------------- haddock-api/src/Haddock/Options.hs | 7 +++++++ 5 files changed, 57 insertions(+), 30 deletions(-) (limited to 'haddock-api/src') diff --git a/CHANGES.md b/CHANGES.md index 0b4ca29d..dd39c563 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,9 @@ * to be released + * A --reexport flag, which can be used to add extra modules to the + top-level module tree + * Haddock no longer reports coverage statistics for hidden modules. By default cabal-install marks all package internal modules as hidden. @@ -44,7 +47,7 @@ * Remove framed view of the HTML documentation -## Changes in version 2.17.2 +Changes in version 2.17.2 * Fix portability of documentation building within GHC diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 7b4b8671..d9bc3ea6 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -67,6 +67,7 @@ import Paths_haddock_api (getDataDir) import System.Directory (doesDirectoryExist) #endif +import Text.ParserCombinators.ReadP (readP_to_S) import GHC hiding (verbosity) import Config import DynFlags hiding (projectVersion, verbosity) @@ -296,6 +297,23 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap') + -- TODO: This silently suppresses errors + installedMap :: Map Module InstalledInterface + installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- installedIfaces ] + + -- The user gives use base-4.9.0.0, but the InstalledInterface + -- records the *wired in* identity base. So untranslate it + -- so that we can service the request. + unwire :: Module -> Module + unwire m = m { moduleUnitId = unwireUnitId dflags (moduleUnitId m) } + + reexportedIfaces = + [ iface + | mod_str <- reexportFlags flags + , (m, "") <- readP_to_S parseModuleId mod_str + , Just iface <- [Map.lookup m installedMap] + ] + libDir <- getHaddockLibDir flags prologue <- getPrologue dflags' flags themes <- getThemes libDir flags >>= either bye return @@ -316,7 +334,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do copyHtmlBits odir libDir themes withQuickjump when (Flag_Html `elem` flags) $ do - ppHtml dflags' title pkgStr visibleIfaces odir + ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir prologue themes opt_mathjax sourceUrls' opt_wiki_urls opt_contents_url opt_index_url unicode qual diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 8205f658..04a066a7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -37,7 +37,7 @@ import Haddock.GhcUtils import Control.Monad ( when, unless ) import Data.Char ( toUpper, isSpace ) -import Data.List ( sortBy, intercalate, isPrefixOf, intersperse ) +import Data.List ( sortBy, isPrefixOf, intercalate, intersperse ) import Data.Maybe import System.FilePath hiding ( () ) import System.Directory @@ -49,7 +49,6 @@ import Data.Ord ( comparing ) import DynFlags (Language(..)) import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) ) import Name -import Module -------------------------------------------------------------------------------- -- * Generating HTML documentation @@ -59,6 +58,7 @@ ppHtml :: DynFlags -> String -- ^ Title -> Maybe String -- ^ Package -> [Interface] + -> [InstalledInterface] -- ^ Reexported interfaces -> FilePath -- ^ Destination directory -> Maybe (MDoc GHC.RdrName) -- ^ Prologue text, maybe -> Themes -- ^ Themes @@ -73,7 +73,7 @@ ppHtml :: DynFlags -> Bool -- ^ Also write Quickjump index -> IO () -ppHtml dflags doctitle maybe_package ifaces odir prologue +ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue themes maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode qual debug withQuickjump = do @@ -84,14 +84,14 @@ ppHtml dflags doctitle maybe_package ifaces odir prologue when (isNothing maybe_contents_url) $ ppHtmlContents dflags odir doctitle maybe_package themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url - (map toInstalledIface visible_ifaces) + (map toInstalledIface visible_ifaces ++ reexported_ifaces) False -- we don't want to display the packages in a single-package contents prologue debug (makeContentsQual qual) when (isNothing maybe_index_url) $ do ppHtmlIndex odir doctitle maybe_package themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url - (map toInstalledIface visible_ifaces) debug + (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug when withQuickjump $ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual @@ -309,29 +309,26 @@ mkNodeList qual ss p ts = case ts of mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html -mkNode qual ss p (Node s leaf pkg srcPkg short ts) = +mkNode qual ss p (Node s leaf _pkg srcPkg short ts) = htmlModule <+> shortDescr +++ htmlPkg +++ subtree where modAttrs = case (ts, leaf) of - (_:_, False) -> collapseControl p "module" + (_:_, Nothing) -> collapseControl p "module" (_, _ ) -> [theclass "module"] cBtn = case (ts, leaf) of - (_:_, True) -> thespan ! collapseControl p "" << spaceHtml + (_:_, Just _) -> thespan ! collapseControl p "" << spaceHtml (_, _ ) -> noHtml -- We only need an explicit collapser button when the module name -- is also a leaf, and so is a link to a module page. Indeed, the -- spaceHtml is a minor hack and does upset the layout a fraction. htmlModule = thespan ! modAttrs << (cBtn +++ - if leaf - then ppModule (mkModule (stringToUnitId (fromMaybe "" pkg)) - (mkModuleName mdl)) - else toHtml s + case leaf of + Just m -> ppModule m + Nothing -> toHtml s ) - mdl = intercalate "." (reverse (s:ss)) - shortDescr = maybe noHtml (origDocToHtml qual) short htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs index e6cf8201..a0be820a 100644 --- a/haddock-api/src/Haddock/ModuleTree.hs +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -20,39 +20,41 @@ import DynFlags ( DynFlags ) import Packages ( lookupPackage ) import PackageConfig ( sourcePackageIdString ) +import qualified Control.Applicative as A -data ModuleTree = Node String Bool (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] + +data ModuleTree = Node String (Maybe Module) (Maybe String) (Maybe String) (Maybe (MDoc Name)) [ModuleTree] mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree] mkModuleTree dflags showPkgs mods = - foldr fn [] [ (splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] + foldr fn [] [ (mdl, splitModule mdl, modPkg mdl, modSrcPkg mdl, short) | (mdl, short) <- mods ] where modPkg mod_ | showPkgs = Just (unitIdString (moduleUnitId mod_)) | otherwise = Nothing modSrcPkg mod_ | showPkgs = fmap sourcePackageIdString (lookupPackage dflags (moduleUnitId mod_)) | otherwise = Nothing - fn (mod_,pkg,srcPkg,short) = addToTrees mod_ pkg srcPkg short + fn (m,mod_,pkg,srcPkg,short) = addToTrees mod_ m pkg srcPkg short -addToTrees :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] -addToTrees [] _ _ _ ts = ts -addToTrees ss pkg srcPkg short [] = mkSubTree ss pkg srcPkg short -addToTrees (s1:ss) pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts) - | s1 > s2 = t : addToTrees (s1:ss) pkg srcPkg short ts - | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_srcPkg this_short (addToTrees ss pkg srcPkg short subs) : ts - | otherwise = mkSubTree (s1:ss) pkg srcPkg short ++ t : ts +addToTrees :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] +addToTrees [] _ _ _ _ ts = ts +addToTrees ss m pkg srcPkg short [] = mkSubTree ss m pkg srcPkg short +addToTrees (s1:ss) m pkg srcPkg short (t@(Node s2 leaf node_pkg node_srcPkg node_short subs) : ts) + | s1 > s2 = t : addToTrees (s1:ss) m pkg srcPkg short ts + | s1 == s2 = Node s2 (leaf A.<|> (if null ss then Just m else Nothing)) this_pkg this_srcPkg this_short (addToTrees ss m pkg srcPkg short subs) : ts + | otherwise = mkSubTree (s1:ss) m pkg srcPkg short ++ t : ts where this_pkg = if null ss then pkg else node_pkg this_srcPkg = if null ss then srcPkg else node_srcPkg this_short = if null ss then short else node_short -mkSubTree :: [String] -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -mkSubTree [] _ _ _ = [] -mkSubTree [s] pkg srcPkg short = [Node s True pkg srcPkg short []] -mkSubTree (s:ss) pkg srcPkg short = [Node s (null ss) Nothing Nothing Nothing (mkSubTree ss pkg srcPkg short)] +mkSubTree :: [String] -> Module -> Maybe String -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] +mkSubTree [] _ _ _ _ = [] +mkSubTree [s] m pkg srcPkg short = [Node s (Just m) pkg srcPkg short []] +mkSubTree (s:s':ss) m pkg srcPkg short = [Node s Nothing Nothing Nothing Nothing (mkSubTree (s':ss) m pkg srcPkg short)] splitModule :: Module -> [String] diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs index 59d2c8a7..caf1fefe 100644 --- a/haddock-api/src/Haddock/Options.hs +++ b/haddock-api/src/Haddock/Options.hs @@ -31,6 +31,7 @@ module Haddock.Options ( qualification, verbosity, ghcFlags, + reexportFlags, readIfaceArgs, optPackageName, optPackageVersion @@ -99,6 +100,7 @@ data Flag | Flag_NoPrintMissingDocs | Flag_PackageName String | Flag_PackageVersion String + | Flag_Reexport String deriving (Eq, Show) @@ -197,6 +199,8 @@ options backwardsCompat = "generate html with newlines and indenting (for use with --html)", Option [] ["no-print-missing-docs"] (NoArg Flag_NoPrintMissingDocs) "don't print information about any undocumented entities", + Option [] ["reexport"] (ReqArg Flag_Reexport "MOD") + "reexport the module MOD, adding it to the index", Option [] ["package-name"] (ReqArg Flag_PackageName "NAME") "name of the package being documented", Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION") @@ -313,6 +317,9 @@ verbosity flags = ghcFlags :: [Flag] -> [String] ghcFlags flags = [ option | Flag_OptGhc option <- flags ] +reexportFlags :: [Flag] -> [String] +reexportFlags flags = [ option | Flag_Reexport option <- flags ] + readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)] readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ] -- cgit v1.2.3 From 75c784e474bd1fc824e2f0214f37908d0d4410c3 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Tue, 31 Oct 2017 20:59:07 +0100 Subject: Copy quickjump.css for nicer error messages --- haddock-api/src/Haddock/Backends/Xhtml.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'haddock-api/src') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 04a066a7..d43de2ad 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -110,9 +110,9 @@ copyHtmlBits odir libdir themes withQuickjump = do copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f]) mapM_ copyCssFile (cssFiles themes) copyLibFile haddockJsFile - when withQuickjump $ do - copyCssFile (joinPath [libhtmldir, quickJumpCssFile]) - copyLibFile jsQuickJumpFile + copyCssFile (joinPath [libhtmldir, quickJumpCssFile]) + when withQuickjump + (copyLibFile jsQuickJumpFile) return () -- cgit v1.2.3 From dbb505ca7e196697336ff82a931e98dbf0ad2aaa Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Tue, 31 Oct 2017 21:31:18 +0100 Subject: Reexported modules: Report warnings if argument cannot be parsed or ... module cannot be found --- haddock-api/src/Haddock.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) (limited to 'haddock-api/src') diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index d9bc3ea6..4b4bad4c 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -44,6 +44,7 @@ import Haddock.Utils import Control.Monad hiding (forM_) import Control.Applicative import Data.Foldable (forM_) +import Data.Traversable (for) import Data.List (isPrefixOf) import Control.Exception import Data.Maybe @@ -297,7 +298,6 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap') - -- TODO: This silently suppresses errors installedMap :: Map Module InstalledInterface installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- installedIfaces ] @@ -307,12 +307,15 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do unwire :: Module -> Module unwire m = m { moduleUnitId = unwireUnitId dflags (moduleUnitId m) } - reexportedIfaces = - [ iface - | mod_str <- reexportFlags flags - , (m, "") <- readP_to_S parseModuleId mod_str - , Just iface <- [Map.lookup m installedMap] - ] + reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do + let warn = hPutStrLn stderr . ("Warning: " ++) + case readP_to_S parseModuleId mod_str of + [(m, "")] + | Just iface <- Map.lookup m installedMap + -> return [iface] + | otherwise + -> warn ("Cannot find reexported module '" ++ mod_str ++ "'") >> return [] + _ -> warn ("Cannot parse reexported module flag '" ++ mod_str ++ "'") >> return []) libDir <- getHaddockLibDir flags prologue <- getPrologue dflags' flags -- cgit v1.2.3 From 281bb7dc19b0993622cb91b15007fb246cddb043 Mon Sep 17 00:00:00 2001 From: Carlo Hamalainen Date: Wed, 1 Nov 2017 04:43:14 +0800 Subject: More general type for nameCacheFromGhc. (#539) --- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src') diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 054c1384..31881c76 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -158,7 +158,7 @@ writeInterfaceFile filename iface = do type NameCacheAccessor m = (m NameCache, NameCache -> m ()) -nameCacheFromGhc :: NameCacheAccessor Ghc +nameCacheFromGhc :: forall m. (GhcMonad m, MonadIO m) => NameCacheAccessor m nameCacheFromGhc = ( read_from_session , write_to_session ) where read_from_session = do -- cgit v1.2.3 From e5fe98530d9c70f5197494da9de07f42dd7fe334 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Tue, 31 Oct 2017 21:46:52 +0100 Subject: Remote tab --- haddock-api/src/Haddock/Backends/Xhtml.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'haddock-api/src') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index d43de2ad..cf8d7e4f 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -111,8 +111,7 @@ copyHtmlBits odir libdir themes withQuickjump = do mapM_ copyCssFile (cssFiles themes) copyLibFile haddockJsFile copyCssFile (joinPath [libhtmldir, quickJumpCssFile]) - when withQuickjump - (copyLibFile jsQuickJumpFile) + when withQuickjump (copyLibFile jsQuickJumpFile) return () -- cgit v1.2.3