diff options
| -rw-r--r-- | haddock-api/src/Haddock.hs | 10 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker.hs | 41 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Utils.hs | 5 |
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 ------------------------------------------------------------------------------- |