Merge remote-tracking branch 'origin/master' into ghc-head

9 files changed, 115 insertions, 92 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
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 59582fd2..76bcb4ae 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
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 d73d1a79..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
@@ -70,6 +71,7 @@ data Flag
   | Flag_WikiEntityURL String
   | Flag_LaTeX
   | Flag_LaTeXStyle String
+  | Flag_QuickJumpIndex
   | Flag_HyperlinkedSource
   | Flag_SourceCss String
   | Flag_Mathjax String
@@ -98,6 +100,7 @@ data Flag
   | Flag_NoPrintMissingDocs
   | Flag_PackageName String
   | Flag_PackageVersion String
+  | Flag_Reexport String
   deriving (Eq, Show)
 
 
@@ -126,6 +129,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")
@@ -194,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")
@@ -310,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 ]