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 ".".

8 files changed, 681 insertions, 84 deletions

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 9158d83c..942798eb 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -1,6 +1,10 @@
-{-# OPTIONS_GHC -Wwarn #-}
-{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, Rank2Types #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE Rank2Types          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections       #-}
+{-# OPTIONS_GHC -Wwarn           #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock
@@ -46,7 +50,7 @@ import Control.Monad.IO.Class (MonadIO(..))
 import Data.Bifunctor (second)
 import Data.Foldable (forM_, foldl')
 import Data.Traversable (for)
-import Data.List (isPrefixOf)
+import Data.List (find, isPrefixOf, nub)
 import Control.Exception
 import Data.Maybe
 import Data.IORef
@@ -75,6 +79,7 @@ import GHC.Utils.Error
 import GHC.Utils.Logger
 import GHC.Types.Name.Cache
 import GHC.Unit
+import GHC.Unit.State (lookupUnit)
 import GHC.Utils.Panic (handleGhcException)
 import GHC.Data.FastString
 
@@ -193,7 +198,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
     forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
       name_cache <- freshNameCache
       mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), path)] noChecks
-      forM_ mIfaceFile $ \(_, ifaceFile) -> do
+      forM_ mIfaceFile $ \(_,_, ifaceFile) -> do
         putMsg logger $ renderJson (jsonInterfaceFile ifaceFile)
 
     if not (null files) then do
@@ -254,7 +259,7 @@ withGhc flags action = do
 
 
 readPackagesAndProcessModules :: [Flag] -> [String]
-                              -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
+                              -> Ghc ([(DocPaths, FilePath, InterfaceFile)], [Interface], LinkEnv)
 readPackagesAndProcessModules flags files = do
     -- Get packages supplied with --read-interface.
     let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags
@@ -262,28 +267,42 @@ readPackagesAndProcessModules flags files = do
     packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks
 
     -- Create the interfaces -- this is the core part of Haddock.
-    let ifaceFiles = map snd packages
+    let ifaceFiles = map (\(_, _, ifaceFile) -> ifaceFile) packages
     (ifaces, homeLinks) <- processModules (verbosity flags) files flags ifaceFiles
 
     return (packages, ifaces, homeLinks)
 
 
 renderStep :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption
-           -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
+           -> [(DocPaths, FilePath, InterfaceFile)] -> [Interface] -> IO ()
 renderStep logger dflags unit_state flags sinceQual nameQual pkgs interfaces = do
-  updateHTMLXRefs pkgs
+  updateHTMLXRefs (map (\(docPath, _ifaceFilePath, ifaceFile) ->
+                          ( case baseUrl flags of
+                              Nothing  -> fst docPath
+                              Just url -> url </> packageName (ifUnitId ifaceFile)
+                          , ifaceFile)) pkgs)
   let
-    ifaceFiles = map snd pkgs
-    installedIfaces = concatMap ifInstalledIfaces ifaceFiles
+    installedIfaces =
+      concatMap
+        (\(_, ifaceFilePath, ifaceFile)
+          -> (ifaceFilePath,) <$> ifInstalledIfaces ifaceFile)
+        pkgs
     extSrcMap = Map.fromList $ do
-      ((_, Just path), ifile) <- pkgs
+      ((_, Just path), _, ifile) <- pkgs
       iface <- ifInstalledIfaces ifile
       return (instMod iface, path)
   render logger dflags unit_state flags sinceQual nameQual interfaces installedIfaces extSrcMap
+  where
+    -- get package name from unit-id
+    packageName :: Unit -> String
+    packageName unit =
+      case lookupUnit unit_state unit of
+        Nothing  -> show unit
+        Just pkg -> unitPackageNameString pkg
 
 -- | Render the interfaces with whatever backend is specified in the flags.
 render :: Logger -> DynFlags -> UnitState -> [Flag] -> SinceQual -> QualOption -> [Interface]
-       -> [InstalledInterface] -> Map Module FilePath -> IO ()
+       -> [(FilePath, InstalledInterface)] -> Map Module FilePath -> IO ()
 render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do
 
   let
@@ -291,6 +310,7 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc
     unicode              = Flag_UseUnicode `elem` flags
     pretty               = Flag_PrettyHtml `elem` flags
     opt_wiki_urls        = wikiUrls          flags
+    opt_base_url         = baseUrl           flags
     opt_contents_url     = optContentsUrl    flags
     opt_index_url        = optIndexUrl       flags
     odir                 = outputDir         flags
@@ -305,7 +325,7 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc
     visibleIfaces    = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
 
     -- /All/ visible interfaces including external package modules.
-    allIfaces        = map toInstalledIface ifaces ++ installedIfaces
+    allIfaces        = map toInstalledIface ifaces ++ map snd installedIfaces
     allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ]
 
     pkgMod           = fmap ifaceMod (listToMaybe ifaces)
@@ -350,7 +370,7 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc
     sourceUrls' = (srcBase, srcModule', pkgSrcMap', pkgSrcLMap')
 
     installedMap :: Map Module InstalledInterface
-    installedMap = Map.fromList [ (unwire (instMod iface), iface) | iface <- installedIfaces ]
+    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
@@ -373,6 +393,13 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc
   themes   <- getThemes libDir flags >>= either bye return
 
   let withQuickjump = Flag_QuickJumpIndex `elem` flags
+      withBaseURL = isJust
+                  . find (\flag -> case flag of
+                           Flag_BaseURL base_url ->
+                             base_url /= "." && base_url /= "./"
+                           _ -> False
+                         )
+                  $ flags
 
   when (Flag_GenIndex `elem` flags) $ do
     withTiming logger "ppHtmlIndex" (const ()) $ do
@@ -382,7 +409,8 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc
                   allVisibleIfaces pretty
       return ()
 
-    copyHtmlBits odir libDir themes withQuickjump
+    unless withBaseURL $
+      copyHtmlBits odir libDir themes withQuickjump
 
   when (Flag_GenContents `elem` flags) $ do
     withTiming logger "ppHtmlContents" (const ()) $ do
@@ -394,17 +422,24 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc
       return ()
     copyHtmlBits odir libDir themes withQuickjump
 
+  when withQuickjump $ void $
+            ppJsonIndex odir sourceUrls' opt_wiki_urls
+                        unicode Nothing qual
+                        ifaces
+                        (nub $ map fst installedIfaces)
+
   when (Flag_Html `elem` flags) $ do
     withTiming logger "ppHtml" (const ()) $ do
       _ <- {-# SCC ppHtml #-}
            ppHtml unit_state title pkgStr visibleIfaces reexportedIfaces odir
                   prologue
-                  themes opt_mathjax sourceUrls' opt_wiki_urls
+                  themes opt_mathjax sourceUrls' opt_wiki_urls opt_base_url
                   opt_contents_url opt_index_url unicode sincePkg qual
                   pretty withQuickjump
       return ()
-    copyHtmlBits odir libDir themes withQuickjump
-    writeHaddockMeta odir withQuickjump
+    unless withBaseURL $ do
+      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
@@ -451,7 +486,7 @@ render log' dflags unit_state flags sinceQual qual ifaces installedIfaces extSrc
 readInterfaceFiles :: NameCache
                    -> [(DocPaths, FilePath)]
                    -> Bool
-                   -> IO [(DocPaths, InterfaceFile)]
+                   -> IO [(DocPaths, FilePath, InterfaceFile)]
 readInterfaceFiles name_cache pairs bypass_version_check = do
   catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
   where
@@ -463,7 +498,7 @@ readInterfaceFiles name_cache pairs bypass_version_check = do
           putStrLn ("   " ++ err)
           putStrLn "Skipping this interface."
           return Nothing
-        Right f -> return $ Just (paths, f)
+        Right f -> return (Just (paths, file, f))
 
 
 -------------------------------------------------------------------------------
@@ -684,12 +719,12 @@ hypSrcWarnings flags = do
     isSourceCssFlag _ = False
 
 
-updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()
+updateHTMLXRefs :: [(FilePath, InterfaceFile)] -> IO ()
 updateHTMLXRefs packages = do
   writeIORef html_xrefs_ref (Map.fromList mapping)
   writeIORef html_xrefs_ref' (Map.fromList mapping')
   where
-    mapping = [ (instMod iface, html) | ((html, _), ifaces) <- packages
+    mapping = [ (instMod iface, html) | (html, ifaces) <- packages
               , iface <- ifInstalledIfaces ifaces ]
     mapping' = [ (moduleName m, html) | (m, html) <- mapping ]
 
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)
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 4d22505f..aa10b5b3 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -24,6 +24,7 @@ module Haddock.Options (
   optSourceCssFile,
   sourceUrls,
   wikiUrls,
+  baseUrl,
   optParCount,
   optDumpInterfaceFile,
   optShowInterfaceFile,
@@ -72,6 +73,7 @@ data Flag
   | Flag_SourceEntityURL  String
   | Flag_SourceLEntityURL String
   | Flag_WikiBaseURL   String
+  | Flag_BaseURL       String
   | Flag_WikiModuleURL String
   | Flag_WikiEntityURL String
   | Flag_LaTeX
@@ -157,6 +159,8 @@ options backwardsCompat =
       "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.",
     Option []  ["comments-base"]   (ReqArg Flag_WikiBaseURL "URL")
       "URL for a comments link on the contents\nand index pages",
+    Option [] ["base-url"] (ReqArg Flag_BaseURL "URL")
+      "Base URL for static assets (eg. css, javascript, json files etc.).\nWhen given statis assets will not be copied.",
     Option []  ["comments-module"]  (ReqArg Flag_WikiModuleURL "URL")
       "URL for a comments link for each module\n(using the %{MODULE} var)",
     Option []  ["comments-entity"]  (ReqArg Flag_WikiEntityURL "URL")
@@ -301,6 +305,9 @@ wikiUrls flags =
   ,optLast [str | Flag_WikiEntityURL str <- flags])
 
 
+baseUrl :: [Flag] -> Maybe String
+baseUrl flags = optLast [str | Flag_BaseURL str <- flags]
+
 optDumpInterfaceFile :: [Flag] -> Maybe FilePath
 optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ]
 
diff --git a/haddock-api/src/Haddock/Utils/Json.hs b/haddock-api/src/Haddock/Utils/Json.hs
index 2270a547..d5d5ae02 100644
--- a/haddock-api/src/Haddock/Utils/Json.hs
+++ b/haddock-api/src/Haddock/Utils/Json.hs
@@ -1,4 +1,6 @@
+{-# LANGUAGE ExplicitForAll    #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
 
 -- | Minimal JSON / RFC 7159 support
 --
@@ -12,35 +14,53 @@ module Haddock.Utils.Json
     , encodeToString
     , encodeToBuilder
     , ToJSON(toJSON)
+
+    , Parser(..)
+    , Result(..)
+    , FromJSON(parseJSON)
+    , withObject
+    , withArray
+    , withString
+    , withDouble
+    , withBool
+    , fromJSON
+    , parse
+    , parseEither
+    , (.:)
+    , (.:?)
+    , decode
+    , decodeWith
+    , eitherDecode
+    , eitherDecodeWith
+    , decodeFile
+    , eitherDecodeFile
     )
     where
 
+import Control.Applicative (Alternative (..))
+import Control.Monad (MonadPlus (..), zipWithM, (>=>))
+import qualified Control.Monad as Monad
+import qualified Control.Monad.Fail as Fail
+
+import qualified Data.ByteString.Lazy as BSL
+import Data.ByteString.Builder (Builder)
+import qualified Data.ByteString.Builder as BB
 import Data.Char
 import Data.Int
-import Data.String
 import Data.Word
 import Data.List (intersperse)
 import Data.Monoid
 
-import Data.ByteString.Builder (Builder)
-import qualified Data.ByteString.Builder as BB
+import GHC.Natural
 
 -- TODO: We may want to replace 'String' with 'Text' or 'ByteString'
 
--- | A JSON value represented as a Haskell value.
-data Value = Object !Object
-           | Array  [Value]
-           | String  String
-           | Number !Double
-           | Bool   !Bool
-           | Null
-           deriving (Eq, Read, Show)
+import qualified Text.Parsec.ByteString.Lazy as Parsec.Lazy
+import qualified Text.ParserCombinators.Parsec as Parsec
 
--- | A key\/value pair for an 'Object'
-type Pair = (String, Value)
+import Haddock.Utils.Json.Types
+import Haddock.Utils.Json.Parser
 
--- | A JSON \"object\" (key/value map).
-type Object = [Pair]
 
 infixr 8 .=
 
@@ -48,13 +68,6 @@ infixr 8 .=
 (.=) :: ToJSON v => String -> v -> Pair
 k .= v  = (k, toJSON v)
 
--- | Create a 'Value' from a list of name\/value 'Pair's.
-object :: [Pair] -> Value
-object = Object
-
-instance IsString Value where
-  fromString = String
-
 
 -- | A type that can be converted to JSON.
 class ToJSON a where
@@ -223,3 +236,324 @@ escapeString s
 
     -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF
     needsEscape c = ord c < 0x20 || c `elem` ['\\','"']
+
+------------------------------------------------------------------------------
+-- FromJSON
+
+-- | Elements of a JSON path used to describe the location of an
+-- error.
+data JSONPathElement
+  = Key String
+  -- ^ JSON path element of a key into an object,
+  -- \"object.key\".
+  | Index !Int
+  -- ^ JSON path element of an index into an
+  -- array, \"array[index]\".
+  deriving (Eq, Show, Ord)
+
+type JSONPath = [JSONPathElement]
+
+-- | Failure continuation.
+type Failure f r   = JSONPath -> String -> f r
+
+-- | Success continuation.
+type Success a f r = a -> f r
+
+newtype Parser a = Parser {
+      runParser :: forall f r.
+                   JSONPath
+                -> Failure f r
+                -> Success a f r
+                -> f r
+    }
+
+modifyFailure :: (String -> String) -> Parser a -> Parser a
+modifyFailure f (Parser p) = Parser $ \path kf ks ->
+    p path (\p' m -> kf p' (f m)) ks
+
+prependFailure :: String -> Parser a -> Parser a
+prependFailure = modifyFailure . (++)
+
+prependContext :: String -> Parser a -> Parser a
+prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")
+
+typeMismatch :: String -> Value -> Parser a
+typeMismatch expected actual =
+    fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual
+
+instance Monad.Monad Parser where
+    m >>= g = Parser $ \path kf ks ->
+      runParser m path kf
+                       (\a -> runParser (g a) path kf ks)
+    return = pure
+
+instance Fail.MonadFail Parser where
+    fail msg = Parser $ \path kf _ks -> kf (reverse path) msg
+
+instance Functor Parser where
+    fmap f m = Parser $ \path kf ks ->
+      let ks' a = ks (f a)
+      in runParser m path kf ks'
+
+instance Applicative Parser where
+    pure a = Parser $ \_path _kf ks -> ks a
+    (<*>) = apP
+
+instance Alternative Parser where
+    empty = fail "empty"
+    (<|>) = mplus
+
+instance MonadPlus Parser where
+    mzero = fail "mzero"
+    mplus a b = Parser $ \path kf ks ->
+      runParser a path (\_ _ -> runParser b path kf ks) ks
+
+instance Semigroup (Parser a) where
+    (<>) = mplus
+
+instance Monoid (Parser a) where
+    mempty  = fail "mempty"
+    mappend = (<>)
+
+apP :: Parser (a -> b) -> Parser a -> Parser b
+apP d e = do
+  b <- d
+  b <$> e
+
+(<?>) :: Parser a -> JSONPathElement -> Parser a
+p <?> pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks
+
+parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
+parseIndexedJSON p idx value = p value <?> Index idx
+
+unexpected :: Value -> Parser a
+unexpected actual = fail $ "unexpected " ++ typeOf actual
+
+withObject :: String -> (Object -> Parser a) -> Value -> Parser a
+withObject _    f (Object obj) = f obj
+withObject name _ v            = prependContext name (typeMismatch "Object" v)
+
+withArray :: String -> ([Value] -> Parser a) -> Value -> Parser a
+withArray _    f (Array arr) = f arr
+withArray name _ v           = prependContext name (typeMismatch "Array" v)
+
+withString :: String -> (String -> Parser a) -> Value -> Parser a
+withString _    f (String txt) = f txt
+withString name _ v            = prependContext name (typeMismatch "String" v)
+
+withDouble :: String -> (Double -> Parser a) -> Value -> Parser a
+withDouble _    f (Number duble) = f duble
+withDouble name _ v              = prependContext name (typeMismatch "Number" v)
+
+withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
+withBool _    f (Bool arr) = f arr
+withBool name _ v          = prependContext name (typeMismatch "Boolean" v)
+
+class FromJSON a where
+    parseJSON     :: Value -> Parser a
+
+    parseJSONList :: Value -> Parser [a]
+    parseJSONList = withArray "[]" (zipWithM (parseIndexedJSON parseJSON) [0..])
+
+instance FromJSON Bool where
+    parseJSON (Bool b)  = pure b
+    parseJSON v = typeMismatch "Bool" v
+
+instance FromJSON () where
+    parseJSON =
+      withArray "()" $ \v ->
+        if null v
+          then pure ()
+          else prependContext "()" $ fail "expected an empty array"
+
+instance FromJSON Char where
+    parseJSON = withString "Char" parseChar
+
+    parseJSONList (String s) = pure s
+    parseJSONList v = typeMismatch "String" v
+
+parseChar :: String -> Parser Char
+parseChar t =
+    if length t == 1
+      then pure $ head t
+      else prependContext "Char" $ fail "expected a string of length 1"
+
+parseRealFloat :: RealFloat a => String -> Value -> Parser a
+parseRealFloat _    (Number s) = pure $ realToFrac s
+parseRealFloat _    Null       = pure (0/0)
+parseRealFloat name v          = prependContext name (unexpected v)
+
+instance FromJSON Double where
+    parseJSON = parseRealFloat "Double"
+
+instance FromJSON Float where
+    parseJSON = parseRealFloat "Float"
+
+parseNatural :: Integer -> Parser Natural
+parseNatural integer =
+    if integer < 0 then
+        fail $ "parsing Natural failed, unexpected negative number " <> show integer
+    else
+        pure $ fromIntegral integer
+
+parseIntegralFromDouble :: Integral a => Double -> Parser a
+parseIntegralFromDouble d =
+    let r = toRational d
+        x = truncate r
+    in if toRational x == r
+         then pure $ x
+         else fail $ "unexpected floating number " <> show d
+
+parseIntegral :: Integral a => String -> Value -> Parser a
+parseIntegral name = withDouble name parseIntegralFromDouble
+
+instance FromJSON Integer where
+    parseJSON = parseIntegral "Integer"
+
+instance FromJSON Natural where
+    parseJSON = withDouble "Natural"
+                  (parseIntegralFromDouble >=> parseNatural)
+
+instance FromJSON Int where
+    parseJSON = parseIntegral "Int"
+
+instance FromJSON Int8 where
+    parseJSON = parseIntegral "Int8"
+
+instance FromJSON Int16 where
+    parseJSON = parseIntegral "Int16"
+
+instance FromJSON Int32 where
+    parseJSON = parseIntegral "Int32"
+
+instance FromJSON Int64 where
+    parseJSON = parseIntegral "Int64"
+
+instance FromJSON Word where
+    parseJSON = parseIntegral "Word"
+
+instance FromJSON Word8 where
+    parseJSON = parseIntegral "Word8"
+
+instance FromJSON Word16 where
+    parseJSON = parseIntegral "Word16"
+
+instance FromJSON Word32 where
+    parseJSON = parseIntegral "Word32"
+
+instance FromJSON Word64 where
+    parseJSON = parseIntegral "Word64"
+
+instance FromJSON a => FromJSON [a] where
+    parseJSON = parseJSONList
+
+data Result a = Error String
+              | Success a
+                deriving (Eq, Show)
+
+fromJSON :: FromJSON a => Value -> Result a
+fromJSON = parse parseJSON
+
+parse :: (a -> Parser b) -> a -> Result b
+parse m v = runParser (m v) [] (const Error) Success
+
+parseEither :: (a -> Parser b) -> a -> Either String b
+parseEither m v = runParser (m v) [] onError Right
+  where onError path msg = Left (formatError path msg)
+
+formatError :: JSONPath -> String -> String
+formatError path msg = "Error in " ++ formatPath path ++ ": " ++ msg
+
+formatPath :: JSONPath -> String
+formatPath path = "$" ++ formatRelativePath path
+
+formatRelativePath :: JSONPath -> String
+formatRelativePath path = format "" path
+  where
+    format :: String -> JSONPath -> String
+    format pfx []                = pfx
+    format pfx (Index idx:parts) = format (pfx ++ "[" ++ show idx ++ "]") parts
+    format pfx (Key key:parts)   = format (pfx ++ formatKey key) parts
+
+    formatKey :: String -> String
+    formatKey key
+       | isIdentifierKey key = "." ++ key
+       | otherwise           = "['" ++ escapeKey key ++ "']"
+
+    isIdentifierKey :: String -> Bool
+    isIdentifierKey []     = False
+    isIdentifierKey (x:xs) = isAlpha x && all isAlphaNum xs
+
+    escapeKey :: String -> String
+    escapeKey = concatMap escapeChar
+
+    escapeChar :: Char -> String
+    escapeChar '\'' = "\\'"
+    escapeChar '\\' = "\\\\"
+    escapeChar c    = [c]
+
+explicitParseField :: (Value -> Parser a) -> Object -> String -> Parser a
+explicitParseField p obj key =
+    case key `lookup` obj of
+      Nothing -> fail $ "key " ++ key ++ " not found"
+      Just v  -> p v <?> Key key
+
+(.:) :: FromJSON a => Object -> String -> Parser a
+(.:) = explicitParseField parseJSON
+
+explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> String -> Parser (Maybe a)
+explicitParseFieldMaybe p obj key =
+    case key `lookup` obj of
+      Nothing -> pure Nothing
+      Just v  -> Just <$> p v <?> Key key
+
+(.:?) :: FromJSON a => Object -> String -> Parser (Maybe a)
+(.:?) = explicitParseFieldMaybe parseJSON
+
+
+decodeWith :: (Value -> Result a) -> BSL.ByteString -> Maybe a
+decodeWith decoder bsl =
+   case Parsec.parse parseJSONValue "<input>" bsl of
+     Left  _    -> Nothing
+     Right json ->
+       case decoder json of
+         Success a -> Just a
+         Error _   -> Nothing
+
+decode :: FromJSON a => BSL.ByteString -> Maybe a
+decode = decodeWith fromJSON
+
+eitherDecodeWith :: (Value -> Result a) -> BSL.ByteString -> Either String a
+eitherDecodeWith decoder bsl =
+    case Parsec.parse parseJSONValue "<input>" bsl of
+      Left parsecError -> Left (show parsecError)
+      Right json ->
+        case decoder json of
+          Success a -> Right a
+          Error err -> Left  err
+
+eitherDecode :: FromJSON a => BSL.ByteString -> Either String a
+eitherDecode = eitherDecodeWith fromJSON
+
+
+decodeFile :: FromJSON a => FilePath -> IO (Maybe a)
+decodeFile filePath = do
+    parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath
+    case parsecResult of
+      Right r ->
+        case fromJSON r of
+          Success a -> return (Just a)
+          Error   _ -> return Nothing
+      Left _ -> return Nothing
+
+
+eitherDecodeFile :: FromJSON a => FilePath -> IO (Either String a)
+eitherDecodeFile filePath = do
+    parsecResult <- Parsec.Lazy.parseFromFile parseJSONValue filePath
+    case parsecResult of
+      Right r ->
+        case fromJSON r of
+          Success a -> return (Right a)
+          Error err -> return (Left err)
+      Left err -> return $ Left (show err)
+
diff --git a/haddock-api/src/Haddock/Utils/Json/Parser.hs b/haddock-api/src/Haddock/Utils/Json/Parser.hs
new file mode 100644
index 00000000..018e27d3
--- /dev/null
+++ b/haddock-api/src/Haddock/Utils/Json/Parser.hs
@@ -0,0 +1,102 @@
+-- | Json "Parsec" parser, based on
+-- [json](https://hackage.haskell.org/package/json) package.
+--
+module Haddock.Utils.Json.Parser
+  ( parseJSONValue
+  ) where
+
+import Prelude hiding (null)
+
+import Control.Applicative (Alternative (..))
+import Control.Monad (MonadPlus (..))
+import Data.Char (isHexDigit)
+import Data.Functor (($>))
+import qualified Data.ByteString.Lazy.Char8 as BSCL
+import Numeric
+import Text.Parsec.ByteString.Lazy (Parser)
+import Text.ParserCombinators.Parsec ((<?>))
+import qualified Text.ParserCombinators.Parsec as Parsec
+
+import Haddock.Utils.Json.Types hiding (object)
+
+parseJSONValue :: Parser Value
+parseJSONValue = Parsec.spaces *> parseValue
+
+tok :: Parser a -> Parser a
+tok p = p <* Parsec.spaces
+
+parseValue :: Parser Value
+parseValue =
+         parseNull
+     <|> Bool   <$> parseBoolean
+     <|> Array  <$> parseArray
+     <|> String <$> parseString
+     <|> Object <$> parseObject
+     <|> Number <$> parseNumber
+     <?> "JSON value"
+
+parseNull :: Parser Value
+parseNull = tok
+     $  Parsec.string "null"
+     $> Null
+
+parseBoolean :: Parser Bool
+parseBoolean = tok
+     $  Parsec.string "true"  $> True
+    <|> Parsec.string "false" $> False
+
+parseArray :: Parser [Value]
+parseArray =
+    Parsec.between
+      (tok (Parsec.char '['))
+      (tok (Parsec.char ']'))
+      (parseValue `Parsec.sepBy` tok (Parsec.char ','))
+
+parseString :: Parser String
+parseString =
+    Parsec.between
+      (tok (Parsec.char '"'))
+      (tok (Parsec.char '"'))
+      (many char)
+  where
+    char = (Parsec.char '\\' >> escapedChar)
+       <|> Parsec.satisfy (\x -> x /= '"' && x /= '\\')
+
+    escapedChar =
+          Parsec.char '"'  $> '"'
+      <|> Parsec.char '\\' $> '\\'
+      <|> Parsec.char '/'  $> '/'
+      <|> Parsec.char 'b'  $> '\b'
+      <|> Parsec.char 'f'  $> '\f'
+      <|> Parsec.char 'n'  $> '\n'
+      <|> Parsec.char 'r'  $> '\r'
+      <|> Parsec.char 't'  $> '\t'
+      <|> Parsec.char 'u'  *> uni
+      <?> "escape character"
+
+    uni = check =<< Parsec.count 4 (Parsec.satisfy isHexDigit)
+      where
+        check x | code <= max_char = return (toEnum code)
+                | otherwise        = mzero
+          where code      = fst $ head $ readHex x
+                max_char  = fromEnum (maxBound :: Char)
+
+parseObject :: Parser Object
+parseObject =
+      Parsec.between
+        (tok (Parsec.char '{'))
+        (tok (Parsec.char '}'))
+        (field `Parsec.sepBy` tok (Parsec.char ','))
+  where
+    field :: Parser (String, Value)
+    field = (,)
+        <$> parseString
+        <*  tok (Parsec.char ':')
+        <*> parseValue
+
+parseNumber :: Parser Double
+parseNumber = tok $ do
+  s <- BSCL.unpack <$> Parsec.getInput
+  case readSigned readFloat s of
+    [(n,s')] -> Parsec.setInput (BSCL.pack s') $> n
+    _        -> mzero
diff --git a/haddock-api/src/Haddock/Utils/Json/Types.hs b/haddock-api/src/Haddock/Utils/Json/Types.hs
new file mode 100644
index 00000000..1174329c
--- /dev/null
+++ b/haddock-api/src/Haddock/Utils/Json/Types.hs
@@ -0,0 +1,42 @@
+module Haddock.Utils.Json.Types
+  ( Value(..)
+  , typeOf
+  , Pair
+  , Object
+  , object
+  ) where
+
+import Data.String
+
+-- TODO: We may want to replace 'String' with 'Text' or 'ByteString'
+
+-- | A JSON value represented as a Haskell value.
+data Value = Object !Object
+           | Array  [Value]
+           | String  String
+           | Number !Double
+           | Bool   !Bool
+           | Null
+           deriving (Eq, Read, Show)
+
+typeOf :: Value -> String
+typeOf v = case v of
+    Object _ -> "Object"
+    Array _  -> "Array"
+    String _ -> "String"
+    Number _ -> "Number"
+    Bool _   -> "Boolean"
+    Null     -> "Null"
+
+-- | A key\/value pair for an 'Object'
+type Pair = (String, Value)
+
+-- | A JSON \"object\" (key/value map).
+type Object = [Pair]
+
+-- | Create a 'Value' from a list of name\/value 'Pair's.
+object :: [Pair] -> Value
+object = Object
+
+instance IsString Value where
+  fromString = String