From 241346e4e275bdde2d28f90df3225057f4a09cfc Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 25 Jul 2015 19:48:08 +0200
Subject: Make hyperlinked source renderer generate line anchors.

---
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 26 +++++++++++++++++++---
 1 file changed, 23 insertions(+), 3 deletions(-)

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 5037421a..15793f0c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE RecordWildCards #-}
+
+
 module Haddock.Backends.Hyperlinker.Renderer (render) where
 
 
@@ -78,10 +81,11 @@ header mcss mjs =
 
 
 tokenGroup :: SrcMap -> TokenGroup -> Html
-tokenGroup _ (GrpNormal tok) =
-    tokenSpan tok ! attrs
+tokenGroup _ (GrpNormal tok@(Token { .. }))
+    | tkType == TkSpace = renderSpace (posRow . spStart $ tkSpan) tkValue
+    | otherwise = tokenSpan tok ! attrs
   where
-    attrs = [ multiclass . tokenStyle . tkType $ tok ]
+    attrs = [ multiclass . tokenStyle $ tkType ]
 tokenGroup srcs (GrpRich det tokens) =
     externalAnchor det . internalAnchor det . hyperlink srcs det $ content
   where
@@ -167,3 +171,19 @@ externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of
     Just (SrcExternal path) -> Html.anchor content !
         [ Html.href $ path </> hypSrcModuleUrl' name ]
     Nothing -> content
+
+
+renderSpace :: Int -> String -> Html
+renderSpace _ [] = Html.noHtml
+renderSpace line ('\n':rest) = mconcat
+    [ Html.thespan . Html.toHtml $ "\n"
+    , lineAnchor (line + 1)
+    , renderSpace (line + 1) rest
+    ]
+renderSpace line space =
+    let (hspace, rest) = span (/= '\n') space
+    in (Html.thespan . Html.toHtml) hspace <> renderSpace line rest
+
+
+lineAnchor :: Int -> Html
+lineAnchor line = Html.anchor Html.noHtml ! [ Html.name $ hypSrcLineUrl line ]
-- 
cgit v1.2.3