Fix #783 Don't show button if --quickjump not present

2 files changed, 39 insertions, 15 deletions

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 7ed43ad2..664168f1 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -435,6 +435,7 @@ render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap =
       _ <- {-# SCC ppHtmlIndex #-}
            ppHtmlIndex odir title pkgStr
                   themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls
+                  withQuickjump
                   (concatMap piInstalledInterfaces allVisiblePackages) pretty
       return ()
 
@@ -446,6 +447,7 @@ render logger dflags unit_state flags sinceQual qual ifaces packages extSrcMap =
       _ <- {-# SCC ppHtmlContents #-}
            ppHtmlContents unit_state odir title pkgStr
                      themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
+                     withQuickjump
                      allVisiblePackages True prologue pretty
                      sincePkg (makeContentsQual qual)
       return ()
@@ -778,4 +780,3 @@ getPrologue dflags flags =
 rightOrThrowE :: Either String b -> IO b
 rightOrThrowE (Left msg) = throwE msg
 rightOrThrowE (Right x) = pure x
-
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index 3dc1e8da..4cc6aa77 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -97,6 +97,7 @@ ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue
   when (isNothing maybe_contents_url) $
     ppHtmlContents state odir doctitle maybe_package
         themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url
+        withQuickjump
         [PackageInterfaces
           { piPackageInfo = packageInfo
           , piVisibility  = Visible
@@ -109,6 +110,7 @@ ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue
   when (isNothing maybe_index_url) $ do
     ppHtmlIndex odir doctitle maybe_package
       themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url
+      withQuickjump
       (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug
 
   when withQuickjump $
@@ -117,7 +119,8 @@ ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue
 
   mapM_ (ppHtmlModule odir doctitle themes
            maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url
-           maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces
+           maybe_contents_url maybe_index_url withQuickjump
+           unicode pkg qual debug) visible_ifaces
 
 
 copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO ()
@@ -163,6 +166,15 @@ headHtml docTitle themes mathjax_url base_url =
                      ,   "}"
                      , "});" ]
 
+quickJumpButtonLi :: Bool  -- ^ With Quick Jump?
+                  -> Maybe Html
+-- The TypeScript should replace this <li> element, given its id. However, in
+-- case it does not, the element is given content here too.
+quickJumpButtonLi True = Just $ li ! [identifier "quick-jump-button"]
+  << anchor ! [href "#"] << "Quick Jump"
+
+quickJumpButtonLi False = Nothing
+
 srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
 srcButton (Just src_base_url, _, _, _) Nothing =
   Just (anchor ! [href src_base_url] << "Source")
@@ -201,20 +213,18 @@ indexButton maybe_index_url
 bodyHtml :: String -> Maybe Interface
     -> SourceURLs -> WikiURLs
     -> Maybe String -> Maybe String
+    -> Bool  -- ^ With Quick Jump?
     -> Html -> Html
 bodyHtml doctitle iface
            maybe_source_url maybe_wiki_url
            maybe_contents_url maybe_index_url
+           withQuickjump
            pageContent =
   body << [
     divPackageHeader << [
       nonEmptySectionName << doctitle,
-      unordList (catMaybes [
-        srcButton maybe_source_url iface,
-        wikiButton maybe_wiki_url (ifaceMod <$> iface),
-        contentsButton maybe_contents_url,
-        indexButton maybe_index_url])
-            ! [theclass "links", identifier "page-menu"]
+      ulist ! [theclass "links", identifier "page-menu"]
+        << catMaybes (quickJumpButtonLi withQuickjump : otherButtonLis)
       ],
     divContent << pageContent,
     divFooter << paragraph << (
@@ -223,6 +233,13 @@ bodyHtml doctitle iface
       (" version " ++ projectVersion)
       )
     ]
+ where
+  otherButtonLis = (fmap . fmap) (li <<)
+    [ srcButton maybe_source_url iface
+    , wikiButton maybe_wiki_url (ifaceMod <$> iface)
+    , contentsButton maybe_contents_url
+    , indexButton maybe_index_url
+    ]
 
 moduleInfo :: Interface -> Html
 moduleInfo iface =
@@ -285,6 +302,7 @@ ppHtmlContents
    -> Maybe String
    -> SourceURLs
    -> WikiURLs
+   -> Bool  -- ^ With Quick Jump?
    -> [PackageInterfaces] -> Bool -> Maybe (MDoc GHC.RdrName)
    -> Bool
    -> Maybe Package  -- ^ Current package
@@ -292,7 +310,8 @@ ppHtmlContents
    -> IO ()
 ppHtmlContents state odir doctitle _maybe_package
   themes mathjax_url maybe_index_url
-  maybe_source_url maybe_wiki_url packages showPkgs prologue debug pkg qual = do
+  maybe_source_url maybe_wiki_url withQuickjump
+  packages showPkgs prologue debug pkg qual = do
   let trees =
         [ ( piPackageInfo pinfo
           , mkModuleTree state showPkgs
@@ -317,7 +336,7 @@ ppHtmlContents state odir doctitle _maybe_package
         headHtml doctitle themes mathjax_url Nothing +++
         bodyHtml doctitle Nothing
           maybe_source_url maybe_wiki_url
-          Nothing maybe_index_url << [
+          Nothing maybe_index_url withQuickjump << [
             ppPrologue pkg qual doctitle prologue,
             ppSignatureTrees pkg qual sig_trees,
             ppModuleTrees pkg qual trees
@@ -531,11 +550,12 @@ ppHtmlIndex :: FilePath
             -> Maybe String
             -> SourceURLs
             -> WikiURLs
+            -> Bool  -- ^ With Quick Jump?
             -> [InstalledInterface]
             -> Bool
             -> IO ()
 ppHtmlIndex odir doctitle _maybe_package themes
-  maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do
+  maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url withQuickjump ifaces debug = do
   let html = indexPage split_indices Nothing
               (if split_indices then [] else index)
 
@@ -554,7 +574,7 @@ ppHtmlIndex odir doctitle _maybe_package themes
       headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing +++
       bodyHtml doctitle Nothing
         maybe_source_url maybe_wiki_url
-        maybe_contents_url Nothing << [
+        maybe_contents_url Nothing withQuickjump << [
           if showLetters then indexInitialLetterLinks else noHtml,
           if null items then noHtml else
             divIndex << [sectionName << indexName ch, buildIndex items]
@@ -652,11 +672,14 @@ ppHtmlIndex odir doctitle _maybe_package themes
 ppHtmlModule
         :: FilePath -> String -> Themes
         -> Maybe String -> SourceURLs -> WikiURLs -> BaseURL
-        -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption
+        -> Maybe String -> Maybe String
+        -> Bool  -- ^ With Quick Jump?
+        -> Bool -> Maybe Package -> QualOption
         -> Bool -> Interface -> IO ()
 ppHtmlModule odir doctitle themes
   maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url
-  maybe_contents_url maybe_index_url unicode pkg qual debug iface = do
+  maybe_contents_url maybe_index_url withQuickjump
+  unicode pkg qual debug iface = do
   let
       mdl = ifaceMod iface
       aliases = ifaceModuleAliases iface
@@ -676,7 +699,7 @@ ppHtmlModule odir doctitle themes
         headHtml mdl_str_annot themes maybe_mathjax_url maybe_base_url +++
         bodyHtml doctitle (Just iface)
           maybe_source_url maybe_wiki_url
-          maybe_contents_url maybe_index_url << [
+          maybe_contents_url maybe_index_url withQuickjump << [
             divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)),
             ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg real_qual
           ]