Source hyperlinker

.gitignore

@@ -2,6 +2,7 @@
 /haddock-api/dist/
 /haddock-library/dist/
 /html-test/out/
+/hypsrc-test/out/
 /latex-test/out/
 
 /doc/haddock

doc/haddock.xml

@@ -345,31 +345,53 @@
       <varlistentry>
         <term>
           <indexterm><primary><option>-i</option></primary></indexterm>
-          <option>-i</option> <replaceable>path</replaceable>,<replaceable>file</replaceable>
+          <option>-i</option> <replaceable>file</replaceable>
+        </term>
+        <term>
+          <indexterm><primary><option>-i</option></primary></indexterm>
+          <option>-i</option> <replaceable>docpath</replaceable>,<replaceable>file</replaceable>
+        </term>
+        <term>
+          <indexterm><primary><option>-i</option></primary></indexterm>
+          <option>-i</option> <replaceable>docpath</replaceable>,<replaceable>srcpath</replaceable>,<replaceable>file</replaceable>
+        </term>
+        <term>
+          <indexterm><primary><option>--read-interface</option></primary></indexterm>
+          <option>--read-interface</option>=<replaceable>file</replaceable>
         </term>
         <term>
           <indexterm><primary><option>--read-interface</option></primary></indexterm>
-          <option>--read-interface</option>=<replaceable>path</replaceable>,<replaceable>file</replaceable>
+          <option>--read-interface</option>=<replaceable>docpath</replaceable>,<replaceable>file</replaceable>
+        </term>
+        <term>
+          <indexterm><primary><option>--read-interface</option></primary></indexterm>
+          <option>--read-interface</option>=<replaceable>docpath</replaceable>,<replaceable>srcpath</replaceable>,<replaceable>file</replaceable>
         </term>
         <listitem>
           <para>Read the interface file in
           <replaceable>file</replaceable>, which must have been
           produced by running Haddock with the
           <option>--dump-interface</option> option.  The interface
           describes a set of modules whose HTML documentation is
-          located in <replaceable>path</replaceable> (which may be a
-          relative pathname).  The <replaceable>path</replaceable> is
-          optional, and defaults to <quote>.</quote>.</para>
+          located in <replaceable>docpath</replaceable> (which may be a
+          relative pathname).  The <replaceable>docpath</replaceable> is
+          optional, and defaults to <quote>.</quote>. The
+          <replaceable>srcpath</replaceable> is optional but has no default
+          value.</para>
 
           <para>This option allows Haddock to produce separate sets of
           documentation with hyperlinks between them.  The
-          <replaceable>path</replaceable> is used to direct hyperlinks
+          <replaceable>docpath</replaceable> is used to direct hyperlinks
           to point to the right files; so make sure you don't move the
           HTML files later or these links will break.  Using a
-          relative <replaceable>path</replaceable> means that a
+          relative <replaceable>docpath</replaceable> means that a
           documentation subtree can still be moved around without
           breaking links.</para>
 
+          <para>Similarly to <replaceable>docpath</replaceable>, <replaceable>srcpath</replaceable> is used generate cross-package hyperlinks but
+          within sources rendered with <option>--hyperlinked-source</option>
+          option.</para>
+
           <para>Multiple <option>--read-interface</option> options may
           be given.</para>
         </listitem>
@@ -528,6 +550,43 @@ $ pdflatex <replaceable>package</replaceable>.tex</screen>
         </listitem>
       </varlistentry>
 
+      <varlistentry>
+        <term>
+          <indexterm><primary><option>--hyperlinked-source</option></primary></indexterm>
+          <option>--hyperlinked-source</option>
+        </term>
+        <listitem>
+          <para>Generate hyperlinked source code (as HTML web page). All
+          rendered files will be put into
+          <filename class='directory'>src/</filename> subfolder of output
+          directory.</para>
+          <para>Usually, this should be used in combination with
+          <option>--html</option> option - generated documentation will then
+          contain references to appropriate code fragments. Previously, this
+          behaviour could be achieved by generating sources using external
+          tool and specifying <option>--source-base</option>,
+          <option>--source-module</option>, <option>--source-entity</option>
+          and related options. Note that these flags are ignored once
+          <option>--hyperlinked-source</option> is set.</para>
+          <para>In order to make cross-package source hyperlinking possible,
+          appropriate source paths have to be set up when providing
+          interface files using <option>--read-interface</option>
+          option.</para>
+        </listitem>
+      </varlistentry>
+
+      <varlistentry>
+        <term>
+          <indexterm><primary><option>--source-css</option></primary></indexterm>
+          <option>--source-css=<replaceable>style</replaceable></option>
+        </term>
+        <listitem>
+          <para>Use custom CSS file for sources rendered by the
+          <option>--hyperlinked-source</option> option. If no custom style
+          file is provided, Haddock will use default one.</para>
+        </listitem>
+      </varlistentry>
+
       <varlistentry>
         <term>
           <indexterm><primary><option>-S</option></primary></indexterm>

haddock-api/haddock-api.cabal

@@ -18,8 +18,10 @@ stability:            experimental
 data-dir:
   resources
 data-files:
+  html/solarized.css
   html/frames.html
   html/haddock-util.js
+  html/highlight.js
   html/Classic.theme/haskell_icon.gif
   html/Classic.theme/minus.gif
   html/Classic.theme/plus.gif
@@ -79,6 +81,12 @@ library
     Haddock.Backends.LaTeX
     Haddock.Backends.HaddockDB
     Haddock.Backends.Hoogle
+    Haddock.Backends.Hyperlinker
+    Haddock.Backends.Hyperlinker.Ast
+    Haddock.Backends.Hyperlinker.Parser
+    Haddock.Backends.Hyperlinker.Renderer
+    Haddock.Backends.Hyperlinker.Types
+    Haddock.Backends.Hyperlinker.Utils
     Haddock.ModuleTree
     Haddock.Types
     Haddock.Doc
@@ -89,6 +97,27 @@ library
     Haddock.Convert
     Paths_haddock_api
 
+test-suite spec
+  type:             exitcode-stdio-1.0
+  default-language: Haskell2010
+  main-is:          Spec.hs
+  ghc-options: -Wall
+
+  hs-source-dirs:
+      test
+    , src
+
+  other-modules:
+    Haddock.Backends.Hyperlinker.ParserSpec
+
+  build-depends:
+      base >= 4.3 && < 4.9
+    , containers
+    , ghc >= 7.10 && < 7.10.2
+
+    , hspec
+    , QuickCheck == 2.*
+
 source-repository head
   type:     git
   location: https://github.com/haskell/haddock.git

haddock-api/resources/html/highlight.js

@@ -0,0 +1,27 @@
+
+var highlight = function (on) {
+	return function () {
+		var links = document.getElementsByTagName('a');
+		for (var i = 0; i < links.length; i++) {
+			var that = links[i];
+
+			if (this.href != that.href) {
+				continue;
+			}
+
+			if (on) {
+				that.classList.add("hover-highlight");
+			} else {
+				that.classList.remove("hover-highlight");
+			}
+		}
+	}
+};
+
+window.onload = function () {
+	var links = document.getElementsByTagName('a');
+	for (var i = 0; i < links.length; i++) {
+		links[i].onmouseover = highlight(true);
+		links[i].onmouseout = highlight(false);
+	}
+};

haddock-api/resources/html/solarized.css

@@ -0,0 +1,55 @@
+body {
+	background-color: #fdf6e3;
+}
+
+.hs-identifier {
+	color: #073642;
+}
+
+.hs-identifier.hs-var {
+}
+
+.hs-identifier.hs-type {
+	color: #5f5faf;
+}
+
+.hs-keyword {
+	color: #af005f;
+}
+
+.hs-string, .hs-char {
+	color: #cb4b16;
+}
+
+.hs-number {
+	color: #268bd2;
+}
+
+.hs-operator {
+	color: #d33682;
+}
+
+.hs-glyph, .hs-special {
+	color: #dc322f;
+}
+
+.hs-comment {
+	color: #8a8a8a;
+}
+
+.hs-pragma {
+	color: #2aa198;
+}
+
+.hs-cpp {
+	color: #859900;
+}
+
+a:link, a:visited {
+	text-decoration: none;
+	border-bottom: 1px solid #eee8d5;
+}
+
+a:hover, a.hover-highlight {
+	background-color: #eee8d5;
+}

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
@@ -45,6 +46,7 @@ import Data.List (isPrefixOf)
 import Control.Exception
 import Data.Maybe
 import Data.IORef
+import Data.Map (Map)
 import qualified Data.Map as Map
 import System.IO
 import System.Exit
@@ -158,6 +160,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
           _ -> return flags
 
   unless (Flag_NoWarnings `elem` flags) $ do
+    hypSrcWarnings flags
     forM_ (warnings args) $ \warning -> do
       hPutStrLn stderr warning
 
@@ -226,13 +229,16 @@ renderStep dflags flags qual pkgs interfaces = do
   let
     ifaceFiles = map snd pkgs
     installedIfaces = concatMap ifInstalledIfaces ifaceFiles
-    srcMap = Map.fromList [ (ifPackageKey if_, x) | ((_, Just x), if_) <- pkgs ]
-  render dflags flags qual interfaces installedIfaces srcMap
+    extSrcMap = Map.fromList $ do
+      ((_, Just path), ifile) <- pkgs
+      iface <- ifInstalledIfaces ifile
+      return (instMod iface, path)
+  render dflags flags qual interfaces installedIfaces extSrcMap
 
 
 -- | Render the interfaces with whatever backend is specified in the flags.
-render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
-render dflags flags qual ifaces installedIfaces srcMap = do
+render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO ()
+render dflags flags qual ifaces installedIfaces extSrcMap = do
 
   let
     title                = fromMaybe "" (optTitle flags)
@@ -243,6 +249,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 ]
 
@@ -256,10 +263,25 @@ render dflags flags qual ifaces installedIfaces srcMap = do
     pkgNameVer       = modulePackageInfo dflags flags pkgMod
 
     (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
-    srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity
+
+    srcModule'
+      | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat
+      | otherwise = srcModule
+
+    srcMap = mkSrcMap $ Map.union
+      (Map.map SrcExternal extSrcMap)
+      (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ])
+
+    pkgSrcMap = Map.mapKeys modulePackageKey extSrcMap
+    pkgSrcMap'
+      | Flag_HyperlinkedSource `elem` flags =
+          Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap
+      | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl pkgSrcMap
+      | otherwise = pkgSrcMap
+
     -- 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', pkgSrcMap', srcLMap')
 
   libDir   <- getHaddockLibDir flags
   prologue <- getPrologue dflags flags
@@ -308,6 +330,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 opt_source_css pretty srcMap ifaces
+
 -- | 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
@@ -476,6 +501,35 @@ shortcutFlags flags = do
       ++ "Ported to use the GHC API by David Waern 2006-2008\n"
 
 
+-- | Generate some warnings about potential misuse of @--hyperlinked-source@.
+hypSrcWarnings :: [Flag] -> IO ()
+hypSrcWarnings flags = do
+
+    when (hypSrc && any isSourceUrlFlag flags) $
+        hPutStrLn stderr $ concat
+            [ "Warning: "
+            , "--source-* options are ignored when "
+            , "--hyperlinked-source is enabled."
+            ]
+
+    when (not hypSrc && any isSourceCssFlag flags) $
+        hPutStrLn stderr $ concat
+            [ "Warning: "
+            , "source CSS file is specified but "
+            , "--hyperlinked-source is disabled."
+            ]
+
+  where
+    hypSrc = Flag_HyperlinkedSource `elem` flags
+    isSourceUrlFlag (Flag_SourceBaseURL _) = True
+    isSourceUrlFlag (Flag_SourceModuleURL _) = True
+    isSourceUrlFlag (Flag_SourceEntityURL _) = True
+    isSourceUrlFlag (Flag_SourceLEntityURL _) = True
+    isSourceUrlFlag _ = False
+    isSourceCssFlag (Flag_SourceCss _) = True
+    isSourceCssFlag _ = False
+
+
 updateHTMLXRefs :: [(DocPaths, InterfaceFile)] -> IO ()
 updateHTMLXRefs packages = do
   writeIORef html_xrefs_ref (Map.fromList mapping)