coot/multiple package (ghc-head) (#1419)

* FromJSON class

Aeson style FromJSON class with Parsec based json parser.

* doc-index.json file for multiple packages

When creating haddock summary page for multiple packages render
doc-index.json file using contents of all found 'doc-index.json' files.

* Render doc-index.json

When rendering html, render doc-index.json file independently of
maybe_index_url option.  doc-index.json file is useful now even if
maybe_index_url is not `Nothing`.

* base url option

New `Flag_BaseURL` which configures from where static files are loaded
(--base-url).  If given and not equal "." static files are not coppied,
as this indicates that they are not read from the the directory where
we'd copy them.  The default value is ".".

3 files changed, 116 insertions, 39 deletions

diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index d390a95a..b7674b24 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -11,10 +11,11 @@
 -- Stability   :  experimental
 -- Portability :  portable
 -----------------------------------------------------------------------------
-{-# LANGUAGE CPP, NamedFieldPuns #-}
+{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, TypeApplications #-}
 module Haddock.Backends.Xhtml (
   ppHtml, copyHtmlBits,
   ppHtmlIndex, ppHtmlContents,
+  ppJsonIndex
 ) where
 
 
@@ -38,12 +39,16 @@ import Haddock.GhcUtils
 
 import Control.Monad         ( when, unless )
 import qualified Data.ByteString.Builder as Builder
+import Data.Bifunctor        ( bimap )
 import Data.Char             ( toUpper, isSpace )
+import Data.Either           ( partitionEithers )
+import Data.Foldable         ( traverse_)
 import Data.List             ( sortBy, isPrefixOf, intersperse )
 import Data.Maybe
 import System.Directory
 import System.FilePath hiding ( (</>) )
 import qualified System.IO as IO
+import qualified System.FilePath as FilePath
 import Data.Map              ( Map )
 import qualified Data.Map as Map hiding ( Map )
 import qualified Data.Set as Set hiding ( Set )
@@ -68,6 +73,7 @@ ppHtml :: UnitState
        -> Maybe String                 -- ^ The mathjax URL (--mathjax)
        -> SourceURLs                   -- ^ The source URL (--source)
        -> WikiURLs                     -- ^ The wiki URL (--wiki)
+       -> BaseURL                      -- ^ The base URL (--base-url)
        -> Maybe String                 -- ^ The contents URL (--use-contents)
        -> Maybe String                 -- ^ The index URL (--use-index)
        -> Bool                         -- ^ Whether to use unicode in output (--use-unicode)
@@ -79,7 +85,7 @@ ppHtml :: UnitState
 
 ppHtml state 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
+        maybe_base_url maybe_contents_url maybe_index_url unicode
         pkg qual debug withQuickjump = do
   let
     visible_ifaces = filter visible ifaces
@@ -97,12 +103,12 @@ ppHtml state doctitle maybe_package ifaces reexported_ifaces odir prologue
       themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url
       (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug
 
-    when withQuickjump $
-      ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual
-        visible_ifaces
+  when withQuickjump $
+    ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual
+      visible_ifaces []
 
   mapM_ (ppHtmlModule odir doctitle themes
-           maybe_mathjax_url maybe_source_url maybe_wiki_url
+           maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url
            maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces
 
 
@@ -119,16 +125,23 @@ copyHtmlBits odir libdir themes withQuickjump = do
   return ()
 
 
-headHtml :: String -> Themes -> Maybe String -> Html
-headHtml docTitle themes mathjax_url =
-  header <<
+headHtml :: String -> Themes -> Maybe String -> Maybe String -> Html
+headHtml docTitle themes mathjax_url base_url =
+      header ! (maybe [] (\url -> [identifier "head", strAttr "data-base-url" url ]) base_url)
+    <<
     [ meta ! [ httpequiv "Content-Type", content "text/html; charset=UTF-8"]
     , meta ! [ XHtml.name "viewport", content "width=device-width, initial-scale=1"]
     , thetitle << docTitle
-    , styleSheet themes
-    , thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml
+    , styleSheet base_url themes
+    , thelink ! [ rel "stylesheet"
+                , thetype "text/css"
+                , href (withBaseURL base_url quickJumpCssFile) ]
+             << noHtml
     , thelink ! [ rel "stylesheet", thetype "text/css", href fontUrl] << noHtml
-    , script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml
+    , script ! [ src (withBaseURL base_url haddockJsFile)
+               , emptyAttr "async"
+               , thetype "text/javascript" ]
+            << noHtml
     , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf
     , script ! [src mjUrl, thetype "text/javascript"] << noHtml
     ]
@@ -281,7 +294,7 @@ ppHtmlContents state odir doctitle _maybe_package
          | iface <- ifaces
          , instIsSig iface]
       html =
-        headHtml doctitle themes mathjax_url +++
+        headHtml doctitle themes mathjax_url Nothing +++
         bodyHtml doctitle Nothing
           maybe_source_url maybe_wiki_url
           Nothing maybe_index_url << [
@@ -361,6 +374,35 @@ mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) =
 -- * Generate the index
 --------------------------------------------------------------------------------
 
+data JsonIndexEntry = JsonIndexEntry {
+      jieHtmlFragment :: String,
+      jieName         :: String,
+      jieModule       :: String,
+      jieLink         :: String
+    }
+  deriving Show
+
+instance ToJSON JsonIndexEntry where
+    toJSON JsonIndexEntry
+        { jieHtmlFragment
+        , jieName
+        , jieModule
+        , jieLink } =
+      Object
+        [ "display_html" .= String jieHtmlFragment
+        , "name"         .= String jieName
+        , "module"       .= String jieModule
+        , "link"         .= String jieLink
+        ]
+
+instance FromJSON JsonIndexEntry where
+    parseJSON = withObject "JsonIndexEntry" $ \v ->
+      JsonIndexEntry
+        <$> v .: "display_html"
+        <*> v .: "name"
+        <*> v .: "module"
+        <*> v .: "link"
+
 ppJsonIndex :: FilePath
            -> SourceURLs                   -- ^ The source URL (--source)
            -> WikiURLs                     -- ^ The wiki URL (--wiki)
@@ -368,34 +410,50 @@ ppJsonIndex :: FilePath
            -> Maybe Package
            -> QualOption
            -> [Interface]
+           -> [FilePath]                   -- ^ file paths to interface files
+                                           -- (--read-interface)
            -> IO ()
-ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = do
+ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces installedIfacesPaths = do
   createDirectoryIfMissing True odir
-  IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do
-    Builder.hPutBuilder h (encodeToBuilder modules)
+  (errors, installedIndexes) <-
+    partitionEithers
+      <$> traverse
+            (\ifaceFile ->
+              let indexFile = takeDirectory ifaceFile
+                    FilePath.</> "doc-index.json" in
+                  bimap (indexFile,) (map (fixLink ifaceFile))
+              <$> eitherDecodeFile @[JsonIndexEntry] indexFile)
+            installedIfacesPaths
+  traverse_ (\(indexFile, err) -> putStrLn $ "haddock: Coudn't parse " ++ indexFile ++ ": " ++ err)
+            errors
+  IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h ->
+      Builder.hPutBuilder
+        h (encodeToBuilder (encodeIndexes (concat installedIndexes)))
   where
-    modules :: Value
-    modules = Array (concatMap goInterface ifaces)
-
-    goInterface :: Interface -> [Value]
-    goInterface iface =
-        concatMap (goExport mdl qual) (ifaceRnExportItems iface)
+    encodeIndexes :: [JsonIndexEntry] -> Value
+    encodeIndexes installedIndexes =
+      toJSON
+        (concatMap fromInterface ifaces
+         ++ installedIndexes)
+
+    fromInterface :: Interface -> [JsonIndexEntry]
+    fromInterface iface =
+        mkIndex mdl qual `mapMaybe` ifaceRnExportItems iface
       where
         aliases = ifaceModuleAliases iface
         qual    = makeModuleQual qual_opt aliases mdl
         mdl     = ifaceMod iface
 
-    goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value]
-    goExport mdl qual item
+    mkIndex :: Module -> Qualification -> ExportItem DocNameI -> Maybe JsonIndexEntry
+    mkIndex mdl qual item
       | Just item_html <- processExport True links_info unicode pkg qual item
-      = [ Object
-            [ "display_html" .= String (showHtmlFragment item_html)
-            , "name"         .= String (unwords (map getOccString names))
-            , "module"       .= String (moduleString mdl)
-            , "link"         .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names)))
-            ]
-        ]
-      | otherwise = []
+      = Just JsonIndexEntry
+          { jieHtmlFragment = showHtmlFragment item_html
+          , jieName         = unwords (map getOccString names)
+          , jieModule       = moduleString mdl
+          , jieLink         = fromMaybe "" (listToMaybe (map (nameLink mdl) names))
+          }
+      | otherwise = Nothing
       where
         names = exportName item ++ exportSubs item
 
@@ -413,6 +471,13 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = d
 
     links_info = (maybe_source_url, maybe_wiki_url)
 
+    -- update link using relative path to output directory
+    fixLink :: FilePath
+            -> JsonIndexEntry -> JsonIndexEntry
+    fixLink ifaceFile jie = 
+      jie { jieLink = makeRelative odir (takeDirectory ifaceFile)
+                        FilePath.</> jieLink jie }
+
 ppHtmlIndex :: FilePath
             -> String
             -> Maybe String
@@ -441,7 +506,7 @@ ppHtmlIndex odir doctitle _maybe_package themes
 
   where
     indexPage showLetters ch items =
-      headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url +++
+      headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url Nothing +++
       bodyHtml doctitle Nothing
         maybe_source_url maybe_wiki_url
         maybe_contents_url Nothing << [
@@ -541,11 +606,11 @@ ppHtmlIndex odir doctitle _maybe_package themes
 
 ppHtmlModule
         :: FilePath -> String -> Themes
-        -> Maybe String -> SourceURLs -> WikiURLs
+        -> Maybe String -> SourceURLs -> WikiURLs -> BaseURL
         -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption
         -> Bool -> Interface -> IO ()
 ppHtmlModule odir doctitle themes
-  maybe_mathjax_url maybe_source_url maybe_wiki_url
+  maybe_mathjax_url maybe_source_url maybe_wiki_url maybe_base_url
   maybe_contents_url maybe_index_url unicode pkg qual debug iface = do
   let
       mdl = ifaceMod iface
@@ -563,7 +628,7 @@ ppHtmlModule odir doctitle themes
         = toHtml mdl_str
       real_qual = makeModuleQual qual aliases mdl
       html =
-        headHtml mdl_str_annot themes maybe_mathjax_url +++
+        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 << [
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
index b1d64acd..08ef747a 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs
@@ -17,6 +17,7 @@ module Haddock.Backends.Xhtml.Themes (
     where
 
 import Haddock.Options
+import Haddock.Backends.Xhtml.Types ( BaseURL, withBaseURL )
 
 import Control.Monad (liftM)
 import Data.Char (toLower)
@@ -176,13 +177,13 @@ cssFiles :: Themes -> [String]
 cssFiles ts = nub $ concatMap themeFiles ts
 
 
-styleSheet :: Themes -> Html
-styleSheet ts = toHtml $ zipWith mkLink rels ts
+styleSheet :: BaseURL -> Themes -> Html
+styleSheet base_url ts = toHtml $ zipWith mkLink rels ts
   where
     rels = "stylesheet" : repeat "alternate stylesheet"
     mkLink aRel t =
       thelink
-        ! [ href (themeHref t),  rel aRel, thetype "text/css",
+        ! [ href (withBaseURL base_url (themeHref t)),  rel aRel, thetype "text/css",
             XHtml.title (themeName t)
           ]
         << noHtml
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs
index e3fd2d5a..a68cb559 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs
@@ -12,6 +12,8 @@
 -----------------------------------------------------------------------------
 module Haddock.Backends.Xhtml.Types (
   SourceURLs, WikiURLs,
+  BaseURL,
+  withBaseURL,
   LinksInfo,
   Splice,
   Unicode,
@@ -20,12 +22,21 @@ module Haddock.Backends.Xhtml.Types (
 
 import Data.Map
 import GHC
+import qualified System.FilePath as FilePath
 
 
 -- the base, module and entity URLs for the source code and wiki links.
 type SourceURLs = (Maybe FilePath, Maybe FilePath, Map Unit FilePath, Map Unit FilePath)
 type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)
 
+-- | base url for loading js, json, css resources.  The default is "."
+--
+type BaseURL = Maybe String
+
+-- TODO: we shouldn't use 'FilePath.</>'
+withBaseURL :: BaseURL -> String -> String
+withBaseURL Nothing        uri = uri
+withBaseURL (Just baseUrl) uri = baseUrl FilePath.</> uri
 
 -- The URL for source and wiki links
 type LinksInfo = (SourceURLs, WikiURLs)