Make source hyperlinker generate output in apropriate directory.

3 files changed, 38 insertions, 18 deletions

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 698122e3..01e4cd45 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -258,10 +258,16 @@ render dflags flags qual ifaces installedIfaces srcMap = do
     pkgNameVer       = modulePackageInfo dflags flags pkgMod
 
     (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
+
+    srcModule'
+      | isJust srcModule = srcModule
+      | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl
+      | otherwise = Nothing
+
     srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity
     -- TODO: Get these from the interface files as with srcMap
     srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity
-    sourceUrls' = (srcBase, srcModule, srcMap', srcLMap')
+    sourceUrls' = (srcBase, srcModule', srcMap', srcLMap')
 
   libDir   <- getHaddockLibDir flags
   prologue <- getPrologue dflags flags
@@ -311,7 +317,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
                   libDir
 
   when (Flag_HyperlinkedSource `elem` flags) $ do
-    ppHyperlinkedSource odir libDir opt_source_css visibleIfaces
+    ppHyperlinkedSource odir libDir opt_source_css sourceUrls' 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 9337307c..2ed4dbdd 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -1,45 +1,54 @@
 module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where
 
 import Haddock.Types
+import Haddock.Utils
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Utils
 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]
+ppHyperlinkedSource :: FilePath -> FilePath
+                    -> Maybe FilePath
+                    -> SourceURLs
+                    -> [Interface]
                     -> IO ()
-ppHyperlinkedSource outdir libdir mstyle ifaces = do
-    createDirectoryIfMissing True $ srcPath outdir
+ppHyperlinkedSource outdir libdir mstyle urls ifaces = do
+    createDirectoryIfMissing True srcdir
     let cssFile = fromMaybe (defaultCssFile libdir) mstyle
-    copyFile cssFile $ srcPath outdir </> srcCssFile
+    copyFile cssFile $ srcdir </> srcCssFile
     copyFile (libdir </> "html" </> highlightScript) $
-        srcPath outdir </> highlightScript
-    mapM_ (ppHyperlinkedModuleSource outdir) ifaces
+        srcdir </> highlightScript
+    mapM_ (ppHyperlinkedModuleSource outdir urls) ifaces
+  where
+    srcdir = srcPath outdir urls
 
-ppHyperlinkedModuleSource :: FilePath -> Interface -> IO ()
-ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of
+ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO ()
+ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of
     Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens
     Nothing -> return ()
   where
     mCssFile = Just $ srcCssFile
     mJsFile = Just $ highlightScript
-    path = srcPath outdir </> moduleSourceFile (ifaceMod iface)
-
-moduleSourceFile :: Module -> FilePath
-moduleSourceFile = (++ ".html") . moduleNameString . moduleName
+    srcFile = spliceURL Nothing (Just $ ifaceMod iface) Nothing Nothing $
+        srcModUrl urls
+    path = outdir </> srcFile
 
-srcPath :: FilePath -> FilePath
-srcPath outdir = outdir </> "src"
+srcPath :: FilePath -> SourceURLs -> FilePath
+srcPath outdir urls = outdir </> takeDirectory (srcModUrl urls)
 
 srcCssFile :: FilePath
-srcCssFile = "style.css"
+srcCssFile = "srcstyle.css"
 
 highlightScript :: FilePath
 highlightScript = "highlight.js"
 
 defaultCssFile :: FilePath -> FilePath
 defaultCssFile libdir = libdir </> "html" </> "solarized.css"
+
+srcModUrl :: SourceURLs -> String
+srcModUrl (_, mModSrcUrl, _, _) = fromMaybe defaultModuleSourceUrl mModSrcUrl
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 4fed3a1e..78c78aca 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -29,6 +29,7 @@ module Haddock.Utils (
   moduleNameUrl, moduleNameUrl', moduleUrl,
   nameAnchorId,
   makeAnchorId,
+  defaultModuleSourceUrl,
 
   -- * Miscellaneous utilities
   getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
@@ -277,6 +278,10 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
        -- NB: '-' is legal in IDs, but we use it as the escape char
 
 
+defaultModuleSourceUrl :: String
+defaultModuleSourceUrl = "src/%{MODULE}.html"
+
+
 -------------------------------------------------------------------------------
 -- * Files we need to copy from our $libdir
 -------------------------------------------------------------------------------