aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/Meta.hs22
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml.hs60
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs6
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs14
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Meta.hs28
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Utils.hs35
6 files changed, 88 insertions, 77 deletions
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.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 4055b1d6..55175163 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,17 +49,16 @@ import Data.Ord ( comparing )
import DynFlags (Language(..))
import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) )
import Name
-import Module
--------------------------------------------------------------------------------
-- * Generating HTML documentation
--------------------------------------------------------------------------------
-
ppHtml :: DynFlags
-> String -- ^ Title
-> Maybe String -- ^ Package
-> [Interface]
+ -> [InstalledInterface] -- ^ Reexported interfaces
-> FilePath -- ^ Destination directory
-> Maybe (MDoc GHC.RdrName) -- ^ Prologue text, maybe
-> Themes -- ^ Themes
@@ -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
+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 = do
+ qual debug withQuickjump = do
let
visible_ifaces = filter visible ifaces
visible i = OptHide `notElem` ifaceOptions i
@@ -84,32 +84,34 @@ 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
- ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual
- visible_ifaces
+ (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug
+
+ 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
+ copyCssFile (joinPath [libhtmldir, quickJumpCssFile])
+ when withQuickjump (copyLibFile jsQuickJumpFile)
return ()
@@ -306,33 +308,35 @@ 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 True "module"
+ (_:_, Nothing) -> collapseControl p "module"
(_, _ ) -> [theclass "module"]
cBtn = case (ts, leaf) of
- (_:_, True) -> thespan ! collapseControl p True "" << 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
- 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
+ )
@@ -587,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/Meta.hs b/haddock-api/src/Haddock/Backends/Xhtml/Meta.hs
new file mode 100644
index 00000000..621bdd41
--- /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 -> Bool -> IO ()
+writeHaddockMeta odir withQuickjump = do
+ let
+ meta_json :: Value
+ meta_json = object (concat [
+ [ "haddock_version" .= String projectVersion ]
+ , [ "quickjump_version" .= quickjumpVersion | withQuickjump ]
+ ])
+
+ withFile (odir </> "meta.json") WriteMode $ \h ->
+ hPutBuilder h (encodeToBuilder meta_json)
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 17:21:27 +0000