diff options
| -rw-r--r-- | haddock-api/src/Haddock.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker.hs | 30 |
2 files changed, 24 insertions, 8 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index c76966fc..02e19531 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -321,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do libDir when (Flag_HyperlinkedSource `elem` flags) $ do - ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap ifaces + ppHyperlinkedSource odir libDir opt_source_css pretty pkgKey srcMap ifaces -- | 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 f2caa2c1..1fadef49 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -14,35 +14,51 @@ import Data.Maybe import System.Directory import System.FilePath -ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath - -> PackageKey -> SrcMap -> [Interface] + +-- | Generate hyperlinked source for given interfaces. +-- +-- Note that list of interfaces should also contain interfaces normally hidden +-- when generating documentation. Otherwise this could lead to dead links in +-- produced source. +ppHyperlinkedSource :: FilePath -- ^ Output directory + -> FilePath -- ^ Resource directory + -> Maybe FilePath -- ^ Custom CSS file path + -> Bool -- ^ Flag indicating whether to pretty-print HTML + -> PackageKey -- ^ Package for which we create source + -> SrcMap -- ^ Paths to external sources + -> [Interface] -- ^ Interfaces for which we create source -> IO () -ppHyperlinkedSource outdir libdir mstyle pkg srcs ifaces = do +ppHyperlinkedSource outdir libdir mstyle pretty pkg srcs ifaces = do createDirectoryIfMissing True srcdir let cssFile = fromMaybe (defaultCssFile libdir) mstyle copyFile cssFile $ srcdir </> srcCssFile copyFile (libdir </> "html" </> highlightScript) $ srcdir </> highlightScript - mapM_ (ppHyperlinkedModuleSource srcdir pkg srcs) ifaces + mapM_ (ppHyperlinkedModuleSource srcdir pretty pkg srcs) ifaces where srcdir = outdir </> hypSrcDir -ppHyperlinkedModuleSource :: FilePath +-- | Generate hyperlinked source for particular interface. +ppHyperlinkedModuleSource :: FilePath -> Bool -> PackageKey -> SrcMap -> Interface -> IO () -ppHyperlinkedModuleSource srcdir pkg srcs iface = +ppHyperlinkedModuleSource srcdir pretty pkg srcs iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path . showHtml . render' $ tokens + Just tokens -> writeFile path . html . render' $ tokens Nothing -> return () where render' = render (Just srcCssFile) (Just highlightScript) pkg srcs + html = if pretty then renderHtml else showHtml path = srcdir </> hypSrcModuleFile (ifaceMod iface) +-- | Name of CSS file in output directory. srcCssFile :: FilePath srcCssFile = "style.css" +-- | Name of highlight script in output and resource directory. highlightScript :: FilePath highlightScript = "highlight.js" +-- | Path to default CSS file. defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir </> "html" </> "solarized.css" |