Add support for providing custom CSS files for hyperlinked source.

3 files changed, 28 insertions, 7 deletions

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index e45456ab..698122e3 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -244,6 +244,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
     opt_index_url        = optIndexUrl       flags
     odir                 = outputDir         flags
     opt_latex_style      = optLaTeXStyle     flags
+    opt_source_css       = optSourceCssFile  flags
 
     visibleIfaces    = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ]
 
@@ -310,7 +311,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
                   libDir
 
   when (Flag_HyperlinkedSource `elem` flags) $ do
-    ppHyperlinkedSource odir libDir Nothing visibleIfaces
+    ppHyperlinkedSource odir libDir opt_source_css visibleIfaces
 
 -- | From GHC 7.10, this function has a potential to crash with a
 -- nasty message such as @expectJust getPackageDetails@ because
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 88619474..66392a67 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -5,21 +5,35 @@ import Haddock.Backends.Hyperlinker.Renderer
 
 import GHC
 import Text.XHtml hiding ((</>))
+
+import Data.Maybe
 import System.Directory
 import System.FilePath
 
 ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath -> [Interface]
                     -> IO ()
 ppHyperlinkedSource outdir libdir mstyle ifaces = do
-    createDirectoryIfMissing True (outdir </> "src")
-    mapM_ (ppHyperlinkedModuleSource outdir mstyle) ifaces
+    createDirectoryIfMissing True $ srcPath outdir
+    let cssFile = fromMaybe (defaultCssFile libdir) mstyle
+    copyFile cssFile $ srcPath outdir </> srcCssFile
+    mapM_ (ppHyperlinkedModuleSource outdir) ifaces
 
-ppHyperlinkedModuleSource :: FilePath -> Maybe FilePath -> Interface -> IO ()
-ppHyperlinkedModuleSource outdir mstyle iface = case ifaceTokenizedSrc iface of
-    Just tokens -> writeFile path $ showHtml . render mstyle $ tokens
+ppHyperlinkedModuleSource :: FilePath -> Interface -> IO ()
+ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of
+    Just tokens -> writeFile path $ showHtml . render mSrcCssFile $ tokens
     Nothing -> return ()
   where
-    path = outdir </> "src" </> moduleSourceFile (ifaceMod iface)
+    mSrcCssFile = Just $ srcCssFile
+    path = srcPath outdir </> moduleSourceFile (ifaceMod iface)
 
 moduleSourceFile :: Module -> FilePath
 moduleSourceFile = (++ ".html") . moduleNameString . moduleName
+
+srcPath :: FilePath -> FilePath
+srcPath outdir = outdir </> "src"
+
+srcCssFile :: FilePath
+srcCssFile = "style.css"
+
+defaultCssFile :: FilePath -> FilePath
+defaultCssFile libdir = libdir </> "html" </> "solarized.css"
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index c9d5688c..f84989ef 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -21,6 +21,7 @@ module Haddock.Options (
   optContentsUrl,
   optIndexUrl,
   optCssFile,
+  optSourceCssFile,
   sourceUrls,
   wikiUrls,
   optDumpInterfaceFile,
@@ -67,6 +68,7 @@ data Flag
   | Flag_LaTeX
   | Flag_LaTeXStyle String
   | Flag_HyperlinkedSource
+  | Flag_SourceCss String
   | Flag_Help
   | Flag_Verbosity String
   | Flag_Version
@@ -119,6 +121,8 @@ options backwardsCompat =
       "output for Hoogle; you may want --package-name and --package-version too",
     Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource)
       "generate highlighted and hyperlinked source code (for use with --html)",
+    Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE")
+      "use custom CSS file instead of default one in hyperlinked source",
     Option []  ["source-base"]   (ReqArg Flag_SourceBaseURL "URL")
       "URL for a source code link on the contents\nand index pages",
     Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"])
@@ -242,6 +246,8 @@ optIndexUrl flags = optLast [ url | Flag_UseIndex url <- flags ]
 optCssFile :: [Flag] -> Maybe FilePath
 optCssFile flags = optLast [ str | Flag_CSS str <- flags ]
 
+optSourceCssFile :: [Flag] -> Maybe FilePath
+optSourceCssFile flags = optLast [ str | Flag_SourceCss str <- flags ]
 
 sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String)
 sourceUrls flags =