coot/multiple packages (ghc-9.2) (#1418)

8 files changed, 681 insertions, 84 deletions

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 8182707d..5b77a00f 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
@@ -72,6 +76,7 @@ import GHC.Driver.Session hiding (projectVersion, verbosity)
 import GHC.Driver.Env
 import GHC.Utils.Error
 import GHC.Unit
+import GHC.Unit.State (lookupUnit)
 import GHC.Utils.Panic (handleGhcException)
 import GHC.Data.FastString
 
@@ -189,7 +194,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
 
     forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do
       mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks
-      forM_ mIfaceFile $ \(_, ifaceFile) -> do
+      forM_ mIfaceFile $ \(_,_, ifaceFile) -> do
         putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile)
 
     if not (null files) then do
@@ -249,35 +254,49 @@ 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
     packages <- readInterfaceFiles nameCacheFromGhc (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 logger dflags unit_state flags sinceQual qual ifaces installedIfaces extSrcMap = do
 
   let
@@ -285,6 +304,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
     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
@@ -298,7 +318,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
     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)
@@ -343,7 +363,7 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
     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
@@ -366,6 +386,13 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
   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 dflags' "ppHtmlIndex" (const ()) $ do
@@ -375,7 +402,8 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
                   allVisibleIfaces pretty
       return ()
 
-    copyHtmlBits odir libDir themes withQuickjump
+    unless withBaseURL $
+      copyHtmlBits odir libDir themes withQuickjump
 
   when (Flag_GenContents `elem` flags) $ do
     withTiming logger dflags' "ppHtmlContents" (const ()) $ do
@@ -387,17 +415,24 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS
       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 dflags' "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
@@ -445,7 +480,7 @@ readInterfaceFiles :: MonadIO m
                    => NameCacheAccessor m
                    -> [(DocPaths, FilePath)]
                    -> Bool
-                   -> m [(DocPaths, InterfaceFile)]
+                   -> m [(DocPaths, FilePath, InterfaceFile)]
 readInterfaceFiles name_cache_accessor pairs bypass_version_check = do
   catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
   where
@@ -457,7 +492,7 @@ readInterfaceFiles name_cache_accessor 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))
 
 
 -------------------------------------------------------------------------------
@@ -678,12 +713,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