Create hyperlinker module and plug it into the Haddock pipeline.

3 files changed, 30 insertions, 0 deletions

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 109e5f95..6ffde976 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -82,6 +82,7 @@ library
     Haddock.Backends.LaTeX
     Haddock.Backends.HaddockDB
     Haddock.Backends.Hoogle
+    Haddock.Backends.Hyperlinker
     Haddock.ModuleTree
     Haddock.Types
     Haddock.Doc
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 3e58aba3..e45456ab 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -30,6 +30,7 @@ import Haddock.Backends.Xhtml
 import Haddock.Backends.Xhtml.Themes (getThemes)
 import Haddock.Backends.LaTeX
 import Haddock.Backends.Hoogle
+import Haddock.Backends.Hyperlinker
 import Haddock.Interface
 import Haddock.Parser
 import Haddock.Types
@@ -308,6 +309,9 @@ render dflags flags qual ifaces installedIfaces srcMap = do
     ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
                   libDir
 
+  when (Flag_HyperlinkedSource `elem` flags) $ do
+    ppHyperlinkedSource odir libDir Nothing visibleIfaces
+
 -- | From GHC 7.10, this function has a potential to crash with a
 -- nasty message such as @expectJust getPackageDetails@ because
 -- package name and versions can no longer reliably be extracted in
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
new file mode 100644
index 00000000..88619474
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -0,0 +1,25 @@
+module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where
+
+import Haddock.Types
+import Haddock.Backends.Hyperlinker.Renderer
+
+import GHC
+import Text.XHtml hiding ((</>))
+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
+
+ppHyperlinkedModuleSource :: FilePath -> Maybe FilePath -> Interface -> IO ()
+ppHyperlinkedModuleSource outdir mstyle iface = case ifaceTokenizedSrc iface of
+    Just tokens -> writeFile path $ showHtml . render mstyle $ tokens
+    Nothing -> return ()
+  where
+    path = outdir </> "src" </> moduleSourceFile (ifaceMod iface)
+
+moduleSourceFile :: Module -> FilePath
+moduleSourceFile = (++ ".html") . moduleNameString . moduleName