From ce0237fa8f482a64dc8ea3ec409a1482ac89e6ac Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 4 Jun 2015 19:27:34 +0200
Subject: Create scaffolding for Haskell source parser module.

---
 .../src/Haddock/Backends/Hyperlinker/Parser.hs     | 36 ++++++++++++++++++++++
 1 file changed, 36 insertions(+)
 create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
new file mode 100644
index 00000000..11a92b57
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -0,0 +1,36 @@
+module Haddock.Backends.Hyperlinker.Parser (parse) where
+
+data Token = Token
+    { tkType :: TokenType
+    , tkValue :: String
+    , tkSpan :: Span
+    }
+
+data Position = Position
+    { posRow :: !Int
+    , posCol :: !Int
+    }
+
+data Span = Span
+    { spStart :: Position
+    , spEnd :: Position
+    }
+
+data TokenType
+    = Identifier
+    | Comment
+    | Whitespace
+    | Operator
+    | Symbol
+
+parse :: String -> [Token]
+parse = tokenize . tag . chunk
+
+chunk :: String -> [String]
+chunk = undefined
+
+tag :: [String] -> [(Span, String)]
+tag = undefined
+
+tokenize :: [(Span, String)] -> [Token]
+tokenize = undefined
-- 
cgit v1.2.3


From e17f62506ecf20d61781c610d6fbb5f3c8cd132e Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 4 Jun 2015 19:59:27 +0200
Subject: Implement function for tagging parsed chunks with source spans.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 9 ++++++++-
 1 file changed, 8 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 11a92b57..4bcc0c8a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -30,7 +30,14 @@ chunk :: String -> [String]
 chunk = undefined
 
 tag :: [String] -> [(Span, String)]
-tag = undefined
+tag =
+    reverse . snd . foldl aux (Position 1 1, [])
+  where
+    aux (pos, cs) c =
+        let pos' = if c == "\n"
+                   then pos { posRow = posRow pos + 1, posCol = 1 }
+                   else pos { posCol = posCol pos + length c }
+        in (pos', (Span pos pos', c):cs)
 
 tokenize :: [(Span, String)] -> [Token]
 tokenize = undefined
-- 
cgit v1.2.3


From 413f7f322cd174e2ba4116dbf53c1b3c0d6a4f77 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 4 Jun 2015 21:10:26 +0200
Subject: Implement simple string chunking based on HsColour library.

---
 .../src/Haddock/Backends/Hyperlinker/Parser.hs     | 28 +++++++++++++++++++++-
 1 file changed, 27 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 4bcc0c8a..4e0d7382 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -1,5 +1,8 @@
 module Haddock.Backends.Hyperlinker.Parser (parse) where
 
+import Data.Char
+import Data.List
+
 data Token = Token
     { tkType :: TokenType
     , tkValue :: String
@@ -27,7 +30,30 @@ parse :: String -> [Token]
 parse = tokenize . tag . chunk
 
 chunk :: String -> [String]
-chunk = undefined
+chunk [] = []
+chunk str@(c:_)
+    | isSpace c = chunk' $ span isSpace str
+chunk str
+    | "--" `isPrefixOf` str = chunk' $ span (not . (== '\n')) str
+    | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str
+    | otherwise = chunk' $ head $ lex str
+
+chunk' :: (String, String) -> [String]
+chunk' (c, rest) = c:(chunk rest)
+
+chunkComment :: Int -> String -> (String, String)
+chunkComment _ [] = ("", "")
+chunkComment depth ('{':'-':str) =
+    let (c, rest) = chunkComment (depth + 1) str
+    in ("{-" ++ c, rest)
+chunkComment depth ('-':'}':str)
+    | depth == 1 = ("-}", str)
+    | otherwise =
+        let (c, rest) = chunkComment (depth - 1) str
+        in ("-}" ++ c, rest)
+chunkComment depth (e:str) =
+    let (c, rest) = chunkComment depth str
+    in (e:c, rest)
 
 tag :: [String] -> [(Span, String)]
 tag =
-- 
cgit v1.2.3


From 6fb8d5abbcc92f5155fdc9596ca1c87fe87f6187 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 4 Jun 2015 23:21:17 +0200
Subject: Create basic token classification method.

---
 .../src/Haddock/Backends/Hyperlinker/Parser.hs     | 104 +++++++++++++++++++--
 1 file changed, 98 insertions(+), 6 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 4e0d7382..be6b7ce5 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -20,11 +20,18 @@ data Span = Span
     }
 
 data TokenType
-    = Identifier
-    | Comment
-    | Whitespace
-    | Operator
-    | Symbol
+    = TkIdentifier
+    | TkKeyword
+    | TkString
+    | TkChar
+    | TkNumber
+    | TkOperator
+    | TkGlyph
+    | TkSpecial
+    | TkSpace
+    | TkComment
+    | TkCpp
+    | TkUnknown
 
 parse :: String -> [Token]
 parse = tokenize . tag . chunk
@@ -66,4 +73,89 @@ tag =
         in (pos', (Span pos pos', c):cs)
 
 tokenize :: [(Span, String)] -> [Token]
-tokenize = undefined
+tokenize =
+    map aux
+  where
+    aux (sp, str) = Token
+        { tkType = classify str
+        , tkValue = str
+        , tkSpan = sp
+        }
+
+classify :: String -> TokenType
+classify (c:_)
+    | isSpace c = TkSpace
+    | isDigit c = TkNumber
+    | c `elem` special = TkSpecial
+    | c == '#' = TkCpp
+    | c == '"' = TkString
+    | c == '\'' = TkChar
+classify str
+    | str `elem` keywords = TkKeyword
+    | str `elem` glyphs = TkGlyph
+    | all (`elem` symbols) str = TkOperator
+    | "--" `isPrefixOf` str = TkComment
+    | "{-" `isPrefixOf` str = TkComment
+    | isIdentifier str = TkIdentifier
+    | otherwise = TkUnknown
+
+keywords :: [String]
+keywords =
+    [ "as"
+    , "case"
+    , "class"
+    , "data"
+    , "default"
+    , "deriving"
+    , "do"
+    , "else"
+    , "hiding"
+    , "if"
+    , "import"
+    , "in"
+    , "infix"
+    , "infixl"
+    , "infixr"
+    , "instance"
+    , "let"
+    , "module"
+    , "newtype"
+    , "of"
+    , "qualified"
+    , "then"
+    , "type"
+    , "where"
+    , "forall"
+    , "mdo"
+    ]
+
+glyphs :: [String]
+glyphs =
+    [ ".."
+    , ":"
+    , "::"
+    , "="
+    , "\\"
+    , "|"
+    , "<-"
+    , "->"
+    , "@"
+    , "~"
+    , "~#"
+    , "=>"
+    , "-"
+    , "!"
+    ]
+
+special :: [Char]
+special = "()[]{},;`"
+
+-- TODO: Add support for any Unicode symbol or punctuation.
+-- source: http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators
+symbols :: [Char]
+symbols = "!#$%&*+./<=>?@\\^|-~:"
+
+isIdentifier :: String -> Bool
+isIdentifier (c:str)
+    | isLetter c = all (\c' -> isAlphaNum c' || c == '\'') str
+isIdentifier _ = False
-- 
cgit v1.2.3


From 57d4c9cff1d60f7dd0f8dafae5537218b63da90f Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 00:07:52 +0200
Subject: Adapt source span tagging to work with current whitespace handling.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 11 +++++++----
 1 file changed, 7 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index be6b7ce5..53ff1f65 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -67,10 +67,13 @@ tag =
     reverse . snd . foldl aux (Position 1 1, [])
   where
     aux (pos, cs) c =
-        let pos' = if c == "\n"
-                   then pos { posRow = posRow pos + 1, posCol = 1 }
-                   else pos { posCol = posCol pos + length c }
-        in (pos', (Span pos pos', c):cs)
+        let pos' = move pos c
+        in (pos', ((Span pos pos', c):cs))
+    move pos str@(c:_)
+        | isSpace c = foldl move' pos str
+    move pos str = pos { posCol = posCol pos + length str }
+    move' pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 }
+    move' pos _ = pos { posCol = posCol pos + 1 }
 
 tokenize :: [(Span, String)] -> [Token]
 tokenize =
-- 
cgit v1.2.3


From c7ecc590090d7f1a4ce8e6d0233c41350202a4bd Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 00:16:15 +0200
Subject: Add record accessors to exports of hyperlinker parser module.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 53ff1f65..4130ab6c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -1,4 +1,9 @@
-module Haddock.Backends.Hyperlinker.Parser (parse) where
+module Haddock.Backends.Hyperlinker.Parser
+    ( parse
+    , tkType, tkValue, tkSpan
+    , posRow, posCol
+    , spStart, spEnd
+    ) where
 
 import Data.Char
 import Data.List
-- 
cgit v1.2.3


From 7b607883d0cea7a795275a2484a33bd89a3b4fc6 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 11:56:01 +0200
Subject: Make parser module export all types and associated accessors.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 4130ab6c..7a162f6d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -1,8 +1,7 @@
 module Haddock.Backends.Hyperlinker.Parser
     ( parse
-    , tkType, tkValue, tkSpan
-    , posRow, posCol
-    , spStart, spEnd
+    , Token(..), TokenType(..)
+    , Position(..), Span(..)
     ) where
 
 import Data.Char
-- 
cgit v1.2.3


From 5e904cb1c3d769d5b99d459838b4b5368c8c1fb7 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 12:59:10 +0200
Subject: Create simple HTML renderer for parsed source file.

---
 haddock-api/haddock-api.cabal                      |  3 ++-
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 26 ++++++++++++++++++++++
 2 files changed, 28 insertions(+), 1 deletion(-)
 create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index b90e3bff..6c6dc810 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -57,6 +57,8 @@ library
 
   exposed-modules:
     Documentation.Haddock
+    Haddock.Backends.Hyperlinker.Parser
+    Haddock.Backends.Hyperlinker.Renderer
 
   other-modules:
     Haddock
@@ -79,7 +81,6 @@ library
     Haddock.Backends.LaTeX
     Haddock.Backends.HaddockDB
     Haddock.Backends.Hoogle
-    Haddock.Backends.Hyperlinker.Parser
     Haddock.ModuleTree
     Haddock.Types
     Haddock.Doc
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
new file mode 100644
index 00000000..eaf5b37b
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -0,0 +1,26 @@
+module Haddock.Backends.Hyperlinker.Renderer where
+
+import Haddock.Backends.Hyperlinker.Parser
+
+import Data.Monoid
+import Text.XHtml
+
+render :: [Token] -> Html
+render = body . pre . foldr (<>) noHtml . map renderToken
+
+renderToken :: Token -> Html
+renderToken (Token t v _) = thespan (toHtml v) ! tokenAttrs t
+
+tokenAttrs :: TokenType -> [HtmlAttr]
+tokenAttrs TkIdentifier = [theclass "hs-identifier"]
+tokenAttrs TkKeyword = [theclass "hs-keyword"]
+tokenAttrs TkString = [theclass "hs-string"]
+tokenAttrs TkChar = [theclass "hs-char"]
+tokenAttrs TkNumber = [theclass "hs-number"]
+tokenAttrs TkOperator = [theclass "hs-operator"]
+tokenAttrs TkGlyph = [theclass "hs-glyph"]
+tokenAttrs TkSpecial = [theclass "hs-special"]
+tokenAttrs TkSpace = []
+tokenAttrs TkComment = [theclass "hs-comment"]
+tokenAttrs TkCpp = [theclass "hs-cpp"]
+tokenAttrs TkUnknown = []
-- 
cgit v1.2.3


From 1a43f35e2dacc9837f9762fd211d63ae6cc7b4a3 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 13:58:47 +0200
Subject: Add support for specifying the CSS file path in HTML source renderer.

---
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 45 ++++++++++++++--------
 1 file changed, 30 insertions(+), 15 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index eaf5b37b..9ebb8707 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -3,24 +3,39 @@ module Haddock.Backends.Hyperlinker.Renderer where
 import Haddock.Backends.Hyperlinker.Parser
 
 import Data.Monoid
-import Text.XHtml
+import Text.XHtml (Html, HtmlAttr, (!))
+import qualified Text.XHtml as Html
 
-render :: [Token] -> Html
-render = body . pre . foldr (<>) noHtml . map renderToken
+render :: Maybe FilePath -> [Token] -> Html
+render css tokens = header css <> body tokens
 
-renderToken :: Token -> Html
-renderToken (Token t v _) = thespan (toHtml v) ! tokenAttrs t
+body :: [Token] -> Html
+body = Html.body . Html.pre . mconcat . map token
+
+header :: Maybe FilePath -> Html
+header Nothing = Html.noHtml
+header (Just css) =
+    Html.header $ Html.thelink Html.noHtml ! attrs
+  where
+    attrs =
+        [ Html.rel "stylesheet"
+        , Html.href css
+        , Html.thetype "text/css"
+        ]
+
+token :: Token -> Html
+token (Token t v _) = Html.thespan (Html.toHtml v) ! tokenAttrs t
 
 tokenAttrs :: TokenType -> [HtmlAttr]
-tokenAttrs TkIdentifier = [theclass "hs-identifier"]
-tokenAttrs TkKeyword = [theclass "hs-keyword"]
-tokenAttrs TkString = [theclass "hs-string"]
-tokenAttrs TkChar = [theclass "hs-char"]
-tokenAttrs TkNumber = [theclass "hs-number"]
-tokenAttrs TkOperator = [theclass "hs-operator"]
-tokenAttrs TkGlyph = [theclass "hs-glyph"]
-tokenAttrs TkSpecial = [theclass "hs-special"]
+tokenAttrs TkIdentifier = [Html.theclass "hs-identifier"]
+tokenAttrs TkKeyword = [Html.theclass "hs-keyword"]
+tokenAttrs TkString = [Html.theclass "hs-string"]
+tokenAttrs TkChar = [Html.theclass "hs-char"]
+tokenAttrs TkNumber = [Html.theclass "hs-number"]
+tokenAttrs TkOperator = [Html.theclass "hs-operator"]
+tokenAttrs TkGlyph = [Html.theclass "hs-glyph"]
+tokenAttrs TkSpecial = [Html.theclass "hs-special"]
 tokenAttrs TkSpace = []
-tokenAttrs TkComment = [theclass "hs-comment"]
-tokenAttrs TkCpp = [theclass "hs-cpp"]
+tokenAttrs TkComment = [Html.theclass "hs-comment"]
+tokenAttrs TkCpp = [Html.theclass "hs-cpp"]
 tokenAttrs TkUnknown = []
-- 
cgit v1.2.3


From 01a2e7c5ab873c0041624a6ec0b0a54eb7da60cc Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 14:39:28 +0200
Subject: Fix identifier recognition in Haskell source parser.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 7a162f6d..9d58728f 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -163,6 +163,9 @@ symbols :: [Char]
 symbols = "!#$%&*+./<=>?@\\^|-~:"
 
 isIdentifier :: String -> Bool
-isIdentifier (c:str)
-    | isLetter c = all (\c' -> isAlphaNum c' || c == '\'') str
+isIdentifier (s:str)
+    | (isLower' s || isUpper s) && all isAlphaNum' str = True
+  where
+    isLower' c = isLower c || c == '_'
+    isAlphaNum' c = isAlphaNum c || c == '_' || c == '\''
 isIdentifier _ = False
-- 
cgit v1.2.3


From ffd0e8028f15f3616f1b3eaaf98459c0c75c6313 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 14:56:59 +0200
Subject: Fix comment recognition in Haskell source parser.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 9d58728f..29edb4c3 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -90,6 +90,9 @@ tokenize =
         }
 
 classify :: String -> TokenType
+classify str
+    | "--" `isPrefixOf` str = TkComment
+    | "{-" `isPrefixOf` str = TkComment
 classify (c:_)
     | isSpace c = TkSpace
     | isDigit c = TkNumber
@@ -101,8 +104,6 @@ classify str
     | str `elem` keywords = TkKeyword
     | str `elem` glyphs = TkGlyph
     | all (`elem` symbols) str = TkOperator
-    | "--" `isPrefixOf` str = TkComment
-    | "{-" `isPrefixOf` str = TkComment
     | isIdentifier str = TkIdentifier
     | otherwise = TkUnknown
 
-- 
cgit v1.2.3


From e5bd5d39550692f936c973637f8ec8d314919359 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 5 Jun 2015 15:12:40 +0200
Subject: Add support for recognizing compiler pragmas in source parser.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs   | 2 ++
 haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 1 +
 2 files changed, 3 insertions(+)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 29edb4c3..0e1ad5b2 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -35,6 +35,7 @@ data TokenType
     | TkSpace
     | TkComment
     | TkCpp
+    | TkPragma
     | TkUnknown
 
 parse :: String -> [Token]
@@ -92,6 +93,7 @@ tokenize =
 classify :: String -> TokenType
 classify str
     | "--" `isPrefixOf` str = TkComment
+    | "{-#" `isPrefixOf` str = TkPragma
     | "{-" `isPrefixOf` str = TkComment
 classify (c:_)
     | isSpace c = TkSpace
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 9ebb8707..39d7d183 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -38,4 +38,5 @@ tokenAttrs TkSpecial = [Html.theclass "hs-special"]
 tokenAttrs TkSpace = []
 tokenAttrs TkComment = [Html.theclass "hs-comment"]
 tokenAttrs TkCpp = [Html.theclass "hs-cpp"]
+tokenAttrs TkPragma = [Html.theclass "hs-pragma"]
 tokenAttrs TkUnknown = []
-- 
cgit v1.2.3


From d275f87c4cfa1e8da042f70659331121afa9a15c Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 6 Jun 2015 19:27:37 +0200
Subject: Create scaffolding of module for associating tokens with AST names.

---
 haddock-api/haddock-api.cabal                       |  1 +
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 20 ++++++++++++++++++++
 2 files changed, 21 insertions(+)
 create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 6c6dc810..109e5f95 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -59,6 +59,7 @@ library
     Documentation.Haddock
     Haddock.Backends.Hyperlinker.Parser
     Haddock.Backends.Hyperlinker.Renderer
+    Haddock.Backends.Hyperlinker.Ast
 
   other-modules:
     Haddock
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
new file mode 100644
index 00000000..abd3ca2b
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -0,0 +1,20 @@
+module Haddock.Backends.Hyperlinker.Ast where
+
+import qualified GHC
+
+import Haddock.Backends.Hyperlinker.Parser
+
+data RichToken = RichToken
+    { rtkToken :: Token
+    , rtkName :: Maybe GHC.Name
+    }
+
+enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
+enrich src =
+    map $ \token -> RichToken
+        { rtkToken = token
+        , rtkName = lookupName src $ tkSpan token
+        }
+
+lookupName :: GHC.RenamedSource -> Span -> Maybe GHC.Name
+lookupName = undefined
-- 
cgit v1.2.3


From 74de0021815f0642a89017fbb1fbdf18064cb5ea Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 6 Jun 2015 19:36:53 +0200
Subject: Implement utility method for extracting variable identifiers from
 AST.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 16 ++++++++++++++++
 1 file changed, 16 insertions(+)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index abd3ca2b..62c0d439 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -1,6 +1,10 @@
+{-# LANGUAGE RankNTypes #-}
+
 module Haddock.Backends.Hyperlinker.Ast where
 
 import qualified GHC
+import Data.Data
+import Control.Applicative
 
 import Haddock.Backends.Hyperlinker.Parser
 
@@ -18,3 +22,15 @@ enrich src =
 
 lookupName :: GHC.RenamedSource -> Span -> Maybe GHC.Name
 lookupName = undefined
+
+everything :: (r -> r -> r) -> (forall a. Data a => a -> r)
+           -> (forall a. Data a => a -> r)
+everything k f x = foldl k (f x) (gmapQ (everything k f) x)
+
+variables :: GHC.RenamedSource -> [(GHC.SrcSpan, GHC.Name)]
+variables =
+    everything (<|>) var
+  where
+    var term = case cast term of
+        (Just (GHC.L sspan (GHC.HsVar sid))) -> pure (sspan, sid)
+        _ -> empty
-- 
cgit v1.2.3


From d06a2b502e7909dff517a7c825e772b493bade24 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 6 Jun 2015 20:04:02 +0200
Subject: Create simple mechanism for associating tokens with AST names.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 30 +++++++++++++++++-----
 1 file changed, 23 insertions(+), 7 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 62c0d439..031ddd5c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -2,11 +2,13 @@
 
 module Haddock.Backends.Hyperlinker.Ast where
 
+import Haddock.Backends.Hyperlinker.Parser
+
 import qualified GHC
-import Data.Data
-import Control.Applicative
 
-import Haddock.Backends.Hyperlinker.Parser
+import Control.Applicative
+import Data.Data
+import Data.Maybe
 
 data RichToken = RichToken
     { rtkToken :: Token
@@ -17,20 +19,34 @@ enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
     map $ \token -> RichToken
         { rtkToken = token
-        , rtkName = lookupName src $ tkSpan token
+        , rtkName = lookupBySpan (tkSpan token) nameMap
         }
+  where
+    nameMap = variables src
+
+type NameMap = [(GHC.SrcSpan, GHC.Name)]
 
-lookupName :: GHC.RenamedSource -> Span -> Maybe GHC.Name
-lookupName = undefined
+lookupBySpan :: Span -> NameMap -> Maybe GHC.Name
+lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)
 
 everything :: (r -> r -> r) -> (forall a. Data a => a -> r)
            -> (forall a. Data a => a -> r)
 everything k f x = foldl k (f x) (gmapQ (everything k f) x)
 
-variables :: GHC.RenamedSource -> [(GHC.SrcSpan, GHC.Name)]
+variables :: GHC.RenamedSource -> NameMap
 variables =
     everything (<|>) var
   where
     var term = case cast term of
         (Just (GHC.L sspan (GHC.HsVar sid))) -> pure (sspan, sid)
         _ -> empty
+
+matches :: Span -> GHC.SrcSpan -> Bool
+matches tspan (GHC.RealSrcSpan aspan)
+    | rs && cs && re && ce = True
+  where
+    rs = (posRow . spStart) tspan == GHC.srcSpanStartLine aspan
+    cs = (posCol . spStart) tspan == GHC.srcSpanStartCol aspan
+    re = (posRow . spEnd) tspan == GHC.srcSpanEndLine aspan
+    ce = (posCol . spEnd) tspan == GHC.srcSpanStartLine aspan
+matches _ _ = False
-- 
cgit v1.2.3


From cb3ece1a493eb444ccb61b6ad3c74e922184b63e Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 6 Jun 2015 21:43:15 +0200
Subject: Add dummy support for hyperlinking named tokens.

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

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 39d7d183..32d2c863 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,16 +1,20 @@
 module Haddock.Backends.Hyperlinker.Renderer where
 
 import Haddock.Backends.Hyperlinker.Parser
+import Haddock.Backends.Hyperlinker.Ast
+
+import qualified GHC
+import qualified Name as GHC
 
 import Data.Monoid
 import Text.XHtml (Html, HtmlAttr, (!))
 import qualified Text.XHtml as Html
 
-render :: Maybe FilePath -> [Token] -> Html
+render :: Maybe FilePath -> [RichToken] -> Html
 render css tokens = header css <> body tokens
 
-body :: [Token] -> Html
-body = Html.body . Html.pre . mconcat . map token
+body :: [RichToken] -> Html
+body = Html.body . Html.pre . mconcat . map richToken
 
 header :: Maybe FilePath -> Html
 header Nothing = Html.noHtml
@@ -23,6 +27,10 @@ header (Just css) =
         , Html.thetype "text/css"
         ]
 
+richToken :: RichToken -> Html
+richToken (RichToken t Nothing) = token t
+richToken (RichToken t (Just name)) = Html.anchor (token t) ! nameAttrs name
+
 token :: Token -> Html
 token (Token t v _) = Html.thespan (Html.toHtml v) ! tokenAttrs t
 
@@ -40,3 +48,12 @@ tokenAttrs TkComment = [Html.theclass "hs-comment"]
 tokenAttrs TkCpp = [Html.theclass "hs-cpp"]
 tokenAttrs TkPragma = [Html.theclass "hs-pragma"]
 tokenAttrs TkUnknown = []
+
+nameAttrs :: GHC.Name -> [HtmlAttr]
+nameAttrs name =
+    [ Html.href (maybe "" id mmod ++ "#" ++ ident)
+    , Html.theclass "varid-reference"
+    ]
+  where
+    mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name
+    ident = GHC.occNameString . GHC.nameOccName $ name
-- 
cgit v1.2.3


From 7d43b8a8c9538692beb91a4c3a485e82b40559ab Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 6 Jun 2015 22:37:28 +0200
Subject: Fix span matcher bug causing wrong items being hyperlinked.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 031ddd5c..7d88b7fb 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -48,5 +48,5 @@ matches tspan (GHC.RealSrcSpan aspan)
     rs = (posRow . spStart) tspan == GHC.srcSpanStartLine aspan
     cs = (posCol . spStart) tspan == GHC.srcSpanStartCol aspan
     re = (posRow . spEnd) tspan == GHC.srcSpanEndLine aspan
-    ce = (posCol . spEnd) tspan == GHC.srcSpanStartLine aspan
+    ce = (posCol . spEnd) tspan == GHC.srcSpanEndCol aspan
 matches _ _ = False
-- 
cgit v1.2.3


From 9a51a6d3f686736354e26137363ea979a5e38076 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 6 Jun 2015 23:40:36 +0200
Subject: Constrain elements exported by hyperlinker modules.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs      | 5 ++++-
 haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 2 +-
 2 files changed, 5 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 7d88b7fb..a24945ea 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -1,6 +1,9 @@
 {-# LANGUAGE RankNTypes #-}
 
-module Haddock.Backends.Hyperlinker.Ast where
+module Haddock.Backends.Hyperlinker.Ast
+    ( enrich
+    , RichToken(..)
+    ) where
 
 import Haddock.Backends.Hyperlinker.Parser
 
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 32d2c863..3c6fe14f 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,4 +1,4 @@
-module Haddock.Backends.Hyperlinker.Renderer where
+module Haddock.Backends.Hyperlinker.Renderer (render) where
 
 import Haddock.Backends.Hyperlinker.Parser
 import Haddock.Backends.Hyperlinker.Ast
-- 
cgit v1.2.3


From 666af8d2f29c05d22bb5930d115c42509528bb90 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 7 Jun 2015 21:35:55 +0200
Subject: Add support for type token recognition.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 35 +++++++++---
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 64 ++++++++++++++--------
 2 files changed, 68 insertions(+), 31 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index a24945ea..0ccf010b 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -2,7 +2,7 @@
 
 module Haddock.Backends.Hyperlinker.Ast
     ( enrich
-    , RichToken(..)
+    , RichToken(..), RichTokenType(..), TokenDetails(..)
     ) where
 
 import Haddock.Backends.Hyperlinker.Parser
@@ -15,33 +15,52 @@ import Data.Maybe
 
 data RichToken = RichToken
     { rtkToken :: Token
-    , rtkName :: Maybe GHC.Name
+    , rtkDetails :: Maybe TokenDetails
     }
 
+data TokenDetails = TokenDetails
+    { rtkType :: RichTokenType
+    , rtkName :: GHC.Name
+    }
+
+data RichTokenType
+    = RtkVar
+    | RtkType
+
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
     map $ \token -> RichToken
         { rtkToken = token
-        , rtkName = lookupBySpan (tkSpan token) nameMap
+        , rtkDetails = lookupBySpan (tkSpan token) detailsMap
         }
   where
-    nameMap = variables src
+    detailsMap = variables src ++ types src
 
-type NameMap = [(GHC.SrcSpan, GHC.Name)]
+type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
 
-lookupBySpan :: Span -> NameMap -> Maybe GHC.Name
+lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
 lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)
 
 everything :: (r -> r -> r) -> (forall a. Data a => a -> r)
            -> (forall a. Data a => a -> r)
 everything k f x = foldl k (f x) (gmapQ (everything k f) x)
 
-variables :: GHC.RenamedSource -> NameMap
+variables :: GHC.RenamedSource -> DetailsMap
 variables =
     everything (<|>) var
   where
     var term = case cast term of
-        (Just (GHC.L sspan (GHC.HsVar sid))) -> pure (sspan, sid)
+        (Just (GHC.L sspan (GHC.HsVar name))) ->
+            pure (sspan, TokenDetails RtkVar name)
+        _ -> empty
+
+types :: GHC.RenamedSource -> DetailsMap
+types =
+    everything (<|>) ty
+  where
+    ty term = case cast term of
+        (Just (GHC.L sspan (GHC.HsTyVar name))) ->
+            pure (sspan, TokenDetails RtkType name)
         _ -> empty
 
 matches :: Span -> GHC.SrcSpan -> Bool
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 3c6fe14f..c2bca438 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -6,10 +6,14 @@ import Haddock.Backends.Hyperlinker.Ast
 import qualified GHC
 import qualified Name as GHC
 
+import Data.List
 import Data.Monoid
+
 import Text.XHtml (Html, HtmlAttr, (!))
 import qualified Text.XHtml as Html
 
+type StyleClass = String
+
 render :: Maybe FilePath -> [RichToken] -> Html
 render css tokens = header css <> body tokens
 
@@ -28,29 +32,43 @@ header (Just css) =
         ]
 
 richToken :: RichToken -> Html
-richToken (RichToken t Nothing) = token t
-richToken (RichToken t (Just name)) = Html.anchor (token t) ! nameAttrs name
-
-token :: Token -> Html
-token (Token t v _) = Html.thespan (Html.toHtml v) ! tokenAttrs t
-
-tokenAttrs :: TokenType -> [HtmlAttr]
-tokenAttrs TkIdentifier = [Html.theclass "hs-identifier"]
-tokenAttrs TkKeyword = [Html.theclass "hs-keyword"]
-tokenAttrs TkString = [Html.theclass "hs-string"]
-tokenAttrs TkChar = [Html.theclass "hs-char"]
-tokenAttrs TkNumber = [Html.theclass "hs-number"]
-tokenAttrs TkOperator = [Html.theclass "hs-operator"]
-tokenAttrs TkGlyph = [Html.theclass "hs-glyph"]
-tokenAttrs TkSpecial = [Html.theclass "hs-special"]
-tokenAttrs TkSpace = []
-tokenAttrs TkComment = [Html.theclass "hs-comment"]
-tokenAttrs TkCpp = [Html.theclass "hs-cpp"]
-tokenAttrs TkPragma = [Html.theclass "hs-pragma"]
-tokenAttrs TkUnknown = []
-
-nameAttrs :: GHC.Name -> [HtmlAttr]
-nameAttrs name =
+richToken (RichToken tok Nothing) =
+    tokenSpan tok ! attrs
+  where
+    attrs = [ multiclass . tokenStyle . tkType $ tok ]
+richToken (RichToken tok (Just det)) =
+    Html.anchor content ! (anchorAttrs . rtkName) det
+  where
+    content = tokenSpan tok ! [ multiclass style]
+    style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det
+
+tokenSpan :: Token -> Html
+tokenSpan = Html.thespan . Html.toHtml . tkValue
+
+richTokenStyle :: RichTokenType -> [StyleClass]
+richTokenStyle RtkVar = ["hs-var"]
+richTokenStyle RtkType = ["hs-type"]
+
+tokenStyle :: TokenType -> [StyleClass]
+tokenStyle TkIdentifier = ["hs-identifier"]
+tokenStyle TkKeyword = ["hs-keyword"]
+tokenStyle TkString = ["hs-string"]
+tokenStyle TkChar = ["hs-char"]
+tokenStyle TkNumber = ["hs-number"]
+tokenStyle TkOperator = ["hs-operator"]
+tokenStyle TkGlyph = ["hs-glyph"]
+tokenStyle TkSpecial = ["hs-special"]
+tokenStyle TkSpace = []
+tokenStyle TkComment = ["hs-comment"]
+tokenStyle TkCpp = ["hs-cpp"]
+tokenStyle TkPragma = ["hs-pragma"]
+tokenStyle TkUnknown = []
+
+multiclass :: [StyleClass] -> HtmlAttr
+multiclass = Html.theclass . intercalate " "
+
+anchorAttrs :: GHC.Name -> [HtmlAttr]
+anchorAttrs name =
     [ Html.href (maybe "" id mmod ++ "#" ++ ident)
     , Html.theclass "varid-reference"
     ]
-- 
cgit v1.2.3


From 70656933ca6935bde0a00310f37440e02c3f21ff Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 8 Jun 2015 00:13:12 +0200
Subject: Add support for binding token recognition.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs  | 20 +++++++++++++++++++-
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs     |  1 +
 2 files changed, 20 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 0ccf010b..19ebbe77 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Haddock.Backends.Hyperlinker.Ast
     ( enrich
@@ -26,6 +27,7 @@ data TokenDetails = TokenDetails
 data RichTokenType
     = RtkVar
     | RtkType
+    | RtkBind
 
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
@@ -34,7 +36,7 @@ enrich src =
         , rtkDetails = lookupBySpan (tkSpan token) detailsMap
         }
   where
-    detailsMap = variables src ++ types src
+    detailsMap = variables src ++ types src ++ binds src
 
 type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
 
@@ -45,6 +47,9 @@ everything :: (r -> r -> r) -> (forall a. Data a => a -> r)
            -> (forall a. Data a => a -> r)
 everything k f x = foldl k (f x) (gmapQ (everything k f) x)
 
+combine :: Alternative f => (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r)
+combine f g x = f x <|> g x
+
 variables :: GHC.RenamedSource -> DetailsMap
 variables =
     everything (<|>) var
@@ -63,6 +68,19 @@ types =
             pure (sspan, TokenDetails RtkType name)
         _ -> empty
 
+binds :: GHC.RenamedSource -> DetailsMap
+binds =
+    everything (<|>) (fun `combine` pat)
+  where
+    fun term = case cast term of
+        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) ->
+            pure (sspan, TokenDetails RtkBind name)
+        _ -> empty
+    pat term = case cast term of
+        (Just (GHC.L sspan (GHC.VarPat name))) ->
+            pure (sspan, TokenDetails RtkBind name)
+        _ -> empty
+
 matches :: Span -> GHC.SrcSpan -> Bool
 matches tspan (GHC.RealSrcSpan aspan)
     | rs && cs && re && ce = True
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index c2bca438..57851c22 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -48,6 +48,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue
 richTokenStyle :: RichTokenType -> [StyleClass]
 richTokenStyle RtkVar = ["hs-var"]
 richTokenStyle RtkType = ["hs-type"]
+richTokenStyle RtkBind = ["hs-bind"]
 
 tokenStyle :: TokenType -> [StyleClass]
 tokenStyle TkIdentifier = ["hs-identifier"]
-- 
cgit v1.2.3


From 21984e4cfcc076ce8cbee934028a1b37aaca930b Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 8 Jun 2015 00:54:58 +0200
Subject: Implement go-to-definition mechanism for local bindings.

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

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 57851c22..995e24e6 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -5,6 +5,7 @@ import Haddock.Backends.Hyperlinker.Ast
 
 import qualified GHC
 import qualified Name as GHC
+import qualified Unique as GHC
 
 import Data.List
 import Data.Monoid
@@ -37,7 +38,7 @@ richToken (RichToken tok Nothing) =
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
 richToken (RichToken tok (Just det)) =
-    Html.anchor content ! (anchorAttrs . rtkName) det
+    internalAnchor det . hyperlink det $ content
   where
     content = tokenSpan tok ! [ multiclass style]
     style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det
@@ -48,7 +49,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue
 richTokenStyle :: RichTokenType -> [StyleClass]
 richTokenStyle RtkVar = ["hs-var"]
 richTokenStyle RtkType = ["hs-type"]
-richTokenStyle RtkBind = ["hs-bind"]
+richTokenStyle RtkBind = []
 
 tokenStyle :: TokenType -> [StyleClass]
 tokenStyle TkIdentifier = ["hs-identifier"]
@@ -68,11 +69,26 @@ tokenStyle TkUnknown = []
 multiclass :: [StyleClass] -> HtmlAttr
 multiclass = Html.theclass . intercalate " "
 
-anchorAttrs :: GHC.Name -> [HtmlAttr]
-anchorAttrs name =
-    [ Html.href (maybe "" id mmod ++ "#" ++ ident)
-    , Html.theclass "varid-reference"
-    ]
+internalAnchor :: TokenDetails -> Html -> Html
+internalAnchor (TokenDetails RtkBind name) content =
+    Html.anchor content ! [ Html.name $ internalAnchorIdent name ]
+internalAnchor _ content = content
+
+internalAnchorIdent :: GHC.Name -> String
+internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
+
+hyperlink :: TokenDetails -> Html -> Html
+hyperlink (TokenDetails _ name) = if GHC.isInternalName name
+    then internalHyperlink name
+    else externalHyperlink name
+
+internalHyperlink :: GHC.Name -> Html -> Html
+internalHyperlink name content =
+    Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
+
+externalHyperlink :: GHC.Name -> Html -> Html
+externalHyperlink name content =
+    Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ]
   where
     mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name
     ident = GHC.occNameString . GHC.nameOccName $ name
-- 
cgit v1.2.3


From c84a3ef8ebca5fb396ee9dc8cb2654f7891f5c0e Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 8 Jun 2015 14:12:58 +0200
Subject: Implement module export- and import-list item hyperlinking.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 20 +++++++++++++++++++-
 1 file changed, 19 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 19ebbe77..2325aa21 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -36,7 +36,12 @@ enrich src =
         , rtkDetails = lookupBySpan (tkSpan token) detailsMap
         }
   where
-    detailsMap = variables src ++ types src ++ binds src
+    detailsMap = concat
+        [ variables src
+        , types src
+        , binds src
+        , imports src
+        ]
 
 type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
 
@@ -81,6 +86,19 @@ binds =
             pure (sspan, TokenDetails RtkBind name)
         _ -> empty
 
+imports :: GHC.RenamedSource -> DetailsMap
+imports =
+    everything (<|>) ie
+  where
+    ie term = case cast term of
+        (Just (GHC.IEVar v)) -> pure $ var v
+        (Just (GHC.IEThingAbs t)) -> pure $ typ t
+        (Just (GHC.IEThingAll t)) -> pure $ typ t
+        (Just (GHC.IEThingWith t vs)) -> [typ t] ++ map var vs
+        _ -> empty
+    typ (GHC.L sspan name) = (sspan, TokenDetails RtkType name)
+    var (GHC.L sspan name) = (sspan, TokenDetails RtkVar name)
+
 matches :: Span -> GHC.SrcSpan -> Bool
 matches tspan (GHC.RealSrcSpan aspan)
     | rs && cs && re && ce = True
-- 
cgit v1.2.3


From fab61bb80c2d8059e91aece7677cf349cd34a8db Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 8 Jun 2015 15:05:35 +0200
Subject: Fix span matching to allow parenthesized operators hyperlinking.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 2325aa21..05d6a52e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -101,10 +101,10 @@ imports =
 
 matches :: Span -> GHC.SrcSpan -> Bool
 matches tspan (GHC.RealSrcSpan aspan)
-    | rs && cs && re && ce = True
+    | saspan <= stspan && etspan <= easpan = True
   where
-    rs = (posRow . spStart) tspan == GHC.srcSpanStartLine aspan
-    cs = (posCol . spStart) tspan == GHC.srcSpanStartCol aspan
-    re = (posRow . spEnd) tspan == GHC.srcSpanEndLine aspan
-    ce = (posCol . spEnd) tspan == GHC.srcSpanEndCol aspan
+    stspan = (posRow . spStart $ tspan, posCol . spStart $ tspan)
+    etspan = (posRow . spEnd $ tspan, posCol . spEnd $ tspan)
+    saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan)
+    easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan)
 matches _ _ = False
-- 
cgit v1.2.3


From b31513dbacb48102b4c5d2fd6de1982161d81fae Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 8 Jun 2015 15:16:06 +0200
Subject: Fix weird hyperlinking of parenthesized operators.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs    | 7 ++++++-
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 +
 2 files changed, 7 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 05d6a52e..2749096e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -33,7 +33,7 @@ enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
     map $ \token -> RichToken
         { rtkToken = token
-        , rtkDetails = lookupBySpan (tkSpan token) detailsMap
+        , rtkDetails = enrichToken token detailsMap
         }
   where
     detailsMap = concat
@@ -45,6 +45,11 @@ enrich src =
 
 type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
 
+enrichToken :: Token -> DetailsMap -> Maybe TokenDetails
+enrichToken (Token typ _ spn) dm
+    | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm
+enrichToken _ _ = Nothing
+
 lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
 lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)
 
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 0e1ad5b2..70a69279 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -37,6 +37,7 @@ data TokenType
     | TkCpp
     | TkPragma
     | TkUnknown
+    deriving (Eq)
 
 parse :: String -> [Token]
 parse = tokenize . tag . chunk
-- 
cgit v1.2.3


From 162b02ed6f50709ea203bf7706eee5804e455419 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 12 Jun 2015 01:03:13 +0200
Subject: Add support for type declaration anchors.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 21 ++++++++++++++++-----
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs    | 14 +++++++++++---
 2 files changed, 27 insertions(+), 8 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 2749096e..39bbacf5 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -28,6 +28,7 @@ data RichTokenType
     = RtkVar
     | RtkType
     | RtkBind
+    | RtkDecl
 
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
@@ -36,11 +37,12 @@ enrich src =
         , rtkDetails = enrichToken token detailsMap
         }
   where
-    detailsMap = concat
-        [ variables src
-        , types src
-        , binds src
-        , imports src
+    detailsMap = concatMap ($ src)
+        [ variables
+        , types
+        , binds
+        , imports
+        , decls
         ]
 
 type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
@@ -91,6 +93,15 @@ binds =
             pure (sspan, TokenDetails RtkBind name)
         _ -> empty
 
+decls :: GHC.RenamedSource -> DetailsMap
+decls (group, _, _, _) = concatMap ($ group)
+    [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
+    ]
+  where
+    typ (GHC.L _ t) =
+        let (GHC.L sspan name) = GHC.tcdLName t
+        in (sspan, TokenDetails RtkDecl name)
+
 imports :: GHC.RenamedSource -> DetailsMap
 imports =
     everything (<|>) ie
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 995e24e6..b7cc5aeb 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -38,7 +38,7 @@ richToken (RichToken tok Nothing) =
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
 richToken (RichToken tok (Just det)) =
-    internalAnchor det . hyperlink det $ content
+    externalAnchor det . internalAnchor det . hyperlink det $ content
   where
     content = tokenSpan tok ! [ multiclass style]
     style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det
@@ -49,7 +49,7 @@ tokenSpan = Html.thespan . Html.toHtml . tkValue
 richTokenStyle :: RichTokenType -> [StyleClass]
 richTokenStyle RtkVar = ["hs-var"]
 richTokenStyle RtkType = ["hs-type"]
-richTokenStyle RtkBind = []
+richTokenStyle _ = []
 
 tokenStyle :: TokenType -> [StyleClass]
 tokenStyle TkIdentifier = ["hs-identifier"]
@@ -69,11 +69,19 @@ tokenStyle TkUnknown = []
 multiclass :: [StyleClass] -> HtmlAttr
 multiclass = Html.theclass . intercalate " "
 
+externalAnchor :: TokenDetails -> Html -> Html
+externalAnchor (TokenDetails RtkDecl name) content =
+    Html.anchor content ! [ Html.name $ externalAnchorIdent name ]
+externalAnchor _ content = content
+
 internalAnchor :: TokenDetails -> Html -> Html
 internalAnchor (TokenDetails RtkBind name) content =
     Html.anchor content ! [ Html.name $ internalAnchorIdent name ]
 internalAnchor _ content = content
 
+externalAnchorIdent :: GHC.Name -> String
+externalAnchorIdent = GHC.occNameString . GHC.nameOccName
+
 internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
@@ -91,4 +99,4 @@ externalHyperlink name content =
     Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ]
   where
     mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name
-    ident = GHC.occNameString . GHC.nameOccName $ name
+    ident = externalAnchorIdent name
-- 
cgit v1.2.3


From c6786894f71809ecfa377a44beab0771a3bc7985 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 12 Jun 2015 01:36:49 +0200
Subject: Add support for top-level function declaration anchors.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 39bbacf5..cb9508ef 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -40,9 +40,9 @@ enrich src =
     detailsMap = concatMap ($ src)
         [ variables
         , types
+        , decls
         , binds
         , imports
-        , decls
         ]
 
 type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
@@ -96,11 +96,16 @@ binds =
 decls :: GHC.RenamedSource -> DetailsMap
 decls (group, _, _, _) = concatMap ($ group)
     [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
+    , everything (<|>) fun
     ]
   where
     typ (GHC.L _ t) =
         let (GHC.L sspan name) = GHC.tcdLName t
         in (sspan, TokenDetails RtkDecl name)
+    fun term = case cast term of
+        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
+            | GHC.isExternalName name -> pure (sspan, TokenDetails RtkDecl name)
+        _ -> empty
 
 imports :: GHC.RenamedSource -> DetailsMap
 imports =
-- 
cgit v1.2.3


From 1064953c6590c05303c6cbd2230b9e13d3ba1376 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 12 Jun 2015 10:57:30 +0200
Subject: Fix external anchors to contain HTML file extension.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index b7cc5aeb..99a0f337 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -96,7 +96,7 @@ internalHyperlink name content =
 
 externalHyperlink :: GHC.Name -> Html -> Html
 externalHyperlink name content =
-    Html.anchor content ! [ Html.href $ maybe "" id mmod ++ "#" ++ ident ]
+    Html.anchor content ! [ Html.href $ maybe "" id mmod ++ ".html#" ++ ident ]
   where
     mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name
     ident = externalAnchorIdent name
-- 
cgit v1.2.3


From 60db14903e01f4c26f179230c7b6190a7b99fb51 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 17 Jun 2015 21:49:46 +0200
Subject: Refactor the way AST names are handled within detailed tokens.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 37 +++++++++++-----------
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 17 ++++++----
 2 files changed, 29 insertions(+), 25 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index cb9508ef..3c07ff3c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -3,7 +3,7 @@
 
 module Haddock.Backends.Hyperlinker.Ast
     ( enrich
-    , RichToken(..), RichTokenType(..), TokenDetails(..)
+    , RichToken(..), TokenDetails(..), rtkName
     ) where
 
 import Haddock.Backends.Hyperlinker.Parser
@@ -19,16 +19,17 @@ data RichToken = RichToken
     , rtkDetails :: Maybe TokenDetails
     }
 
-data TokenDetails = TokenDetails
-    { rtkType :: RichTokenType
-    , rtkName :: GHC.Name
-    }
+data TokenDetails
+    = RtkVar GHC.Name
+    | RtkType GHC.Name
+    | RtkBind GHC.Name
+    | RtkDecl GHC.Name
 
-data RichTokenType
-    = RtkVar
-    | RtkType
-    | RtkBind
-    | RtkDecl
+rtkName :: TokenDetails -> GHC.Name
+rtkName (RtkVar name) = name
+rtkName (RtkType name) = name
+rtkName (RtkBind name) = name
+rtkName (RtkDecl name) = name
 
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
@@ -68,7 +69,7 @@ variables =
   where
     var term = case cast term of
         (Just (GHC.L sspan (GHC.HsVar name))) ->
-            pure (sspan, TokenDetails RtkVar name)
+            pure (sspan, RtkVar name)
         _ -> empty
 
 types :: GHC.RenamedSource -> DetailsMap
@@ -77,7 +78,7 @@ types =
   where
     ty term = case cast term of
         (Just (GHC.L sspan (GHC.HsTyVar name))) ->
-            pure (sspan, TokenDetails RtkType name)
+            pure (sspan, RtkType name)
         _ -> empty
 
 binds :: GHC.RenamedSource -> DetailsMap
@@ -86,11 +87,11 @@ binds =
   where
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) ->
-            pure (sspan, TokenDetails RtkBind name)
+            pure (sspan, RtkBind name)
         _ -> empty
     pat term = case cast term of
         (Just (GHC.L sspan (GHC.VarPat name))) ->
-            pure (sspan, TokenDetails RtkBind name)
+            pure (sspan, RtkBind name)
         _ -> empty
 
 decls :: GHC.RenamedSource -> DetailsMap
@@ -101,10 +102,10 @@ decls (group, _, _, _) = concatMap ($ group)
   where
     typ (GHC.L _ t) =
         let (GHC.L sspan name) = GHC.tcdLName t
-        in (sspan, TokenDetails RtkDecl name)
+        in (sspan, RtkDecl name)
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
-            | GHC.isExternalName name -> pure (sspan, TokenDetails RtkDecl name)
+            | GHC.isExternalName name -> pure (sspan, RtkDecl name)
         _ -> empty
 
 imports :: GHC.RenamedSource -> DetailsMap
@@ -117,8 +118,8 @@ imports =
         (Just (GHC.IEThingAll t)) -> pure $ typ t
         (Just (GHC.IEThingWith t vs)) -> [typ t] ++ map var vs
         _ -> empty
-    typ (GHC.L sspan name) = (sspan, TokenDetails RtkType name)
-    var (GHC.L sspan name) = (sspan, TokenDetails RtkVar name)
+    typ (GHC.L sspan name) = (sspan, RtkType name)
+    var (GHC.L sspan name) = (sspan, RtkVar name)
 
 matches :: Span -> GHC.SrcSpan -> Bool
 matches tspan (GHC.RealSrcSpan aspan)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 99a0f337..e08d8974 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -41,14 +41,14 @@ richToken (RichToken tok (Just det)) =
     externalAnchor det . internalAnchor det . hyperlink det $ content
   where
     content = tokenSpan tok ! [ multiclass style]
-    style = (tokenStyle . tkType) tok ++ (richTokenStyle . rtkType) det
+    style = (tokenStyle . tkType) tok ++ richTokenStyle det
 
 tokenSpan :: Token -> Html
 tokenSpan = Html.thespan . Html.toHtml . tkValue
 
-richTokenStyle :: RichTokenType -> [StyleClass]
-richTokenStyle RtkVar = ["hs-var"]
-richTokenStyle RtkType = ["hs-type"]
+richTokenStyle :: TokenDetails -> [StyleClass]
+richTokenStyle (RtkVar _) = ["hs-var"]
+richTokenStyle (RtkType _) = ["hs-type"]
 richTokenStyle _ = []
 
 tokenStyle :: TokenType -> [StyleClass]
@@ -70,12 +70,12 @@ multiclass :: [StyleClass] -> HtmlAttr
 multiclass = Html.theclass . intercalate " "
 
 externalAnchor :: TokenDetails -> Html -> Html
-externalAnchor (TokenDetails RtkDecl name) content =
+externalAnchor (RtkDecl name) content =
     Html.anchor content ! [ Html.name $ externalAnchorIdent name ]
 externalAnchor _ content = content
 
 internalAnchor :: TokenDetails -> Html -> Html
-internalAnchor (TokenDetails RtkBind name) content =
+internalAnchor (RtkBind name) content =
     Html.anchor content ! [ Html.name $ internalAnchorIdent name ]
 internalAnchor _ content = content
 
@@ -86,9 +86,12 @@ internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
 hyperlink :: TokenDetails -> Html -> Html
-hyperlink (TokenDetails _ name) = if GHC.isInternalName name
+hyperlink details =
+    if GHC.isInternalName $ name
     then internalHyperlink name
     else externalHyperlink name
+  where
+    name = rtkName details
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
-- 
cgit v1.2.3


From a85224a68b51b70035446ad8e5565d571c4a10d4 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 17 Jun 2015 22:22:49 +0200
Subject: Implement hyperlinking of imported module names.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 19 +++++++++------
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 28 +++++++++++++---------
 2 files changed, 29 insertions(+), 18 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 3c07ff3c..10389958 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -24,12 +24,14 @@ data TokenDetails
     | RtkType GHC.Name
     | RtkBind GHC.Name
     | RtkDecl GHC.Name
+    | RtkModule GHC.ModuleName
 
-rtkName :: TokenDetails -> GHC.Name
-rtkName (RtkVar name) = name
-rtkName (RtkType name) = name
-rtkName (RtkBind name) = name
-rtkName (RtkDecl name) = name
+rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName
+rtkName (RtkVar name) = Left name
+rtkName (RtkType name) = Left name
+rtkName (RtkBind name) = Left name
+rtkName (RtkDecl name) = Left name
+rtkName (RtkModule name) = Right name
 
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
@@ -109,8 +111,8 @@ decls (group, _, _, _) = concatMap ($ group)
         _ -> empty
 
 imports :: GHC.RenamedSource -> DetailsMap
-imports =
-    everything (<|>) ie
+imports src@(_, imps, _, _) =
+    everything (<|>) ie src ++ map (imp . GHC.unLoc) imps
   where
     ie term = case cast term of
         (Just (GHC.IEVar v)) -> pure $ var v
@@ -120,6 +122,9 @@ imports =
         _ -> empty
     typ (GHC.L sspan name) = (sspan, RtkType name)
     var (GHC.L sspan name) = (sspan, RtkVar name)
+    imp idecl =
+        let (GHC.L sspan name) = GHC.ideclName idecl
+        in (sspan, RtkModule name)
 
 matches :: Span -> GHC.SrcSpan -> Bool
 matches tspan (GHC.RealSrcSpan aspan)
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index e08d8974..70524759 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -8,6 +8,7 @@ import qualified Name as GHC
 import qualified Unique as GHC
 
 import Data.List
+import Data.Maybe
 import Data.Monoid
 
 import Text.XHtml (Html, HtmlAttr, (!))
@@ -86,20 +87,25 @@ internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
 hyperlink :: TokenDetails -> Html -> Html
-hyperlink details =
-    if GHC.isInternalName $ name
-    then internalHyperlink name
-    else externalHyperlink name
-  where
-    name = rtkName details
+hyperlink details = case rtkName details of
+    Left name ->
+        if GHC.isInternalName name
+        then internalHyperlink name
+        else externalHyperlink mname (Just name)
+      where
+        mname = GHC.moduleName <$> GHC.nameModule_maybe name
+    Right name -> externalHyperlink (Just name) Nothing
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
     Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
 
-externalHyperlink :: GHC.Name -> Html -> Html
-externalHyperlink name content =
-    Html.anchor content ! [ Html.href $ maybe "" id mmod ++ ".html#" ++ ident ]
+externalHyperlink :: Maybe GHC.ModuleName -> Maybe GHC.Name -> Html -> Html
+externalHyperlink mmname miname content =
+    Html.anchor content ! [ Html.href $ path ++ anchor ]
   where
-    mmod = GHC.moduleNameString . GHC.moduleName <$> GHC.nameModule_maybe name
-    ident = externalAnchorIdent name
+    path = fromMaybe "" $ modulePath <$> mmname
+    anchor = fromMaybe "" $ ("#" ++) . externalAnchorIdent <$> miname
+
+modulePath :: GHC.ModuleName -> String
+modulePath name = GHC.moduleNameString name ++ ".html"
-- 
cgit v1.2.3


From ebd60c5cd0c3642c2d5542c0e126be0a4ec111d9 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 17 Jun 2015 23:43:31 +0200
Subject: Fix parsing of single line comments with broken up newlines.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 12 +++++++++++-
 1 file changed, 11 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 70a69279..3ecfc7e7 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -47,13 +47,23 @@ chunk [] = []
 chunk str@(c:_)
     | isSpace c = chunk' $ span isSpace str
 chunk str
-    | "--" `isPrefixOf` str = chunk' $ span (not . (== '\n')) str
+    | "--" `isPrefixOf` str = chunk' $ spanToNewline str
     | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str
     | otherwise = chunk' $ head $ lex str
 
 chunk' :: (String, String) -> [String]
 chunk' (c, rest) = c:(chunk rest)
 
+spanToNewline :: String -> (String, String)
+spanToNewline [] = ([], [])
+spanToNewline ('\\':'\n':str) =
+    let (str', rest) = spanToNewline str
+    in ('\\':'\n':str', rest)
+spanToNewline ('\n':str) = ("\n", str)
+spanToNewline (c:str) =
+    let (str', rest) = spanToNewline str
+    in (c:str', rest)
+
 chunkComment :: Int -> String -> (String, String)
 chunkComment _ [] = ("", "")
 chunkComment depth ('{':'-':str) =
-- 
cgit v1.2.3


From a7888aefa4011d919b887ff31fcf8651af5632be Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 18 Jun 2015 00:25:56 +0200
Subject: Fix bug with improper newline handling.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 3ecfc7e7..bfee4a7f 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -59,7 +59,7 @@ spanToNewline [] = ([], [])
 spanToNewline ('\\':'\n':str) =
     let (str', rest) = spanToNewline str
     in ('\\':'\n':str', rest)
-spanToNewline ('\n':str) = ("\n", str)
+spanToNewline str@('\n':_) = ("", str)
 spanToNewline (c:str) =
     let (str', rest) = spanToNewline str
     in (c:str', rest)
-- 
cgit v1.2.3


From 45cc27fe79492a7b921574796a7ea8fdac4c5af2 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 18 Jun 2015 14:29:59 +0200
Subject: Fix issues with escaped newlines in comments.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 13 +++++--------
 1 file changed, 5 insertions(+), 8 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index bfee4a7f..fa5a58b3 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -82,14 +82,11 @@ tag :: [String] -> [(Span, String)]
 tag =
     reverse . snd . foldl aux (Position 1 1, [])
   where
-    aux (pos, cs) c =
-        let pos' = move pos c
-        in (pos', ((Span pos pos', c):cs))
-    move pos str@(c:_)
-        | isSpace c = foldl move' pos str
-    move pos str = pos { posCol = posCol pos + length str }
-    move' pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 }
-    move' pos _ = pos { posCol = posCol pos + 1 }
+    aux (pos, cs) str =
+        let pos' = foldl move pos str
+        in (pos', (Span pos pos', str):cs)
+    move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 }
+    move pos _ = pos { posCol = posCol pos + 1 }
 
 tokenize :: [(Span, String)] -> [Token]
 tokenize =
-- 
cgit v1.2.3


From 61942ce564edcb3c0a64051042c8ed850f2090bd Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 18 Jun 2015 15:19:59 +0200
Subject: Add support for parsing C preprocessor macros.

---
 .../src/Haddock/Backends/Hyperlinker/Parser.hs       | 20 ++++++++++++++++----
 1 file changed, 16 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index fa5a58b3..7f408165 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -6,6 +6,7 @@ module Haddock.Backends.Hyperlinker.Parser
 
 import Data.Char
 import Data.List
+import Data.Maybe
 
 data Token = Token
     { tkType :: TokenType
@@ -45,14 +46,15 @@ parse = tokenize . tag . chunk
 chunk :: String -> [String]
 chunk [] = []
 chunk str@(c:_)
-    | isSpace c = chunk' $ span isSpace str
+    | isSpace c =
+        let (space, mcpp, rest) = spanSpaceOrCpp str
+        in [space] ++ maybeToList mcpp ++ chunk rest
 chunk str
     | "--" `isPrefixOf` str = chunk' $ spanToNewline str
     | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str
     | otherwise = chunk' $ head $ lex str
-
-chunk' :: (String, String) -> [String]
-chunk' (c, rest) = c:(chunk rest)
+  where
+    chunk' (c, rest) = c:(chunk rest)
 
 spanToNewline :: String -> (String, String)
 spanToNewline [] = ([], [])
@@ -64,6 +66,16 @@ spanToNewline (c:str) =
     let (str', rest) = spanToNewline str
     in (c:str', rest)
 
+spanSpaceOrCpp :: String -> (String, Maybe String, String)
+spanSpaceOrCpp ('\n':'#':str) =
+    let (str', rest) = spanToNewline str
+    in ("\n", Just $ '#':str', rest)
+spanSpaceOrCpp (c:str')
+    | isSpace c =
+        let (space, mcpp, rest) = spanSpaceOrCpp str'
+        in (c:space, mcpp, rest)
+spanSpaceOrCpp str = ("", Nothing, str)
+
 chunkComment :: Int -> String -> (String, String)
 chunkComment _ [] = ("", "")
 chunkComment depth ('{':'-':str) =
-- 
cgit v1.2.3


From 416c384a981593005c9c6bf87ac27b7c2f9b8695 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 21 Jun 2015 23:48:03 +0200
Subject: Add some documentation for parser module of source hyperlinker.

---
 .../src/Haddock/Backends/Hyperlinker/Parser.hs     | 39 ++++++++++++++++++++++
 1 file changed, 39 insertions(+)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 7f408165..6e195dba 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -40,9 +40,20 @@ data TokenType
     | TkUnknown
     deriving (Eq)
 
+-- | Turn source code string into a stream of more descriptive tokens.
+--
+-- Result should retain original file layout (including comments, whitespace,
+-- etc.), i.e. the following "law" should hold:
+--
+-- @concat . map 'tkValue' . 'parse' = id@
 parse :: String -> [Token]
 parse = tokenize . tag . chunk
 
+-- | Split raw source string to more meaningful chunks.
+--
+-- This is the initial stage of tokenization process. Each chunk is either
+-- a comment (including comment delimiters), a whitespace string, preprocessor
+-- macro (and all its content until the end of a line) or valid Haskell lexeme.
 chunk :: String -> [String]
 chunk [] = []
 chunk str@(c:_)
@@ -56,6 +67,11 @@ chunk str
   where
     chunk' (c, rest) = c:(chunk rest)
 
+-- | Split input to "first line" string and the rest of it.
+--
+-- Ideally, this should be done simply with @'break' (== '\n')@. However,
+-- Haskell also allows line-unbreaking (or whatever it is called) so things
+-- are not as simple and this function deals with that.
 spanToNewline :: String -> (String, String)
 spanToNewline [] = ([], [])
 spanToNewline ('\\':'\n':str) =
@@ -66,6 +82,16 @@ spanToNewline (c:str) =
     let (str', rest) = spanToNewline str
     in (c:str', rest)
 
+-- | Split input to whitespace string, (optional) preprocessor directive and
+-- the rest of it.
+--
+-- Again, using something like @'span' 'isSpace'@ would be nice to chunk input
+-- to whitespace. The problem is with /#/ symbol - if it is placed at the very
+-- beginning of a line, it should be recognized as preprocessor macro. In any
+-- other case, it is ordinary Haskell symbol and can be used to declare
+-- operators. Hence, while dealing with whitespace we also check whether there
+-- happens to be /#/ symbol just after a newline character - if that is the
+-- case, we begin treating the whole line as preprocessor macro.
 spanSpaceOrCpp :: String -> (String, Maybe String, String)
 spanSpaceOrCpp ('\n':'#':str) =
     let (str', rest) = spanToNewline str
@@ -76,6 +102,10 @@ spanSpaceOrCpp (c:str')
         in (c:space, mcpp, rest)
 spanSpaceOrCpp str = ("", Nothing, str)
 
+-- | Split input to comment content (including delimiters) and the rest.
+--
+-- Again, some more logic than simple 'span' is required because of Haskell
+-- comment nesting policy.
 chunkComment :: Int -> String -> (String, String)
 chunkComment _ [] = ("", "")
 chunkComment depth ('{':'-':str) =
@@ -90,6 +120,7 @@ chunkComment depth (e:str) =
     let (c, rest) = chunkComment depth str
     in (e:c, rest)
 
+-- | Assign source location for each chunk in given stream.
 tag :: [String] -> [(Span, String)]
 tag =
     reverse . snd . foldl aux (Position 1 1, [])
@@ -100,6 +131,7 @@ tag =
     move pos '\n' = pos { posRow = posRow pos + 1, posCol = 1 }
     move pos _ = pos { posCol = posCol pos + 1 }
 
+-- | Turn unrecognised chunk stream to more descriptive token stream.
 tokenize :: [(Span, String)] -> [Token]
 tokenize =
     map aux
@@ -110,6 +142,13 @@ tokenize =
         , tkSpan = sp
         }
 
+-- | Classify given string as appropriate Haskell token.
+--
+-- This method is based on Haskell 98 Report lexical structure description:
+-- https://www.haskell.org/onlinereport/lexemes.html
+--
+-- However, this is probably far from being perfect and most probably does not
+-- handle correctly all corner cases.
 classify :: String -> TokenType
 classify str
     | "--" `isPrefixOf` str = TkComment
-- 
cgit v1.2.3


From 937a6011d253a77cda98ec112a839cd08ac7e7ca Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 22 Jun 2015 00:20:44 +0200
Subject: Add some documentation for AST module of source hyperlinker.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 56 ++++++++++++++++++----
 1 file changed, 46 insertions(+), 10 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 10389958..275f10e9 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -33,6 +33,7 @@ rtkName (RtkBind name) = Left name
 rtkName (RtkDecl name) = Left name
 rtkName (RtkModule name) = Right name
 
+-- | Add more detailed information to token stream using GHC API.
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
 enrich src =
     map $ \token -> RichToken
@@ -48,23 +49,24 @@ enrich src =
         , imports
         ]
 
+-- | A map containing association between source locations and "details" of
+-- this location.
+--
+-- For the time being, it is just a list of pairs. However, looking up things
+-- in such structure has linear complexity. We cannot use any hashmap-like
+-- stuff because source locations are not ordered. In the future, this should
+-- be replaced with interval tree data structure.
 type DetailsMap = [(GHC.SrcSpan, TokenDetails)]
 
+lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
+lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)
+
 enrichToken :: Token -> DetailsMap -> Maybe TokenDetails
 enrichToken (Token typ _ spn) dm
     | typ `elem` [TkIdentifier, TkOperator] = lookupBySpan spn dm
 enrichToken _ _ = Nothing
 
-lookupBySpan :: Span -> DetailsMap -> Maybe TokenDetails
-lookupBySpan tspan = listToMaybe . map snd . filter (matches tspan . fst)
-
-everything :: (r -> r -> r) -> (forall a. Data a => a -> r)
-           -> (forall a. Data a => a -> r)
-everything k f x = foldl k (f x) (gmapQ (everything k f) x)
-
-combine :: Alternative f => (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r) -> (forall a. Data a => a -> f r)
-combine f g x = f x <|> g x
-
+-- | Obtain details map for variables ("normally" used identifiers).
 variables :: GHC.RenamedSource -> DetailsMap
 variables =
     everything (<|>) var
@@ -74,6 +76,7 @@ variables =
             pure (sspan, RtkVar name)
         _ -> empty
 
+-- | Obtain details map for types.
 types :: GHC.RenamedSource -> DetailsMap
 types =
     everything (<|>) ty
@@ -83,6 +86,11 @@ types =
             pure (sspan, RtkType name)
         _ -> empty
 
+-- | Obtain details map for identifier bindings.
+--
+-- That includes both identifiers bound by pattern matching or declared using
+-- ordinary assignment (in top-level declarations, let-expressions and where
+-- clauses).
 binds :: GHC.RenamedSource -> DetailsMap
 binds =
     everything (<|>) (fun `combine` pat)
@@ -96,6 +104,7 @@ binds =
             pure (sspan, RtkBind name)
         _ -> empty
 
+-- | Obtain details map for top-level declarations.
 decls :: GHC.RenamedSource -> DetailsMap
 decls (group, _, _, _) = concatMap ($ group)
     [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
@@ -110,6 +119,10 @@ decls (group, _, _, _) = concatMap ($ group)
             | GHC.isExternalName name -> pure (sspan, RtkDecl name)
         _ -> empty
 
+-- | Obtain details map for import declarations.
+--
+-- This map also includes type and variable details for items in export and
+-- import lists.
 imports :: GHC.RenamedSource -> DetailsMap
 imports src@(_, imps, _, _) =
     everything (<|>) ie src ++ map (imp . GHC.unLoc) imps
@@ -126,6 +139,15 @@ imports src@(_, imps, _, _) =
         let (GHC.L sspan name) = GHC.ideclName idecl
         in (sspan, RtkModule name)
 
+-- | Check whether token stream span matches GHC source span.
+--
+-- Currently, it is implemented as checking whether "our" span is contained
+-- in GHC span. The reason for that is because GHC span are generally wider
+-- and may spread across couple tokens. For example, @(>>=)@ consists of three
+-- tokens: @(@, @>>=@, @)@, but GHC source span associated with @>>=@ variable
+-- contains @(@ and @)@. Similarly, qualified identifiers like @Foo.Bar.quux@
+-- are tokenized as @Foo@, @.@, @Bar@, @.@, @quux@ but GHC source span
+-- associated with @quux@ contains all five elements.
 matches :: Span -> GHC.SrcSpan -> Bool
 matches tspan (GHC.RealSrcSpan aspan)
     | saspan <= stspan && etspan <= easpan = True
@@ -135,3 +157,17 @@ matches tspan (GHC.RealSrcSpan aspan)
     saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan)
     easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan)
 matches _ _ = False
+
+-- | Perform a query on each level of a tree.
+--
+-- This is stolen directly from SYB package and copied here to not introduce
+-- additional dependencies.
+everything :: (r -> r -> r) -> (forall a. Data a => a -> r)
+           -> (forall a. Data a => a -> r)
+everything k f x = foldl k (f x) (gmapQ (everything k f) x)
+
+-- | Combine two queries into one using alternative combinator.
+combine :: Alternative f => (forall a. Data a => a -> f r)
+                         -> (forall a. Data a => a -> f r)
+                         -> (forall a. Data a => a -> f r)
+combine f g x = f x <|> g x
-- 
cgit v1.2.3


From a6bd86a8550d5d7e8bdb12e1d09036b9f88eed73 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 22 Jun 2015 17:41:31 +0200
Subject: Add support for fancy highlighting upon hovering over identifier.

---
 haddock-api/haddock-api.cabal                      |  1 +
 haddock-api/resources/html/highlight.js            | 46 ++++++++++++++++++++++
 haddock-api/src/Haddock/Backends/Hyperlinker.hs    | 10 ++++-
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 23 +++++++----
 4 files changed, 70 insertions(+), 10 deletions(-)
 create mode 100644 haddock-api/resources/html/highlight.js

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 14656994..216627cc 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -21,6 +21,7 @@ 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
diff --git a/haddock-api/resources/html/highlight.js b/haddock-api/resources/html/highlight.js
new file mode 100644
index 00000000..639cf5d5
--- /dev/null
+++ b/haddock-api/resources/html/highlight.js
@@ -0,0 +1,46 @@
+
+var styleForRule = function (rule) {
+	var sheets = document.styleSheets;
+	for (var s = 0; s < sheets.length; s++) {
+		var rules = sheets[s].cssRules;
+		for (var r = 0; r < rules.length; r++) {
+			if (rules[r].selectorText == rule) {
+				return rules[r].style;
+			}
+		}
+	}
+};
+
+var highlight = function () {
+	var color = styleForRule("a:hover")["background-color"];
+	var links = document.getElementsByTagName('a');
+	for (var i = 0; i < links.length; i++) {
+		var that = links[i];
+		if (this.href == that.href) {
+			that.style["background-color"] = color;
+		}
+	}
+};
+
+/*
+ * I have no idea what is the proper antonym for "highlight" in this
+ * context. "Diminish"? "Unhighlight"? "Lowlight" sounds ridiculously
+ * so I like it.
+ */
+var lowlight = function () {
+	var links = document.getElementsByTagName('a');
+	for (var i = 0; i < links.length; i++) {
+		var that = links[i];
+		if (this.href == that.href) {
+			that.style["background-color"] = "";
+		}
+	}
+};
+
+window.onload = function () {
+	var links = document.getElementsByTagName('a');
+	for (var i = 0; i < links.length; i++) {
+		links[i].onmouseover = highlight;
+		links[i].onmouseout = lowlight;
+	}
+};
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 66392a67..9337307c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -16,14 +16,17 @@ ppHyperlinkedSource outdir libdir mstyle ifaces = do
     createDirectoryIfMissing True $ srcPath outdir
     let cssFile = fromMaybe (defaultCssFile libdir) mstyle
     copyFile cssFile $ srcPath outdir </> srcCssFile
+    copyFile (libdir </> "html" </> highlightScript) $
+        srcPath outdir </> highlightScript
     mapM_ (ppHyperlinkedModuleSource outdir) ifaces
 
 ppHyperlinkedModuleSource :: FilePath -> Interface -> IO ()
 ppHyperlinkedModuleSource outdir iface = case ifaceTokenizedSrc iface of
-    Just tokens -> writeFile path $ showHtml . render mSrcCssFile $ tokens
+    Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens
     Nothing -> return ()
   where
-    mSrcCssFile = Just $ srcCssFile
+    mCssFile = Just $ srcCssFile
+    mJsFile = Just $ highlightScript
     path = srcPath outdir </> moduleSourceFile (ifaceMod iface)
 
 moduleSourceFile :: Module -> FilePath
@@ -35,5 +38,8 @@ srcPath outdir = outdir </> "src"
 srcCssFile :: FilePath
 srcCssFile = "style.css"
 
+highlightScript :: FilePath
+highlightScript = "highlight.js"
+
 defaultCssFile :: FilePath -> FilePath
 defaultCssFile libdir = libdir </> "html" </> "solarized.css"
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 70524759..6d6d2012 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -16,21 +16,28 @@ import qualified Text.XHtml as Html
 
 type StyleClass = String
 
-render :: Maybe FilePath -> [RichToken] -> Html
-render css tokens = header css <> body tokens
+render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html
+render mcss mjs tokens = header mcss mjs <> body tokens
 
 body :: [RichToken] -> Html
 body = Html.body . Html.pre . mconcat . map richToken
 
-header :: Maybe FilePath -> Html
-header Nothing = Html.noHtml
-header (Just css) =
-    Html.header $ Html.thelink Html.noHtml ! attrs
+header :: Maybe FilePath -> Maybe FilePath -> Html
+header mcss mjs
+    | isNothing mcss && isNothing mjs = Html.noHtml
+header mcss mjs =
+    Html.header $ css mcss <> js mjs
   where
-    attrs =
+    css Nothing = Html.noHtml
+    css (Just cssFile) = Html.thelink Html.noHtml !
         [ Html.rel "stylesheet"
-        , Html.href css
         , Html.thetype "text/css"
+        , Html.href cssFile
+        ]
+    js Nothing = Html.noHtml
+    js (Just jsFile) = Html.script Html.noHtml !
+        [ Html.thetype "text/javascript"
+        , Html.src jsFile
         ]
 
 richToken :: RichToken -> Html
-- 
cgit v1.2.3


From 844c09d0c1d724e0f0f0698654f2f85f5f58be19 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 26 Jun 2015 22:24:57 +0200
Subject: Create module with hyperlinker utility functions.

---
 haddock-api/haddock-api.cabal                         |  1 +
 haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs | 18 ++++++++++++++++++
 2 files changed, 19 insertions(+)
 create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 216627cc..7670f888 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -85,6 +85,7 @@ library
     Haddock.Backends.HaddockDB
     Haddock.Backends.Hoogle
     Haddock.Backends.Hyperlinker
+    Haddock.Backends.Hyperlinker.Utils
     Haddock.ModuleTree
     Haddock.Types
     Haddock.Doc
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
new file mode 100644
index 00000000..25ed942b
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -0,0 +1,18 @@
+module Haddock.Backends.Hyperlinker.Utils
+    ( srcModUrl
+    , srcNameUrlMap
+    ) where
+
+import Haddock.Utils
+import Haddock.Backends.Xhtml.Types
+
+import GHC
+
+import Data.Maybe
+import Data.Map (Map)
+
+srcModUrl :: SourceURLs -> String
+srcModUrl (_, mModUrl, _, _) = fromMaybe defaultModuleSourceUrl mModUrl
+
+srcNameUrlMap :: SourceURLs -> Map PackageKey FilePath
+srcNameUrlMap (_, _, nameUrlMap, _) = nameUrlMap
-- 
cgit v1.2.3


From d58bcf24dfa4333e7893935eb86c036be28125b1 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 26 Jun 2015 22:41:07 +0200
Subject: Make external hyperlinks point to locations specified by source URLs.

---
 haddock-api/src/Haddock.hs                         |  7 ++-
 haddock-api/src/Haddock/Backends/Hyperlinker.hs    |  8 ++--
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 52 +++++++++++++---------
 haddock-api/src/Haddock/Utils.hs                   |  5 ++-
 4 files changed, 44 insertions(+), 28 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 01e4cd45..3105edf5 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -264,7 +264,12 @@ render dflags flags qual ifaces installedIfaces srcMap = do
       | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl
       | otherwise = Nothing
 
-    srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity
+    srcMap'
+      | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap
+      | Flag_HyperlinkedSource `elem` flags =
+          Map.insert pkgKey defaultNameSourceUrl srcMap
+      | otherwise = srcMap
+
     -- 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')
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 2ed4dbdd..6c66e0c6 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -1,10 +1,10 @@
 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 Haddock.Backends.Hyperlinker.Utils
 
 import Text.XHtml hiding ((</>))
 
@@ -29,7 +29,8 @@ ppHyperlinkedSource outdir libdir mstyle urls ifaces = do
 
 ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO ()
 ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of
-    Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens
+    Just tokens ->
+        writeFile path $ showHtml . render mCssFile mJsFile urls $ tokens
     Nothing -> return ()
   where
     mCssFile = Just $ srcCssFile
@@ -49,6 +50,3 @@ 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/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 6d6d2012..2df62938 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -2,12 +2,16 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where
 
 import Haddock.Backends.Hyperlinker.Parser
 import Haddock.Backends.Hyperlinker.Ast
+import Haddock.Backends.Hyperlinker.Utils
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Utils
 
 import qualified GHC
 import qualified Name as GHC
 import qualified Unique as GHC
 
 import Data.List
+import qualified Data.Map as Map
 import Data.Maybe
 import Data.Monoid
 
@@ -16,11 +20,11 @@ import qualified Text.XHtml as Html
 
 type StyleClass = String
 
-render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html
-render mcss mjs tokens = header mcss mjs <> body tokens
+render :: Maybe FilePath -> Maybe FilePath -> SourceURLs -> [RichToken] -> Html
+render mcss mjs urls tokens = header mcss mjs <> body urls tokens
 
-body :: [RichToken] -> Html
-body = Html.body . Html.pre . mconcat . map richToken
+body :: SourceURLs -> [RichToken] -> Html
+body urls = Html.body . Html.pre . mconcat . map (richToken urls)
 
 header :: Maybe FilePath -> Maybe FilePath -> Html
 header mcss mjs
@@ -40,13 +44,13 @@ header mcss mjs =
         , Html.src jsFile
         ]
 
-richToken :: RichToken -> Html
-richToken (RichToken tok Nothing) =
+richToken :: SourceURLs -> RichToken -> Html
+richToken _ (RichToken tok Nothing) =
     tokenSpan tok ! attrs
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
-richToken (RichToken tok (Just det)) =
-    externalAnchor det . internalAnchor det . hyperlink det $ content
+richToken urls (RichToken tok (Just det)) =
+    externalAnchor det . internalAnchor det . hyperlink urls det $ content
   where
     content = tokenSpan tok ! [ multiclass style]
     style = (tokenStyle . tkType) tok ++ richTokenStyle det
@@ -93,26 +97,32 @@ externalAnchorIdent = GHC.occNameString . GHC.nameOccName
 internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
-hyperlink :: TokenDetails -> Html -> Html
-hyperlink details = case rtkName details of
+hyperlink :: SourceURLs -> TokenDetails -> Html -> Html
+hyperlink urls details = case rtkName details of
     Left name ->
         if GHC.isInternalName name
         then internalHyperlink name
-        else externalHyperlink mname (Just name)
-      where
-        mname = GHC.moduleName <$> GHC.nameModule_maybe name
-    Right name -> externalHyperlink (Just name) Nothing
+        else externalNameHyperlink urls name
+    Right name -> externalModHyperlink name
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
     Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
 
-externalHyperlink :: Maybe GHC.ModuleName -> Maybe GHC.Name -> Html -> Html
-externalHyperlink mmname miname content =
-    Html.anchor content ! [ Html.href $ path ++ anchor ]
+externalNameHyperlink :: SourceURLs -> GHC.Name -> Html -> Html
+externalNameHyperlink urls name =
+    case Map.lookup key $ srcNameUrlMap urls of
+        Just url -> externalNameHyperlink' url name
+        Nothing -> id
   where
-    path = fromMaybe "" $ modulePath <$> mmname
-    anchor = fromMaybe "" $ ("#" ++) . externalAnchorIdent <$> miname
+    key = GHC.modulePackageKey . GHC.nameModule $ name
 
-modulePath :: GHC.ModuleName -> String
-modulePath name = GHC.moduleNameString name ++ ".html"
+externalNameHyperlink' :: String -> GHC.Name -> Html -> Html
+externalNameHyperlink' url name content =
+    Html.anchor content ! [ Html.href $ href ]
+  where
+    mdl = GHC.nameModule name
+    href = spliceURL Nothing (Just mdl) (Just name) Nothing url
+
+externalModHyperlink :: GHC.ModuleName -> Html -> Html
+externalModHyperlink _ = id -- TODO
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 78c78aca..047d9fd0 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -29,7 +29,7 @@ module Haddock.Utils (
   moduleNameUrl, moduleNameUrl', moduleUrl,
   nameAnchorId,
   makeAnchorId,
-  defaultModuleSourceUrl,
+  defaultModuleSourceUrl, defaultNameSourceUrl,
 
   -- * Miscellaneous utilities
   getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
@@ -281,6 +281,9 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r
 defaultModuleSourceUrl :: String
 defaultModuleSourceUrl = "src/%{MODULE}.html"
 
+defaultNameSourceUrl :: String
+defaultNameSourceUrl = defaultModuleSourceUrl ++ "#%{NAME}"
+
 
 -------------------------------------------------------------------------------
 -- * Files we need to copy from our $libdir
-- 
cgit v1.2.3


From ab070206d67748232995a262b533957a5a7b9315 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 27 Jun 2015 18:03:56 +0200
Subject: Rewrite source generation to fixed links and directory structure.

---
 haddock-api/src/Haddock.hs                         | 11 +++--
 haddock-api/src/Haddock/Backends/Hyperlinker.hs    | 29 +++++-------
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 52 +++++++++-------------
 .../src/Haddock/Backends/Hyperlinker/Utils.hs      | 48 +++++++++++++++-----
 haddock-api/src/Haddock/Backends/Xhtml/Utils.hs    | 14 +++---
 haddock-api/src/Haddock/Utils.hs                   |  8 ----
 6 files changed, 85 insertions(+), 77 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 3105edf5..d596c075 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -260,14 +260,13 @@ render dflags flags qual ifaces installedIfaces srcMap = do
     (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags
 
     srcModule'
-      | isJust srcModule = srcModule
-      | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl
-      | otherwise = Nothing
+      | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat
+      | otherwise = srcModule
 
     srcMap'
-      | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap
       | Flag_HyperlinkedSource `elem` flags =
-          Map.insert pkgKey defaultNameSourceUrl srcMap
+          Map.insert pkgKey hypSrcModuleNameUrlFormat srcMap
+      | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap
       | otherwise = srcMap
 
     -- TODO: Get these from the interface files as with srcMap
@@ -322,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
                   libDir
 
   when (Flag_HyperlinkedSource `elem` flags) $ do
-    ppHyperlinkedSource odir libDir opt_source_css sourceUrls' visibleIfaces
+    ppHyperlinkedSource odir libDir opt_source_css 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 6c66e0c6..f197eaa3 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -1,8 +1,9 @@
-module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where
+module Haddock.Backends.Hyperlinker
+    ( ppHyperlinkedSource
+    , module Haddock.Backends.Hyperlinker.Utils
+    ) where
 
 import Haddock.Types
-import Haddock.Backends.Xhtml.Types
-import Haddock.Backends.Xhtml.Utils
 import Haddock.Backends.Hyperlinker.Renderer
 import Haddock.Backends.Hyperlinker.Utils
 
@@ -14,36 +15,30 @@ import System.FilePath
 
 ppHyperlinkedSource :: FilePath -> FilePath
                     -> Maybe FilePath
-                    -> SourceURLs
                     -> [Interface]
                     -> IO ()
-ppHyperlinkedSource outdir libdir mstyle urls ifaces = do
+ppHyperlinkedSource outdir libdir mstyle ifaces = do
     createDirectoryIfMissing True srcdir
     let cssFile = fromMaybe (defaultCssFile libdir) mstyle
     copyFile cssFile $ srcdir </> srcCssFile
     copyFile (libdir </> "html" </> highlightScript) $
         srcdir </> highlightScript
-    mapM_ (ppHyperlinkedModuleSource outdir urls) ifaces
+    mapM_ (ppHyperlinkedModuleSource srcdir) ifaces
   where
-    srcdir = srcPath outdir urls
+    srcdir = outdir </> hypSrcDir
 
-ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO ()
-ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of
+ppHyperlinkedModuleSource :: FilePath -> Interface -> IO ()
+ppHyperlinkedModuleSource srcdir iface = case ifaceTokenizedSrc iface of
     Just tokens ->
-        writeFile path $ showHtml . render mCssFile mJsFile urls $ tokens
+        writeFile path $ showHtml . render mCssFile mJsFile $ tokens
     Nothing -> return ()
   where
     mCssFile = Just $ srcCssFile
     mJsFile = Just $ highlightScript
-    srcFile = spliceURL Nothing (Just $ ifaceMod iface) Nothing Nothing $
-        srcModUrl urls
-    path = outdir </> srcFile
-
-srcPath :: FilePath -> SourceURLs -> FilePath
-srcPath outdir urls = outdir </> takeDirectory (srcModUrl urls)
+    path = srcdir </> hypSrcModuleFile (ifaceMod iface)
 
 srcCssFile :: FilePath
-srcCssFile = "srcstyle.css"
+srcCssFile = "style.css"
 
 highlightScript :: FilePath
 highlightScript = "highlight.js"
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 2df62938..d8ea5ec7 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -3,15 +3,12 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where
 import Haddock.Backends.Hyperlinker.Parser
 import Haddock.Backends.Hyperlinker.Ast
 import Haddock.Backends.Hyperlinker.Utils
-import Haddock.Backends.Xhtml.Types
-import Haddock.Backends.Xhtml.Utils
 
 import qualified GHC
 import qualified Name as GHC
 import qualified Unique as GHC
 
 import Data.List
-import qualified Data.Map as Map
 import Data.Maybe
 import Data.Monoid
 
@@ -20,11 +17,11 @@ import qualified Text.XHtml as Html
 
 type StyleClass = String
 
-render :: Maybe FilePath -> Maybe FilePath -> SourceURLs -> [RichToken] -> Html
-render mcss mjs urls tokens = header mcss mjs <> body urls tokens
+render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html
+render mcss mjs tokens = header mcss mjs <> body tokens
 
-body :: SourceURLs -> [RichToken] -> Html
-body urls = Html.body . Html.pre . mconcat . map (richToken urls)
+body :: [RichToken] -> Html
+body = Html.body . Html.pre . mconcat . map richToken
 
 header :: Maybe FilePath -> Maybe FilePath -> Html
 header mcss mjs
@@ -39,18 +36,18 @@ header mcss mjs =
         , Html.href cssFile
         ]
     js Nothing = Html.noHtml
-    js (Just jsFile) = Html.script Html.noHtml !
+    js (Just scriptFile) = Html.script Html.noHtml !
         [ Html.thetype "text/javascript"
-        , Html.src jsFile
+        , Html.src scriptFile
         ]
 
-richToken :: SourceURLs -> RichToken -> Html
-richToken _ (RichToken tok Nothing) =
+richToken :: RichToken -> Html
+richToken (RichToken tok Nothing) =
     tokenSpan tok ! attrs
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
-richToken urls (RichToken tok (Just det)) =
-    externalAnchor det . internalAnchor det . hyperlink urls det $ content
+richToken (RichToken tok (Just det)) =
+    externalAnchor det . internalAnchor det . hyperlink det $ content
   where
     content = tokenSpan tok ! [ multiclass style]
     style = (tokenStyle . tkType) tok ++ richTokenStyle det
@@ -92,37 +89,30 @@ internalAnchor (RtkBind name) content =
 internalAnchor _ content = content
 
 externalAnchorIdent :: GHC.Name -> String
-externalAnchorIdent = GHC.occNameString . GHC.nameOccName
+externalAnchorIdent = hypSrcNameUrl
 
 internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
-hyperlink :: SourceURLs -> TokenDetails -> Html -> Html
-hyperlink urls details = case rtkName details of
+hyperlink :: TokenDetails -> Html -> Html
+hyperlink details = case rtkName details of
     Left name ->
         if GHC.isInternalName name
         then internalHyperlink name
-        else externalNameHyperlink urls name
+        else externalNameHyperlink name
     Right name -> externalModHyperlink name
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
     Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
 
-externalNameHyperlink :: SourceURLs -> GHC.Name -> Html -> Html
-externalNameHyperlink urls name =
-    case Map.lookup key $ srcNameUrlMap urls of
-        Just url -> externalNameHyperlink' url name
-        Nothing -> id
+externalNameHyperlink :: GHC.Name -> Html -> Html
+externalNameHyperlink name content =
+    Html.anchor content ! [ Html.href href ]
   where
-    key = GHC.modulePackageKey . GHC.nameModule $ name
-
-externalNameHyperlink' :: String -> GHC.Name -> Html -> Html
-externalNameHyperlink' url name content =
-    Html.anchor content ! [ Html.href $ href ]
-  where
-    mdl = GHC.nameModule name
-    href = spliceURL Nothing (Just mdl) (Just name) Nothing url
+    href = hypSrcModuleNameUrl (GHC.nameModule name) name
 
 externalModHyperlink :: GHC.ModuleName -> Html -> Html
-externalModHyperlink _ = id -- TODO
+externalModHyperlink mdl content =
+    Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ]
+
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index 25ed942b..9ba8446d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -1,18 +1,46 @@
 module Haddock.Backends.Hyperlinker.Utils
-    ( srcModUrl
-    , srcNameUrlMap
+    ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile'
+    , hypSrcModuleUrl, hypSrcModuleUrl', hypSrcNameUrl, hypSrcModuleNameUrl
+    , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat,
     ) where
 
-import Haddock.Utils
-import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Utils
 
 import GHC
+import System.FilePath.Posix ((</>))
 
-import Data.Maybe
-import Data.Map (Map)
 
-srcModUrl :: SourceURLs -> String
-srcModUrl (_, mModUrl, _, _) = fromMaybe defaultModuleSourceUrl mModUrl
+hypSrcDir :: FilePath
+hypSrcDir = "src"
 
-srcNameUrlMap :: SourceURLs -> Map PackageKey FilePath
-srcNameUrlMap (_, _, nameUrlMap, _) = nameUrlMap
+hypSrcModuleFile :: Module -> FilePath
+hypSrcModuleFile = hypSrcModuleFile' . moduleName
+
+hypSrcModuleFile' :: ModuleName -> FilePath
+hypSrcModuleFile' mdl = spliceURL'
+    Nothing (Just mdl) Nothing Nothing moduleFormat
+
+hypSrcModuleUrl :: Module -> String
+hypSrcModuleUrl = hypSrcModuleFile
+
+hypSrcModuleUrl' :: ModuleName -> String
+hypSrcModuleUrl' = hypSrcModuleFile'
+
+hypSrcNameUrl :: Name -> String
+hypSrcNameUrl name = spliceURL
+    Nothing Nothing (Just name) Nothing nameFormat
+
+hypSrcModuleNameUrl :: Module -> Name -> String
+hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name
+
+hypSrcModuleUrlFormat :: String
+hypSrcModuleUrlFormat = hypSrcDir </> moduleFormat
+
+hypSrcModuleNameUrlFormat :: String
+hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat
+
+moduleFormat :: String
+moduleFormat = "%{MODULE}.html"
+
+nameFormat :: String
+nameFormat = "%{NAME}"
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
index cbcbbd6d..36ecf863 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs
@@ -14,7 +14,7 @@ module Haddock.Backends.Xhtml.Utils (
   renderToString,
 
   namedAnchor, linkedAnchor,
-  spliceURL,
+  spliceURL, spliceURL',
   groupId,
 
   (<+>), (<=>), char,
@@ -29,7 +29,6 @@ module Haddock.Backends.Xhtml.Utils (
 ) where
 
 
-import Haddock.GhcUtils
 import Haddock.Utils
 
 import Data.Maybe
@@ -38,18 +37,23 @@ import Text.XHtml hiding ( name, title, p, quote )
 import qualified Text.XHtml as XHtml
 
 import GHC      ( SrcSpan(..), srcSpanStartLine, Name )
-import Module   ( Module )
+import Module   ( Module, ModuleName, moduleName, moduleNameString )
 import Name     ( getOccString, nameOccName, isValOcc )
 
 
 spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name ->
              Maybe SrcSpan -> String -> String
-spliceURL maybe_file maybe_mod maybe_name maybe_loc = run
+spliceURL mfile mmod = spliceURL' mfile (moduleName <$> mmod)
+
+
+spliceURL' :: Maybe FilePath -> Maybe ModuleName -> Maybe GHC.Name ->
+              Maybe SrcSpan -> String -> String
+spliceURL' maybe_file maybe_mod maybe_name maybe_loc = run
  where
   file = fromMaybe "" maybe_file
   mdl = case maybe_mod of
           Nothing           -> ""
-          Just m -> moduleString m
+          Just m -> moduleNameString m
 
   (name, kind) =
     case maybe_name of
diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs
index 047d9fd0..4fed3a1e 100644
--- a/haddock-api/src/Haddock/Utils.hs
+++ b/haddock-api/src/Haddock/Utils.hs
@@ -29,7 +29,6 @@ module Haddock.Utils (
   moduleNameUrl, moduleNameUrl', moduleUrl,
   nameAnchorId,
   makeAnchorId,
-  defaultModuleSourceUrl, defaultNameSourceUrl,
 
   -- * Miscellaneous utilities
   getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr,
@@ -278,13 +277,6 @@ 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"
-
-defaultNameSourceUrl :: String
-defaultNameSourceUrl = defaultModuleSourceUrl ++ "#%{NAME}"
-
-
 -------------------------------------------------------------------------------
 -- * Files we need to copy from our $libdir
 -------------------------------------------------------------------------------
-- 
cgit v1.2.3


From a6eb5a19b13bc4dfa79d0e55e5992dfa403aa3c3 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 28 Jun 2015 21:00:55 +0200
Subject: Add basic support for cross-package hyperlink generation.

---
 haddock-api/src/Haddock.hs                         |  2 +-
 haddock-api/src/Haddock/Backends/Hyperlinker.hs    | 25 ++++++-------
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 42 +++++++++++++---------
 3 files changed, 40 insertions(+), 29 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index d596c075..caaa1eef 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 visibleIfaces
+    ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap 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 f197eaa3..f2caa2c1 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -8,33 +8,34 @@ import Haddock.Backends.Hyperlinker.Renderer
 import Haddock.Backends.Hyperlinker.Utils
 
 import Text.XHtml hiding ((</>))
+import GHC
 
 import Data.Maybe
 import System.Directory
 import System.FilePath
 
-ppHyperlinkedSource :: FilePath -> FilePath
-                    -> Maybe FilePath
-                    -> [Interface]
+ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath
+                    -> PackageKey -> SrcMap -> [Interface]
                     -> IO ()
-ppHyperlinkedSource outdir libdir mstyle ifaces = do
+ppHyperlinkedSource outdir libdir mstyle 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) ifaces
+    mapM_ (ppHyperlinkedModuleSource srcdir pkg srcs) ifaces
   where
     srcdir = outdir </> hypSrcDir
 
-ppHyperlinkedModuleSource :: FilePath -> Interface -> IO ()
-ppHyperlinkedModuleSource srcdir iface = case ifaceTokenizedSrc iface of
-    Just tokens ->
-        writeFile path $ showHtml . render mCssFile mJsFile $ tokens
-    Nothing -> return ()
+ppHyperlinkedModuleSource :: FilePath
+                          -> PackageKey -> SrcMap -> Interface
+                          -> IO ()
+ppHyperlinkedModuleSource srcdir pkg srcs iface =
+    case ifaceTokenizedSrc iface of
+        Just tokens -> writeFile path . showHtml . render' $ tokens
+        Nothing -> return ()
   where
-    mCssFile = Just $ srcCssFile
-    mJsFile = Just $ highlightScript
+    render' = render (Just srcCssFile) (Just highlightScript) pkg srcs
     path = srcdir </> hypSrcModuleFile (ifaceMod iface)
 
 srcCssFile :: FilePath
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index d8ea5ec7..b05a5b8a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,5 +1,6 @@
 module Haddock.Backends.Hyperlinker.Renderer (render) where
 
+import Haddock.Types
 import Haddock.Backends.Hyperlinker.Parser
 import Haddock.Backends.Hyperlinker.Ast
 import Haddock.Backends.Hyperlinker.Utils
@@ -8,20 +9,25 @@ import qualified GHC
 import qualified Name as GHC
 import qualified Unique as GHC
 
+import System.FilePath.Posix ((</>))
+
 import Data.List
 import Data.Maybe
 import Data.Monoid
+import qualified Data.Map as Map
 
 import Text.XHtml (Html, HtmlAttr, (!))
 import qualified Text.XHtml as Html
 
 type StyleClass = String
 
-render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html
-render mcss mjs tokens = header mcss mjs <> body tokens
+render :: Maybe FilePath -> Maybe FilePath
+       -> GHC.PackageKey -> SrcMap -> [RichToken]
+       -> Html
+render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens
 
-body :: [RichToken] -> Html
-body = Html.body . Html.pre . mconcat . map richToken
+body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html
+body pkg srcs = Html.body . Html.pre . mconcat . map (richToken pkg srcs)
 
 header :: Maybe FilePath -> Maybe FilePath -> Html
 header mcss mjs
@@ -41,13 +47,13 @@ header mcss mjs =
         , Html.src scriptFile
         ]
 
-richToken :: RichToken -> Html
-richToken (RichToken tok Nothing) =
+richToken :: GHC.PackageKey -> SrcMap -> RichToken -> Html
+richToken _ _ (RichToken tok Nothing) =
     tokenSpan tok ! attrs
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
-richToken (RichToken tok (Just det)) =
-    externalAnchor det . internalAnchor det . hyperlink det $ content
+richToken pkg srcs (RichToken tok (Just det)) =
+    externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content
   where
     content = tokenSpan tok ! [ multiclass style]
     style = (tokenStyle . tkType) tok ++ richTokenStyle det
@@ -94,25 +100,29 @@ externalAnchorIdent = hypSrcNameUrl
 internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
-hyperlink :: TokenDetails -> Html -> Html
-hyperlink details = case rtkName details of
+hyperlink :: GHC.PackageKey -> SrcMap -> TokenDetails -> Html -> Html
+hyperlink pkg srcs details = case rtkName details of
     Left name ->
         if GHC.isInternalName name
         then internalHyperlink name
-        else externalNameHyperlink name
+        else externalNameHyperlink pkg srcs name
     Right name -> externalModHyperlink name
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
     Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
 
-externalNameHyperlink :: GHC.Name -> Html -> Html
-externalNameHyperlink name content =
-    Html.anchor content ! [ Html.href href ]
+externalNameHyperlink :: GHC.PackageKey -> SrcMap -> GHC.Name -> Html -> Html
+externalNameHyperlink pkg srcs name content
+    | namePkg == pkg = Html.anchor content !
+        [ Html.href $ hypSrcModuleNameUrl mdl name ]
+    | Just path <- Map.lookup namePkg srcs = Html.anchor content !
+        [ Html.href $ path </> hypSrcModuleNameUrl mdl name ]
+    | otherwise = content
   where
-    href = hypSrcModuleNameUrl (GHC.nameModule name) name
+    mdl = GHC.nameModule name
+    namePkg = GHC.modulePackageKey mdl
 
 externalModHyperlink :: GHC.ModuleName -> Html -> Html
 externalModHyperlink mdl content =
     Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ]
-
-- 
cgit v1.2.3


From 98cb99c2398a2e2b4467da0a1755d24422384f14 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 28 Jun 2015 21:33:03 +0200
Subject: Disable generating hyperlinks for module references.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs | 11 +++++++++--
 1 file changed, 9 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index b05a5b8a..89d9b60d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -123,6 +123,13 @@ externalNameHyperlink pkg srcs name content
     mdl = GHC.nameModule name
     namePkg = GHC.modulePackageKey mdl
 
+-- TODO: Implement module hyperlinks.
+--
+-- Unfortunately, 'ModuleName' is not enough to provide viable cross-package
+-- hyperlink. And the problem is that GHC AST does not have other information
+-- on imported modules, so for the time being, we do not provide such reference
+-- either.
 externalModHyperlink :: GHC.ModuleName -> Html -> Html
-externalModHyperlink mdl content =
-    Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ]
+externalModHyperlink _ content =
+    content
+    --Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ]
-- 
cgit v1.2.3


From 311b3cc529097ef83a8212439dafcabb86534c62 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 28 Jun 2015 22:28:00 +0200
Subject: Prevent source parser from throwing exception when lexing fails.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 6e195dba..bab5ba0a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -63,7 +63,9 @@ chunk str@(c:_)
 chunk str
     | "--" `isPrefixOf` str = chunk' $ spanToNewline str
     | "{-" `isPrefixOf` str = chunk' $ chunkComment 0 str
-    | otherwise = chunk' $ head $ lex str
+    | otherwise = case lex str of
+        (tok:_) -> chunk' tok
+        [] -> [str]
   where
     chunk' (c, rest) = c:(chunk rest)
 
-- 
cgit v1.2.3


From 5a86381db3d73b4b68fdaae5c150a84e91e80c09 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 29 Jun 2015 16:10:03 +0200
Subject: Make hyperlinker generate correct anchors for data constructors.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 13 +++++++++----
 1 file changed, 9 insertions(+), 4 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 275f10e9..c32bb722 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -107,17 +107,22 @@ binds =
 -- | Obtain details map for top-level declarations.
 decls :: GHC.RenamedSource -> DetailsMap
 decls (group, _, _, _) = concatMap ($ group)
-    [ map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
+    [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
     , everything (<|>) fun
     ]
   where
-    typ (GHC.L _ t) =
-        let (GHC.L sspan name) = GHC.tcdLName t
-        in (sspan, RtkDecl name)
+    typ (GHC.L _ t) = case t of
+        GHC.DataDecl (GHC.L sspan name) _ defn _ ->
+            [(sspan, RtkDecl name)] ++ concatMap con (GHC.dd_cons defn)
+        _ ->
+            let (GHC.L sspan name) = GHC.tcdLName t
+            in pure (sspan, RtkDecl name)
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
             | GHC.isExternalName name -> pure (sspan, RtkDecl name)
         _ -> empty
+    con (GHC.L _ t) = flip map (GHC.con_names t) $
+        \(GHC.L sspan name) -> (sspan, RtkDecl name)
 
 -- | Obtain details map for import declarations.
 --
-- 
cgit v1.2.3


From 46b1520fcc8ef56825bd42ecf1c1fa8ec899ee58 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 29 Jun 2015 17:33:59 +0200
Subject: Make hyperlinker generate anchors for record field declarations.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 16 +++++++++-------
 1 file changed, 9 insertions(+), 7 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index c32bb722..5efcd2ed 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -112,17 +112,19 @@ decls (group, _, _, _) = concatMap ($ group)
     ]
   where
     typ (GHC.L _ t) = case t of
-        GHC.DataDecl (GHC.L sspan name) _ defn _ ->
-            [(sspan, RtkDecl name)] ++ concatMap con (GHC.dd_cons defn)
-        _ ->
-            let (GHC.L sspan name) = GHC.tcdLName t
-            in pure (sspan, RtkDecl name)
+        GHC.DataDecl name _ defn _ ->
+            [decl name] ++ concatMap con (GHC.dd_cons defn)
+        _ -> pure . decl $ GHC.tcdLName t
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
             | GHC.isExternalName name -> pure (sspan, RtkDecl name)
         _ -> empty
-    con (GHC.L _ t) = flip map (GHC.con_names t) $
-        \(GHC.L sspan name) -> (sspan, RtkDecl name)
+    con (GHC.L _ t) =
+        map decl (GHC.con_names t) ++ everything (<|>) fld t
+    fld term = case cast term of
+        Just field -> map decl $ GHC.cd_fld_names field
+        Nothing -> empty
+    decl (GHC.L sspan name) = (sspan, RtkDecl name)
 
 -- | Obtain details map for import declarations.
 --
-- 
cgit v1.2.3


From d6cfd266b30066a5452514b26e50b740104a982b Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 29 Jun 2015 23:00:54 +0200
Subject: Add support for hyperlinking constructor names in patters.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 ++
 1 file changed, 2 insertions(+)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 5efcd2ed..fd3f2f1e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -102,6 +102,8 @@ binds =
     pat term = case cast term of
         (Just (GHC.L sspan (GHC.VarPat name))) ->
             pure (sspan, RtkBind name)
+        (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) _))) ->
+            pure (sspan, RtkVar name)
         _ -> empty
 
 -- | Obtain details map for top-level declarations.
-- 
cgit v1.2.3


From a1d3cb1d86340cd670e50f88e1cb8bf4a4e64f7b Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 29 Jun 2015 23:15:26 +0200
Subject: Add support for hyperlinking field names in record patterns.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index fd3f2f1e..3b0e0f44 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -102,7 +102,11 @@ binds =
     pat term = case cast term of
         (Just (GHC.L sspan (GHC.VarPat name))) ->
             pure (sspan, RtkBind name)
-        (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) _))) ->
+        (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
+            [(sspan, RtkVar name)] ++ everything (<|>) rec recs
+        _ -> empty
+    rec term = case cast term of
+        (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) ->
             pure (sspan, RtkVar name)
         _ -> empty
 
-- 
cgit v1.2.3


From 7d269444ea9c55a2b364ead45fe06d435fa078b2 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 29 Jun 2015 23:41:10 +0200
Subject: Add support for hyperlinking field names in record expressions.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 3b0e0f44..c41b5e5f 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -69,11 +69,17 @@ enrichToken _ _ = Nothing
 -- | Obtain details map for variables ("normally" used identifiers).
 variables :: GHC.RenamedSource -> DetailsMap
 variables =
-    everything (<|>) var
+    everything (<|>) (var `combine` rec)
   where
     var term = case cast term of
         (Just (GHC.L sspan (GHC.HsVar name))) ->
             pure (sspan, RtkVar name)
+        (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _))) ->
+            pure (sspan, RtkVar name)
+        _ -> empty
+    rec term = case cast term of
+        Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.Name) _) ->
+            pure (sspan, RtkVar name)
         _ -> empty
 
 -- | Obtain details map for types.
-- 
cgit v1.2.3


From f3d1f3cbd6e99f5d477a78e05c13b65b9e8b3fae Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 28 Jun 2015 00:49:17 +0200
Subject: Add basic tests related to comment parsing.

---
 .../src/Haddock/Backends/Hyperlinker/Parser.hs     |  2 +-
 .../Haddock/Backends/Hyperlinker/ParserSpec.hs     | 37 +++++++++++++++++++++-
 2 files changed, 37 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index bab5ba0a..019075a1 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -38,7 +38,7 @@ data TokenType
     | TkCpp
     | TkPragma
     | TkUnknown
-    deriving (Eq)
+    deriving (Show, Eq)
 
 -- | Turn source code string into a stream of more descriptive tokens.
 --
diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
index c85fa47e..d5964224 100644
--- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
+++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
@@ -9,9 +9,44 @@ import Haddock.Backends.Hyperlinker.Parser
 main :: IO ()
 main = hspec spec
 
+
 spec :: Spec
 spec = do
     describe "parse" parseSpec
 
+
 parseSpec :: Spec
-parseSpec = return ()
+parseSpec = do
+
+    context "when parsing single-line comments" $ do
+
+        it "should ignore content until the end of line" $
+            "-- some very simple comment\nidentifier"
+            `shouldParseTo`
+            [TkComment, TkSpace, TkIdentifier]
+
+        it "should allow endline escaping" $
+            "-- first line\\\nsecond line\\\nand another one"
+            `shouldParseTo`
+            [TkComment]
+
+    context "when parsing multi-line comments" $ do
+
+        it "should support nested comments" $
+            "{- comment {- nested -} still comment -} {- next comment -}"
+            `shouldParseTo`
+            [TkComment, TkSpace, TkComment]
+
+        it "should distinguish compiler pragma" $
+            "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}"
+            `shouldParseTo`
+            [TkComment, TkPragma, TkComment]
+
+    it "should recognize preprocessor directives" $ do
+        "\n#define foo bar" `shouldParseTo` [TkSpace, TkCpp]
+        "x # y" `shouldParseTo`
+            [TkIdentifier, TkSpace, TkCpp, TkSpace,TkIdentifier]
+
+
+shouldParseTo :: String -> [TokenType] -> Expectation
+str `shouldParseTo` tokens = map tkType (parse str) `shouldBe` tokens
-- 
cgit v1.2.3


From b91ee2f4f0869d1c1076813019ce858c53738042 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 1 Jul 2015 18:32:19 +0200
Subject: Add support for hyperlinking synonyms in patterns.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 ++
 1 file changed, 2 insertions(+)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index c41b5e5f..8777e26d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -110,6 +110,8 @@ binds =
             pure (sspan, RtkBind name)
         (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
             [(sspan, RtkVar name)] ++ everything (<|>) rec recs
+        (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->
+            pure (sspan, RtkBind name)
         _ -> empty
     rec term = case cast term of
         (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) ->
-- 
cgit v1.2.3


From dd781d18eca0d8c28350093d78926d4a9b474827 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 1 Jul 2015 19:06:04 +0200
Subject: Add support for hyperlinking universally quantified type variables.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 8777e26d..79e31db7 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -99,7 +99,7 @@ types =
 -- clauses).
 binds :: GHC.RenamedSource -> DetailsMap
 binds =
-    everything (<|>) (fun `combine` pat)
+    everything (<|>) (fun `combine` pat `combine` tvar)
   where
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) ->
@@ -117,6 +117,12 @@ binds =
         (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.Name) _)) ->
             pure (sspan, RtkVar name)
         _ -> empty
+    tvar term = case cast term of
+        (Just (GHC.L sspan (GHC.UserTyVar name))) ->
+            pure (sspan, RtkBind name)
+        (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) ->
+            pure (sspan, RtkBind name)
+        _ -> empty
 
 -- | Obtain details map for top-level declarations.
 decls :: GHC.RenamedSource -> DetailsMap
-- 
cgit v1.2.3


From 868248d5e847e29ffede5b6c7d20f08a3ec7eb47 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Wed, 1 Jul 2015 22:25:21 +0200
Subject: Make hyperlinker render qualified names as one entity.

---
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        |  1 +
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 50 +++++++++++++++++++---
 2 files changed, 46 insertions(+), 5 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 79e31db7..decb1206 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -25,6 +25,7 @@ data TokenDetails
     | RtkBind GHC.Name
     | RtkDecl GHC.Name
     | RtkModule GHC.ModuleName
+    deriving (Eq)
 
 rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName
 rtkName (RtkVar name) = Left name
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 89d9b60d..ddb2e5b9 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -19,15 +19,46 @@ import qualified Data.Map as Map
 import Text.XHtml (Html, HtmlAttr, (!))
 import qualified Text.XHtml as Html
 
+
 type StyleClass = String
 
+
 render :: Maybe FilePath -> Maybe FilePath
        -> GHC.PackageKey -> SrcMap -> [RichToken]
        -> Html
 render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens
 
+
+data TokenGroup
+    = GrpNormal Token
+    | GrpRich TokenDetails [Token]
+
+
+-- | Group consecutive tokens pointing to the same element.
+--
+-- We want to render qualified identifiers as one entity. For example,
+-- @Bar.Baz.foo@ consists of 5 tokens (@Bar@, @.@, @Baz@, @.@, @foo@) but for
+-- better user experience when highlighting and clicking links, these tokens
+-- should be regarded as one identifier. Therefore, before rendering we must
+-- group consecutive elements pointing to the same 'GHC.Name' (note that even
+-- dot token has it if it is part of qualified name).
+groupTokens :: [RichToken] -> [TokenGroup]
+groupTokens [] = []
+groupTokens ((RichToken tok Nothing):rest) = (GrpNormal tok):(groupTokens rest)
+groupTokens ((RichToken tok (Just det)):rest) =
+    let (grp, rest') = span same rest
+    in (GrpRich det (tok:(map rtkToken grp))):(groupTokens rest')
+  where
+    same (RichToken _ (Just det')) = det == det'
+    same _ = False
+
+
 body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html
-body pkg srcs = Html.body . Html.pre . mconcat . map (richToken pkg srcs)
+body pkg srcs tokens =
+    Html.body . Html.pre $ hypsrc
+  where
+    hypsrc = mconcat . map (tokenGroup pkg srcs) . groupTokens $ tokens
+
 
 header :: Maybe FilePath -> Maybe FilePath -> Html
 header mcss mjs
@@ -47,20 +78,29 @@ header mcss mjs =
         , Html.src scriptFile
         ]
 
-richToken :: GHC.PackageKey -> SrcMap -> RichToken -> Html
-richToken _ _ (RichToken tok Nothing) =
+
+tokenGroup :: GHC.PackageKey -> SrcMap -> TokenGroup -> Html
+tokenGroup _ _ (GrpNormal tok) =
     tokenSpan tok ! attrs
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
-richToken pkg srcs (RichToken tok (Just det)) =
+tokenGroup pkg srcs (GrpRich det tokens) =
     externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content
   where
-    content = tokenSpan tok ! [ multiclass style]
+    content = mconcat . map (richToken det) $ tokens
+
+
+richToken :: TokenDetails -> Token -> Html
+richToken det tok =
+    tokenSpan tok ! [ multiclass style ]
+  where
     style = (tokenStyle . tkType) tok ++ richTokenStyle det
 
+
 tokenSpan :: Token -> Html
 tokenSpan = Html.thespan . Html.toHtml . tkValue
 
+
 richTokenStyle :: TokenDetails -> [StyleClass]
 richTokenStyle (RtkVar _) = ["hs-var"]
 richTokenStyle (RtkType _) = ["hs-type"]
-- 
cgit v1.2.3


From 0d0550cdcf3fa7ceff88e2572f7ffb341b9f760d Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 2 Jul 2015 12:32:59 +0200
Subject: Fix crash happening when hyperlinking type family declarations.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 1 +
 1 file changed, 1 insertion(+)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index decb1206..c12ac35a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -135,6 +135,7 @@ decls (group, _, _, _) = concatMap ($ group)
     typ (GHC.L _ t) = case t of
         GHC.DataDecl name _ defn _ ->
             [decl name] ++ concatMap con (GHC.dd_cons defn)
+        GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
         _ -> pure . decl $ GHC.tcdLName t
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
-- 
cgit v1.2.3


From 5c01af0e605c2bd16382cbd0de7102f1fbc2f361 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 2 Jul 2015 12:47:03 +0200
Subject: Add support for anchoring data family constructor declarations.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 11 ++++++-----
 1 file changed, 6 insertions(+), 5 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index c12ac35a..b592326d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -129,20 +129,21 @@ binds =
 decls :: GHC.RenamedSource -> DetailsMap
 decls (group, _, _, _) = concatMap ($ group)
     [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
-    , everything (<|>) fun
+    , everything (<|>) (fun `combine` con)
     ]
   where
     typ (GHC.L _ t) = case t of
-        GHC.DataDecl name _ defn _ ->
-            [decl name] ++ concatMap con (GHC.dd_cons defn)
+        GHC.DataDecl name _ _ _ -> pure . decl $ name
         GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
         _ -> pure . decl $ GHC.tcdLName t
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
             | GHC.isExternalName name -> pure (sspan, RtkDecl name)
         _ -> empty
-    con (GHC.L _ t) =
-        map decl (GHC.con_names t) ++ everything (<|>) fld t
+    con term = case cast term of
+        (Just cdcl) ->
+            map decl (GHC.con_names cdcl) ++ everything (<|>) fld cdcl
+        Nothing -> empty
     fld term = case cast term of
         Just field -> map decl $ GHC.cd_fld_names field
         Nothing -> empty
-- 
cgit v1.2.3


From 28e93ceec440d0d1ed053bbf3c20e4bdcd6d5f4e Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 2 Jul 2015 13:31:05 +0200
Subject: Improve support for hyperlinking type families.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs    | 8 +++++++-
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 1 +
 2 files changed, 8 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index b592326d..4b60ca37 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -129,7 +129,7 @@ binds =
 decls :: GHC.RenamedSource -> DetailsMap
 decls (group, _, _, _) = concatMap ($ group)
     [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
-    , everything (<|>) (fun `combine` con)
+    , everything (<|>) (fun `combine` con `combine` ins)
     ]
   where
     typ (GHC.L _ t) = case t of
@@ -144,10 +144,16 @@ decls (group, _, _, _) = concatMap ($ group)
         (Just cdcl) ->
             map decl (GHC.con_names cdcl) ++ everything (<|>) fld cdcl
         Nothing -> empty
+    ins term = case cast term of
+        (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst
+        (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) ->
+            pure . tyref $ GHC.tfe_tycon eqn
+        _ -> empty
     fld term = case cast term of
         Just field -> map decl $ GHC.cd_fld_names field
         Nothing -> empty
     decl (GHC.L sspan name) = (sspan, RtkDecl name)
+    tyref (GHC.L sspan name) = (sspan, RtkType name)
 
 -- | Obtain details map for import declarations.
 --
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 019075a1..37cc5377 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -197,6 +197,7 @@ keywords =
     , "type"
     , "where"
     , "forall"
+    , "family"
     , "mdo"
     ]
 
-- 
cgit v1.2.3


From aa6c6deba47af1c21765ed09dc0317825aa1d78d Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 2 Jul 2015 13:41:38 +0200
Subject: Fix issue with operators being recognized as preprocessor directives.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 6 +++---
 hypsrc-test/src/Operators.hs                           | 4 ++++
 2 files changed, 7 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index 37cc5377..d927aa08 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -156,17 +156,17 @@ classify str
     | "--" `isPrefixOf` str = TkComment
     | "{-#" `isPrefixOf` str = TkPragma
     | "{-" `isPrefixOf` str = TkComment
-classify (c:_)
+classify str@(c:_)
     | isSpace c = TkSpace
     | isDigit c = TkNumber
     | c `elem` special = TkSpecial
+    | str `elem` glyphs = TkGlyph
+    | all (`elem` symbols) str = TkOperator
     | c == '#' = TkCpp
     | c == '"' = TkString
     | c == '\'' = TkChar
 classify str
     | str `elem` keywords = TkKeyword
-    | str `elem` glyphs = TkGlyph
-    | all (`elem` symbols) str = TkOperator
     | isIdentifier str = TkIdentifier
     | otherwise = TkUnknown
 
diff --git a/hypsrc-test/src/Operators.hs b/hypsrc-test/src/Operators.hs
index bc76c2d3..8e86ab0b 100644
--- a/hypsrc-test/src/Operators.hs
+++ b/hypsrc-test/src/Operators.hs
@@ -16,3 +16,7 @@ a */\* b = concatMap (*** b) a
 
 (**/\**) :: [[a]] -> [[a]] -> [[a]]
 a **/\** b = zipWith (*/\*) [a +++ b] (a $$$ b)
+
+
+(#.#) :: a -> b -> (c -> (a, b))
+a #.# b = const $ (a, b)
-- 
cgit v1.2.3


From d761512f239b17f8e9824629595d75aa46e55554 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 2 Jul 2015 18:53:28 +0200
Subject: Add support for anchoring signatures in type class declarations.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 5 +++++
 1 file changed, 5 insertions(+)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 4b60ca37..98c9770f 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+
 
 module Haddock.Backends.Hyperlinker.Ast
     ( enrich
@@ -135,6 +137,7 @@ decls (group, _, _, _) = concatMap ($ group)
     typ (GHC.L _ t) = case t of
         GHC.DataDecl name _ _ _ -> pure . decl $ name
         GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
+        GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
         _ -> pure . decl $ GHC.tcdLName t
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
@@ -152,6 +155,8 @@ decls (group, _, _, _) = concatMap ($ group)
     fld term = case cast term of
         Just field -> map decl $ GHC.cd_fld_names field
         Nothing -> empty
+    sig (GHC.L _ (GHC.TypeSig names _ _)) = map decl names
+    sig _ = []
     decl (GHC.L sspan name) = (sspan, RtkDecl name)
     tyref (GHC.L sspan name) = (sspan, RtkType name)
 
-- 
cgit v1.2.3


From ef3b8691ea607bd4f67d5dc77bb226cf57ec4c30 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Thu, 2 Jul 2015 19:04:47 +0200
Subject: Make hyperlinker generate anchors only to top-level value bindings.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 98c9770f..1e121c2e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -131,7 +131,8 @@ binds =
 decls :: GHC.RenamedSource -> DetailsMap
 decls (group, _, _, _) = concatMap ($ group)
     [ concat . map typ . concat . map GHC.group_tyclds . GHC.hs_tyclds
-    , everything (<|>) (fun `combine` con `combine` ins)
+    , everything (<|>) fun . GHC.hs_valds
+    , everything (<|>) (con `combine` ins)
     ]
   where
     typ (GHC.L _ t) = case t of
-- 
cgit v1.2.3


From a86147030e0f8fe33ebd4b358ac04d3beb45c3f8 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 4 Jul 2015 17:15:26 +0200
Subject: Remove potentially dangerous record access in hyperlinker AST module.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 1e121c2e..9d5c127d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -137,9 +137,9 @@ decls (group, _, _, _) = concatMap ($ group)
   where
     typ (GHC.L _ t) = case t of
         GHC.DataDecl name _ _ _ -> pure . decl $ name
+        GHC.SynDecl name _ _ _ -> pure . decl $ name
         GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
         GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
-        _ -> pure . decl $ GHC.tcdLName t
     fun term = case cast term of
         (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
             | GHC.isExternalName name -> pure (sspan, RtkDecl name)
-- 
cgit v1.2.3


From 99980dcc63d696c7912ff1f0d2faadcce169f184 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sun, 5 Jul 2015 17:06:36 +0200
Subject: Refactor source path mapping to use modules as indices.

---
 haddock-api/src/Haddock.hs                         | 27 ++++++++++------
 haddock-api/src/Haddock/Backends/Hyperlinker.hs    | 15 ++++-----
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   | 36 ++++++++++------------
 haddock-api/src/Haddock/InterfaceFile.hs           | 11 ++++---
 haddock-api/src/Haddock/Types.hs                   |  9 +++++-
 5 files changed, 55 insertions(+), 43 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 5a1c6abe..5c48d28b 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -46,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
@@ -228,13 +229,14 @@ 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
+      [ (ifModule ifile, path) | ((_, Just path), ifile) <- pkgs ]
+  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)
@@ -264,15 +266,20 @@ render dflags flags qual ifaces installedIfaces srcMap = do
       | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat
       | otherwise = srcModule
 
-    srcMap'
+    srcMap = 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 srcMap
-      | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap
-      | otherwise = srcMap
+          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
@@ -322,7 +329,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
                   libDir
 
   when (Flag_HyperlinkedSource `elem` flags) $ do
-    ppHyperlinkedSource odir libDir opt_source_css pretty pkgKey srcMap ifaces
+    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
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 1fadef49..f007f970 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -8,7 +8,6 @@ import Haddock.Backends.Hyperlinker.Renderer
 import Haddock.Backends.Hyperlinker.Utils
 
 import Text.XHtml hiding ((</>))
-import GHC
 
 import Data.Maybe
 import System.Directory
@@ -24,30 +23,28 @@ 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
+                    -> SrcMap -- ^ Paths to sources
                     -> [Interface] -- ^ Interfaces for which we create source
                     -> IO ()
-ppHyperlinkedSource outdir libdir mstyle pretty pkg srcs ifaces = do
+ppHyperlinkedSource outdir libdir mstyle pretty 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 pretty pkg srcs) ifaces
+    mapM_ (ppHyperlinkedModuleSource srcdir pretty srcs) ifaces
   where
     srcdir = outdir </> hypSrcDir
 
 -- | Generate hyperlinked source for particular interface.
-ppHyperlinkedModuleSource :: FilePath -> Bool
-                          -> PackageKey -> SrcMap -> Interface
+ppHyperlinkedModuleSource :: FilePath -> Bool -> SrcMap -> Interface
                           -> IO ()
-ppHyperlinkedModuleSource srcdir pretty pkg srcs iface =
+ppHyperlinkedModuleSource srcdir pretty srcs iface =
     case ifaceTokenizedSrc iface of
         Just tokens -> writeFile path . html . render' $ tokens
         Nothing -> return ()
   where
-    render' = render (Just srcCssFile) (Just highlightScript) pkg srcs
+    render' = render (Just srcCssFile) (Just highlightScript) srcs
     html = if pretty then renderHtml else showHtml
     path = srcdir </> hypSrcModuleFile (ifaceMod iface)
 
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index ddb2e5b9..a4d7bc2d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -23,10 +23,9 @@ import qualified Text.XHtml as Html
 type StyleClass = String
 
 
-render :: Maybe FilePath -> Maybe FilePath
-       -> GHC.PackageKey -> SrcMap -> [RichToken]
+render :: Maybe FilePath -> Maybe FilePath -> SrcMap -> [RichToken]
        -> Html
-render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens
+render mcss mjs srcs tokens = header mcss mjs <> body srcs tokens
 
 
 data TokenGroup
@@ -53,11 +52,11 @@ groupTokens ((RichToken tok (Just det)):rest) =
     same _ = False
 
 
-body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html
-body pkg srcs tokens =
+body :: SrcMap -> [RichToken] -> Html
+body srcs tokens =
     Html.body . Html.pre $ hypsrc
   where
-    hypsrc = mconcat . map (tokenGroup pkg srcs) . groupTokens $ tokens
+    hypsrc = mconcat . map (tokenGroup srcs) . groupTokens $ tokens
 
 
 header :: Maybe FilePath -> Maybe FilePath -> Html
@@ -79,13 +78,13 @@ header mcss mjs =
         ]
 
 
-tokenGroup :: GHC.PackageKey -> SrcMap -> TokenGroup -> Html
-tokenGroup _ _ (GrpNormal tok) =
+tokenGroup :: SrcMap -> TokenGroup -> Html
+tokenGroup _ (GrpNormal tok) =
     tokenSpan tok ! attrs
   where
     attrs = [ multiclass . tokenStyle . tkType $ tok ]
-tokenGroup pkg srcs (GrpRich det tokens) =
-    externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content
+tokenGroup srcs (GrpRich det tokens) =
+    externalAnchor det . internalAnchor det . hyperlink srcs det $ content
   where
     content = mconcat . map (richToken det) $ tokens
 
@@ -140,28 +139,27 @@ externalAnchorIdent = hypSrcNameUrl
 internalAnchorIdent :: GHC.Name -> String
 internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
 
-hyperlink :: GHC.PackageKey -> SrcMap -> TokenDetails -> Html -> Html
-hyperlink pkg srcs details = case rtkName details of
+hyperlink :: SrcMap -> TokenDetails -> Html -> Html
+hyperlink srcs details = case rtkName details of
     Left name ->
         if GHC.isInternalName name
         then internalHyperlink name
-        else externalNameHyperlink pkg srcs name
+        else externalNameHyperlink srcs name
     Right name -> externalModHyperlink name
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
     Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
 
-externalNameHyperlink :: GHC.PackageKey -> SrcMap -> GHC.Name -> Html -> Html
-externalNameHyperlink pkg srcs name content
-    | namePkg == pkg = Html.anchor content !
+externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html
+externalNameHyperlink srcs name content = case Map.lookup mdl srcs of
+    Just SrcLocal -> Html.anchor content !
         [ Html.href $ hypSrcModuleNameUrl mdl name ]
-    | Just path <- Map.lookup namePkg srcs = Html.anchor content !
+    Just (SrcExternal path) -> Html.anchor content !
         [ Html.href $ path </> hypSrcModuleNameUrl mdl name ]
-    | otherwise = content
+    Nothing -> content
   where
     mdl = GHC.nameModule name
-    namePkg = GHC.modulePackageKey mdl
 
 -- TODO: Implement module hyperlinks.
 --
diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs
index 4b39d315..d5762ce8 100644
--- a/haddock-api/src/Haddock/InterfaceFile.hs
+++ b/haddock-api/src/Haddock/InterfaceFile.hs
@@ -14,7 +14,7 @@
 -- Reading and writing the .haddock interface file
 -----------------------------------------------------------------------------
 module Haddock.InterfaceFile (
-  InterfaceFile(..), ifPackageKey,
+  InterfaceFile(..), ifModule, ifPackageKey,
   readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor,
   writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility
 ) where
@@ -51,11 +51,14 @@ data InterfaceFile = InterfaceFile {
 }
 
 
-ifPackageKey :: InterfaceFile -> PackageKey
-ifPackageKey if_ =
+ifModule :: InterfaceFile -> Module
+ifModule if_ =
   case ifInstalledIfaces if_ of
     [] -> error "empty InterfaceFile"
-    iface:_ -> modulePackageKey $ instMod iface
+    iface:_ -> instMod iface
+
+ifPackageKey :: InterfaceFile -> PackageKey
+ifPackageKey = modulePackageKey . ifModule
 
 
 binaryInterfaceMagic :: Word32
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index fbb5f44c..da4b3eec 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -50,7 +50,7 @@ type SubMap        = Map Name [Name]
 type DeclMap       = Map Name [LHsDecl Name]
 type InstMap       = Map SrcSpan Name
 type FixMap        = Map Name Fixity
-type SrcMap        = Map PackageKey FilePath
+type SrcMap        = Map Module SrcPath
 type DocPaths      = (FilePath, Maybe FilePath) -- paths to HTML and sources
 
 
@@ -271,6 +271,13 @@ unrenameDocForDecl (doc, fnArgsDoc) =
 -- | Type of environment used to cross-reference identifiers in the syntax.
 type LinkEnv = Map Name Module
 
+-- | Path for making cross-package hyperlinks in generated sources.
+--
+-- Used in 'SrcMap' to determine whether module originates in current package
+-- or in an external package.
+data SrcPath
+  = SrcExternal FilePath
+  | SrcLocal
 
 -- | Extends 'Name' with cross-reference information.
 data DocName
-- 
cgit v1.2.3


From fcaa46b054fc3b5a5535a748d3c3283629e3eadf Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 6 Jul 2015 16:39:57 +0200
Subject: Extract main hyperlinker types to separate module.

---
 haddock-api/haddock-api.cabal                      |  1 +
 haddock-api/src/Haddock/Backends/Hyperlinker.hs    |  1 +
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 27 ++--------
 .../src/Haddock/Backends/Hyperlinker/Parser.hs     | 40 ++-------------
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs   |  4 +-
 .../src/Haddock/Backends/Hyperlinker/Types.hs      | 59 ++++++++++++++++++++++
 .../src/Haddock/Backends/Hyperlinker/Utils.hs      |  1 +
 haddock-api/src/Haddock/Interface/Create.hs        |  1 +
 haddock-api/src/Haddock/Types.hs                   |  3 +-
 haddock.cabal                                      |  5 ++
 10 files changed, 79 insertions(+), 63 deletions(-)
 create mode 100644 haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 11567f99..3838c3d8 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -85,6 +85,7 @@ library
     Haddock.Backends.Hyperlinker.Ast
     Haddock.Backends.Hyperlinker.Parser
     Haddock.Backends.Hyperlinker.Renderer
+    Haddock.Backends.Hyperlinker.Types
     Haddock.Backends.Hyperlinker.Utils
     Haddock.ModuleTree
     Haddock.Types
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index f007f970..4b58190c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -3,6 +3,7 @@ module Haddock.Backends.Hyperlinker
     , module Haddock.Backends.Hyperlinker.Utils
     ) where
 
+
 import Haddock.Types
 import Haddock.Backends.Hyperlinker.Renderer
 import Haddock.Backends.Hyperlinker.Utils
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 9d5c127d..28fdc3f5 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -3,12 +3,10 @@
 {-# LANGUAGE RecordWildCards #-}
 
 
-module Haddock.Backends.Hyperlinker.Ast
-    ( enrich
-    , RichToken(..), TokenDetails(..), rtkName
-    ) where
+module Haddock.Backends.Hyperlinker.Ast (enrich) where
 
-import Haddock.Backends.Hyperlinker.Parser
+
+import Haddock.Backends.Hyperlinker.Types
 
 import qualified GHC
 
@@ -16,25 +14,6 @@ import Control.Applicative
 import Data.Data
 import Data.Maybe
 
-data RichToken = RichToken
-    { rtkToken :: Token
-    , rtkDetails :: Maybe TokenDetails
-    }
-
-data TokenDetails
-    = RtkVar GHC.Name
-    | RtkType GHC.Name
-    | RtkBind GHC.Name
-    | RtkDecl GHC.Name
-    | RtkModule GHC.ModuleName
-    deriving (Eq)
-
-rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName
-rtkName (RtkVar name) = Left name
-rtkName (RtkType name) = Left name
-rtkName (RtkBind name) = Left name
-rtkName (RtkDecl name) = Left name
-rtkName (RtkModule name) = Right name
 
 -- | Add more detailed information to token stream using GHC API.
 enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
index d927aa08..e206413e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
@@ -1,44 +1,12 @@
-module Haddock.Backends.Hyperlinker.Parser
-    ( parse
-    , Token(..), TokenType(..)
-    , Position(..), Span(..)
-    ) where
+module Haddock.Backends.Hyperlinker.Parser (parse) where
+
 
 import Data.Char
 import Data.List
 import Data.Maybe
 
-data Token = Token
-    { tkType :: TokenType
-    , tkValue :: String
-    , tkSpan :: Span
-    }
-
-data Position = Position
-    { posRow :: !Int
-    , posCol :: !Int
-    }
-
-data Span = Span
-    { spStart :: Position
-    , spEnd :: Position
-    }
-
-data TokenType
-    = TkIdentifier
-    | TkKeyword
-    | TkString
-    | TkChar
-    | TkNumber
-    | TkOperator
-    | TkGlyph
-    | TkSpecial
-    | TkSpace
-    | TkComment
-    | TkCpp
-    | TkPragma
-    | TkUnknown
-    deriving (Show, Eq)
+import Haddock.Backends.Hyperlinker.Types
+
 
 -- | Turn source code string into a stream of more descriptive tokens.
 --
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index a4d7bc2d..add1465b 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,8 +1,8 @@
 module Haddock.Backends.Hyperlinker.Renderer (render) where
 
+
 import Haddock.Types
-import Haddock.Backends.Hyperlinker.Parser
-import Haddock.Backends.Hyperlinker.Ast
+import Haddock.Backends.Hyperlinker.Types
 import Haddock.Backends.Hyperlinker.Utils
 
 import qualified GHC
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
new file mode 100644
index 00000000..19cc5288
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -0,0 +1,59 @@
+module Haddock.Backends.Hyperlinker.Types where
+
+
+import qualified GHC
+
+
+data Token = Token
+    { tkType :: TokenType
+    , tkValue :: String
+    , tkSpan :: Span
+    }
+
+data Position = Position
+    { posRow :: !Int
+    , posCol :: !Int
+    }
+
+data Span = Span
+    { spStart :: Position
+    , spEnd :: Position
+    }
+
+data TokenType
+    = TkIdentifier
+    | TkKeyword
+    | TkString
+    | TkChar
+    | TkNumber
+    | TkOperator
+    | TkGlyph
+    | TkSpecial
+    | TkSpace
+    | TkComment
+    | TkCpp
+    | TkPragma
+    | TkUnknown
+    deriving (Show, Eq)
+
+
+data RichToken = RichToken
+    { rtkToken :: Token
+    , rtkDetails :: Maybe TokenDetails
+    }
+
+data TokenDetails
+    = RtkVar GHC.Name
+    | RtkType GHC.Name
+    | RtkBind GHC.Name
+    | RtkDecl GHC.Name
+    | RtkModule GHC.ModuleName
+    deriving (Eq)
+
+
+rtkName :: TokenDetails -> Either GHC.Name GHC.ModuleName
+rtkName (RtkVar name) = Left name
+rtkName (RtkType name) = Left name
+rtkName (RtkBind name) = Left name
+rtkName (RtkDecl name) = Left name
+rtkName (RtkModule name) = Right name
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index 9ba8446d..db2bfc76 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -4,6 +4,7 @@ module Haddock.Backends.Hyperlinker.Utils
     , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat,
     ) where
 
+
 import Haddock.Backends.Xhtml.Utils
 
 import GHC
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 59f7076f..0599151e 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -21,6 +21,7 @@ import Haddock.GhcUtils
 import Haddock.Utils
 import Haddock.Convert
 import Haddock.Interface.LexParseRn
+import Haddock.Backends.Hyperlinker.Types
 import Haddock.Backends.Hyperlinker.Ast as Hyperlinker
 import Haddock.Backends.Hyperlinker.Parser as Hyperlinker
 
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index da4b3eec..90dbb4d4 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -35,7 +35,8 @@ import DynFlags (ExtensionFlag, Language)
 import OccName
 import Outputable
 import Control.Monad (ap)
-import Haddock.Backends.Hyperlinker.Ast
+
+import Haddock.Backends.Hyperlinker.Types
 
 -----------------------------------------------------------------------------
 -- * Convenient synonyms
diff --git a/haddock.cabal b/haddock.cabal
index 2a1caee7..8fa9f33d 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -104,6 +104,11 @@ executable haddock
       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
-- 
cgit v1.2.3


From 13254609062a16e010d1c5a24e571dfe98ab6f69 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 6 Jul 2015 16:52:13 +0200
Subject: Move source paths types to hyperlinker types module.

---
 haddock-api/src/Haddock/Backends/Hyperlinker.hs          |  2 ++
 haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs |  1 -
 haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs    | 13 +++++++++++++
 haddock-api/src/Haddock/Types.hs                         |  9 ---------
 4 files changed, 15 insertions(+), 10 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index 4b58190c..248a8a54 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -1,11 +1,13 @@
 module Haddock.Backends.Hyperlinker
     ( ppHyperlinkedSource
+    , module Haddock.Backends.Hyperlinker.Types
     , module Haddock.Backends.Hyperlinker.Utils
     ) where
 
 
 import Haddock.Types
 import Haddock.Backends.Hyperlinker.Renderer
+import Haddock.Backends.Hyperlinker.Types
 import Haddock.Backends.Hyperlinker.Utils
 
 import Text.XHtml hiding ((</>))
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index add1465b..1065897d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,7 +1,6 @@
 module Haddock.Backends.Hyperlinker.Renderer (render) where
 
 
-import Haddock.Types
 import Haddock.Backends.Hyperlinker.Types
 import Haddock.Backends.Hyperlinker.Utils
 
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
index 19cc5288..ecb51a07 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -3,6 +3,8 @@ module Haddock.Backends.Hyperlinker.Types where
 
 import qualified GHC
 
+import Data.Map (Map)
+
 
 data Token = Token
     { tkType :: TokenType
@@ -57,3 +59,14 @@ rtkName (RtkType name) = Left name
 rtkName (RtkBind name) = Left name
 rtkName (RtkDecl name) = Left name
 rtkName (RtkModule name) = Right name
+
+
+-- | Path for making cross-package hyperlinks in generated sources.
+--
+-- Used in 'SrcMap' to determine whether module originates in current package
+-- or in an external package.
+data SrcPath
+  = SrcExternal FilePath
+  | SrcLocal
+
+type SrcMap = Map GHC.Module SrcPath
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index 90dbb4d4..6dd64506 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -51,7 +51,6 @@ type SubMap        = Map Name [Name]
 type DeclMap       = Map Name [LHsDecl Name]
 type InstMap       = Map SrcSpan Name
 type FixMap        = Map Name Fixity
-type SrcMap        = Map Module SrcPath
 type DocPaths      = (FilePath, Maybe FilePath) -- paths to HTML and sources
 
 
@@ -272,14 +271,6 @@ unrenameDocForDecl (doc, fnArgsDoc) =
 -- | Type of environment used to cross-reference identifiers in the syntax.
 type LinkEnv = Map Name Module
 
--- | Path for making cross-package hyperlinks in generated sources.
---
--- Used in 'SrcMap' to determine whether module originates in current package
--- or in an external package.
-data SrcPath
-  = SrcExternal FilePath
-  | SrcLocal
-
 -- | Extends 'Name' with cross-reference information.
 data DocName
   = Documented Name Module
-- 
cgit v1.2.3


From bbd036ad309c95ce70affa5aa0a77a61aa5569c8 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 6 Jul 2015 17:06:19 +0200
Subject: Add support for hyperlinking modules in import lists.

---
 haddock-api/src/Haddock.hs                          |  2 +-
 .../src/Haddock/Backends/Hyperlinker/Renderer.hs    | 21 +++++++++------------
 .../src/Haddock/Backends/Hyperlinker/Types.hs       | 10 +++++++---
 3 files changed, 17 insertions(+), 16 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index d4d8e3e6..350a73ea 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -268,7 +268,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
       | Flag_HyperlinkedSource `elem` flags = Just hypSrcModuleUrlFormat
       | otherwise = srcModule
 
-    srcMap = Map.union
+    srcMap = mkSrcMap $ Map.union
       (Map.map SrcExternal extSrcMap)
       (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ])
 
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 1065897d..5037421a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -144,14 +144,14 @@ hyperlink srcs details = case rtkName details of
         if GHC.isInternalName name
         then internalHyperlink name
         else externalNameHyperlink srcs name
-    Right name -> externalModHyperlink name
+    Right name -> externalModHyperlink srcs name
 
 internalHyperlink :: GHC.Name -> Html -> Html
 internalHyperlink name content =
     Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
 
 externalNameHyperlink :: SrcMap -> GHC.Name -> Html -> Html
-externalNameHyperlink srcs name content = case Map.lookup mdl srcs of
+externalNameHyperlink (srcs, _) name content = case Map.lookup mdl srcs of
     Just SrcLocal -> Html.anchor content !
         [ Html.href $ hypSrcModuleNameUrl mdl name ]
     Just (SrcExternal path) -> Html.anchor content !
@@ -160,13 +160,10 @@ externalNameHyperlink srcs name content = case Map.lookup mdl srcs of
   where
     mdl = GHC.nameModule name
 
--- TODO: Implement module hyperlinks.
---
--- Unfortunately, 'ModuleName' is not enough to provide viable cross-package
--- hyperlink. And the problem is that GHC AST does not have other information
--- on imported modules, so for the time being, we do not provide such reference
--- either.
-externalModHyperlink :: GHC.ModuleName -> Html -> Html
-externalModHyperlink _ content =
-    content
-    --Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ]
+externalModHyperlink :: SrcMap -> GHC.ModuleName -> Html -> Html
+externalModHyperlink (_, srcs) name content = case Map.lookup name srcs of
+    Just SrcLocal -> Html.anchor content !
+        [ Html.href $ hypSrcModuleUrl' name ]
+    Just (SrcExternal path) -> Html.anchor content !
+        [ Html.href $ path </> hypSrcModuleUrl' name ]
+    Nothing -> content
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
index ecb51a07..c3954dc9 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -4,6 +4,7 @@ module Haddock.Backends.Hyperlinker.Types where
 import qualified GHC
 
 import Data.Map (Map)
+import qualified Data.Map as Map
 
 
 data Token = Token
@@ -66,7 +67,10 @@ rtkName (RtkModule name) = Right name
 -- Used in 'SrcMap' to determine whether module originates in current package
 -- or in an external package.
 data SrcPath
-  = SrcExternal FilePath
-  | SrcLocal
+    = SrcExternal FilePath
+    | SrcLocal
 
-type SrcMap = Map GHC.Module SrcPath
+type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath)
+
+mkSrcMap :: Map GHC.Module SrcPath -> SrcMap
+mkSrcMap srcs = (srcs, Map.mapKeys GHC.moduleName srcs)
-- 
cgit v1.2.3


From b6e9968643bc0ab6c61289ecee7205e4d7bc421a Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 6 Jul 2015 17:26:49 +0200
Subject: Add short documentation for hyperlinker source map type.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs | 9 +++++++++
 1 file changed, 9 insertions(+)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
index c3954dc9..5f4dbc8c 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Types.hs
@@ -70,6 +70,15 @@ data SrcPath
     = SrcExternal FilePath
     | SrcLocal
 
+-- | Mapping from modules to cross-package source paths.
+--
+-- This mapping is actually a pair of maps instead of just one map. The reason
+-- for this is because when hyperlinking modules in import lists we have no
+-- 'GHC.Module' available. On the other hand, we can't just use map with
+-- 'GHC.ModuleName' as indices because certain modules may have common name
+-- but originate in different packages. Hence, we use both /rich/ and /poor/
+-- versions, where the /poor/ is just projection of /rich/ one cached in pair
+-- for better performance.
 type SrcMap = (Map GHC.Module SrcPath, Map GHC.ModuleName SrcPath)
 
 mkSrcMap :: Map GHC.Module SrcPath -> SrcMap
-- 
cgit v1.2.3


From 0e1cad7c38ed1a771794d9332233f784a52d2c1a Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Mon, 6 Jul 2015 18:07:20 +0200
Subject: Fix bug with module name being hyperlinked to `Prelude`.

---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs         | 7 ++++---
 haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs | 1 +
 2 files changed, 5 insertions(+), 3 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 28fdc3f5..71b73663 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -146,7 +146,7 @@ decls (group, _, _, _) = concatMap ($ group)
 -- import lists.
 imports :: GHC.RenamedSource -> DetailsMap
 imports src@(_, imps, _, _) =
-    everything (<|>) ie src ++ map (imp . GHC.unLoc) imps
+    everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps
   where
     ie term = case cast term of
         (Just (GHC.IEVar v)) -> pure $ var v
@@ -156,9 +156,10 @@ imports src@(_, imps, _, _) =
         _ -> empty
     typ (GHC.L sspan name) = (sspan, RtkType name)
     var (GHC.L sspan name) = (sspan, RtkVar name)
-    imp idecl =
+    imp idecl | not . GHC.ideclImplicit $ idecl =
         let (GHC.L sspan name) = GHC.ideclName idecl
-        in (sspan, RtkModule name)
+        in Just (sspan, RtkModule name)
+    imp _ = Nothing
 
 -- | Check whether token stream span matches GHC source span.
 --
diff --git a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
index a76bdcdc..8cd2690e 100644
--- a/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
+++ b/haddock-api/test/Haddock/Backends/Hyperlinker/ParserSpec.hs
@@ -5,6 +5,7 @@ import Test.Hspec
 import Test.QuickCheck
 
 import Haddock.Backends.Hyperlinker.Parser
+import Haddock.Backends.Hyperlinker.Types
 
 
 main :: IO ()
-- 
cgit v1.2.3


From 7e8330944666064f12f067970de2936b58589785 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Sat, 25 Jul 2015 18:54:30 +0200
Subject: Add some utility definitions for generating line anchors.

---
 .../src/Haddock/Backends/Hyperlinker/Utils.hs      | 25 ++++++++++++++++++++--
 1 file changed, 23 insertions(+), 2 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
index db2bfc76..9de4a03d 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
@@ -1,13 +1,18 @@
 module Haddock.Backends.Hyperlinker.Utils
     ( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile'
-    , hypSrcModuleUrl, hypSrcModuleUrl', hypSrcNameUrl, hypSrcModuleNameUrl
-    , hypSrcModuleUrlFormat, hypSrcModuleNameUrlFormat,
+    , hypSrcModuleUrl, hypSrcModuleUrl'
+    , hypSrcNameUrl
+    , hypSrcLineUrl
+    , hypSrcModuleNameUrl, hypSrcModuleLineUrl
+    , hypSrcModuleUrlFormat
+    , hypSrcModuleNameUrlFormat, hypSrcModuleLineUrlFormat
     ) where
 
 
 import Haddock.Backends.Xhtml.Utils
 
 import GHC
+import FastString
 import System.FilePath.Posix ((</>))
 
 
@@ -31,17 +36,33 @@ hypSrcNameUrl :: Name -> String
 hypSrcNameUrl name = spliceURL
     Nothing Nothing (Just name) Nothing nameFormat
 
+hypSrcLineUrl :: Int -> String
+hypSrcLineUrl line = spliceURL
+    Nothing Nothing Nothing (Just spn) lineFormat
+  where
+    loc = mkSrcLoc nilFS line 1
+    spn = mkSrcSpan loc loc
+
 hypSrcModuleNameUrl :: Module -> Name -> String
 hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name
 
+hypSrcModuleLineUrl :: Module -> Int -> String
+hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line
+
 hypSrcModuleUrlFormat :: String
 hypSrcModuleUrlFormat = hypSrcDir </> moduleFormat
 
 hypSrcModuleNameUrlFormat :: String
 hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat
 
+hypSrcModuleLineUrlFormat :: String
+hypSrcModuleLineUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ lineFormat
+
 moduleFormat :: String
 moduleFormat = "%{MODULE}.html"
 
 nameFormat :: String
 nameFormat = "%{NAME}"
+
+lineFormat :: String
+lineFormat = "line-%{LINE}"
-- 
cgit v1.2.3


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(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

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


From e9d61b79faf40200d8f9806d83a05ece272cd7d3 Mon Sep 17 00:00:00 2001
From: Łukasz Hanuszczak <lukasz.hanuszczak@gmail.com>
Date: Fri, 10 Jul 2015 11:42:18 +0200
Subject: Move SYB utilities to standalone module.

---
 haddock-api/haddock-api.cabal                      |  1 +
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 15 +------------
 haddock-api/src/Haddock/Syb.hs                     | 26 ++++++++++++++++++++++
 haddock.cabal                                      |  1 +
 4 files changed, 29 insertions(+), 14 deletions(-)
 create mode 100644 haddock-api/src/Haddock/Syb.hs

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index 4db05de8..bfdb2179 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -94,6 +94,7 @@ library
     Haddock.InterfaceFile
     Haddock.Options
     Haddock.GhcUtils
+    Haddock.Syb
     Haddock.Convert
     Paths_haddock_api
 
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 71b73663..5eca973e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -6,6 +6,7 @@
 module Haddock.Backends.Hyperlinker.Ast (enrich) where
 
 
+import Haddock.Syb
 import Haddock.Backends.Hyperlinker.Types
 
 import qualified GHC
@@ -179,17 +180,3 @@ matches tspan (GHC.RealSrcSpan aspan)
     saspan = (GHC.srcSpanStartLine aspan, GHC.srcSpanStartCol aspan)
     easpan = (GHC.srcSpanEndLine aspan, GHC.srcSpanEndCol aspan)
 matches _ _ = False
-
--- | Perform a query on each level of a tree.
---
--- This is stolen directly from SYB package and copied here to not introduce
--- additional dependencies.
-everything :: (r -> r -> r) -> (forall a. Data a => a -> r)
-           -> (forall a. Data a => a -> r)
-everything k f x = foldl k (f x) (gmapQ (everything k f) x)
-
--- | Combine two queries into one using alternative combinator.
-combine :: Alternative f => (forall a. Data a => a -> f r)
-                         -> (forall a. Data a => a -> f r)
-                         -> (forall a. Data a => a -> f r)
-combine f g x = f x <|> g x
diff --git a/haddock-api/src/Haddock/Syb.hs b/haddock-api/src/Haddock/Syb.hs
new file mode 100644
index 00000000..dd7ffc1b
--- /dev/null
+++ b/haddock-api/src/Haddock/Syb.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE Rank2Types #-}
+
+
+module Haddock.Syb
+    ( everything
+    , combine
+    ) where
+
+
+import Data.Data
+import Control.Applicative
+
+
+-- | Perform a query on each level of a tree.
+--
+-- This is stolen directly from SYB package and copied here to not introduce
+-- additional dependencies.
+everything :: (r -> r -> r) -> (forall a. Data a => a -> r)
+           -> (forall a. Data a => a -> r)
+everything k f x = foldl k (f x) (gmapQ (everything k f) x)
+
+-- | Combine two queries into one using alternative combinator.
+combine :: Alternative f => (forall a. Data a => a -> f r)
+                         -> (forall a. Data a => a -> f r)
+                         -> (forall a. Data a => a -> f r)
+combine f g x = f x <|> g x
diff --git a/haddock.cabal b/haddock.cabal
index 27ae8967..b0c6c34f 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -116,6 +116,7 @@ executable haddock
       Haddock.InterfaceFile
       Haddock.Options
       Haddock.GhcUtils
+      Haddock.Syb
       Haddock.Convert
   else
     build-depends:  haddock-api == 2.16.*
-- 
cgit v1.2.3


From cb89336401b74b274b81b28079e6906e926409c4 Mon Sep 17 00:00:00 2001
From: Matthew Pickering <matthewtpickering@gmail.com>
Date: Mon, 14 Dec 2015 18:17:00 +0000
Subject: Changes to compile with 8.0

---
 haddock-api/src/Haddock.hs                         |  2 +-
 haddock-api/src/Haddock/Backends/Hoogle.hs         | 10 +--
 .../src/Haddock/Backends/Hyperlinker/Ast.hs        | 24 ++++---
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs     | 24 ++++---
 haddock-api/src/Haddock/Convert.hs                 | 12 +---
 haddock-api/src/Haddock/Interface/Rename.hs        |  4 +-
 haddock-api/src/Haddock/Interface/Specialize.hs    | 78 +++++++++++-----------
 haddock-api/src/Haddock/Types.hs                   | 10 +--
 8 files changed, 82 insertions(+), 82 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index ef873500..70cdf8a3 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -269,7 +269,7 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
       (Map.map SrcExternal extSrcMap)
       (Map.fromList [ (ifaceMod iface, SrcLocal) | iface <- ifaces ])
 
-    pkgSrcMap = Map.mapKeys modulePackageKey extSrcMap
+    pkgSrcMap = Map.mapKeys moduleUnitId extSrcMap
     pkgSrcMap'
       | Flag_HyperlinkedSource `elem` flags =
           Map.insert pkgKey hypSrcModuleNameUrlFormat pkgSrcMap
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index a8882fe2..1adcddfc 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -122,8 +122,8 @@ ppExport dflags ExportDecl { expItemDecl    = L _ decl
         f (TyClD d@DataDecl{})  = ppData dflags d subdocs
         f (TyClD d@SynDecl{})   = ppSynonym dflags d
         f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs
-        f (ForD (ForeignImport name typ _ _)) = pp_sig dflags [name] (hsSigType typ)
-        f (ForD (ForeignExport name typ _ _)) = pp_sig dflags [name] (hsSigType typ)
+        f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]
+        f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)]
         f (SigD sig) = ppSig dflags sig ++ ppFixities
         f _ = []
 
@@ -157,10 +157,10 @@ ppClass :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
 ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) :  ppMethods
     where
 
-        ppMethods = concat . map (ppSig' . unL . add_ctxt) $ tcdSigs decl
-        ppSig' = flip (ppSigWithDoc dflags) subdocs . addContext
+        ppMethods = concat . map (ppSig' . unLoc . add_ctxt) $ tcdSigs decl
+        ppSig' = flip (ppSigWithDoc dflags) subdocs
 
-        add_ctxt = addClassContext (tcdName x) (tyClDeclTyVars x)
+        add_ctxt = addClassContext (tcdName decl) (tyClDeclTyVars decl)
 
         ppTyFams
             | null $ tcdATs decl = ""
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 5eca973e..060534bf 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
 
 
 module Haddock.Backends.Hyperlinker.Ast (enrich) where
@@ -10,6 +11,7 @@ import Haddock.Syb
 import Haddock.Backends.Hyperlinker.Types
 
 import qualified GHC
+import qualified FieldLabel as GHC
 
 import Control.Applicative
 import Data.Data
@@ -56,8 +58,8 @@ variables =
   where
     var term = case cast term of
         (Just (GHC.L sspan (GHC.HsVar name))) ->
-            pure (sspan, RtkVar name)
-        (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _))) ->
+            pure (sspan, RtkVar (GHC.unLoc name))
+        (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) ->
             pure (sspan, RtkVar name)
         _ -> empty
     rec term = case cast term of
@@ -72,7 +74,7 @@ types =
   where
     ty term = case cast term of
         (Just (GHC.L sspan (GHC.HsTyVar name))) ->
-            pure (sspan, RtkType name)
+            pure (sspan, RtkType (GHC.unLoc name))
         _ -> empty
 
 -- | Obtain details map for identifier bindings.
@@ -85,12 +87,12 @@ binds =
     everything (<|>) (fun `combine` pat `combine` tvar)
   where
     fun term = case cast term of
-        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name)) ->
+        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name)) ->
             pure (sspan, RtkBind name)
         _ -> empty
     pat term = case cast term of
         (Just (GHC.L sspan (GHC.VarPat name))) ->
-            pure (sspan, RtkBind name)
+            pure (sspan, RtkBind (GHC.unLoc name))
         (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
             [(sspan, RtkVar name)] ++ everything (<|>) rec recs
         (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) ->
@@ -102,7 +104,7 @@ binds =
         _ -> empty
     tvar term = case cast term of
         (Just (GHC.L sspan (GHC.UserTyVar name))) ->
-            pure (sspan, RtkBind name)
+            pure (sspan, RtkBind (GHC.unLoc name))
         (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) ->
             pure (sspan, RtkBind name)
         _ -> empty
@@ -121,7 +123,7 @@ decls (group, _, _, _) = concatMap ($ group)
         GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam
         GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs
     fun term = case cast term of
-        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ _ :: GHC.HsBind GHC.Name))
+        (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.Name))
             | GHC.isExternalName name -> pure (sspan, RtkDecl name)
         _ -> empty
     con term = case cast term of
@@ -134,9 +136,10 @@ decls (group, _, _, _) = concatMap ($ group)
             pure . tyref $ GHC.tfe_tycon eqn
         _ -> empty
     fld term = case cast term of
-        Just field -> map decl $ GHC.cd_fld_names field
+        Just (field :: GHC.ConDeclField GHC.Name)
+          -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field
         Nothing -> empty
-    sig (GHC.L _ (GHC.TypeSig names _ _)) = map decl names
+    sig (GHC.L _ (GHC.TypeSig names _)) = map decl names
     sig _ = []
     decl (GHC.L sspan name) = (sspan, RtkDecl name)
     tyref (GHC.L sspan name) = (sspan, RtkType name)
@@ -153,7 +156,8 @@ imports src@(_, imps, _, _) =
         (Just (GHC.IEVar v)) -> pure $ var v
         (Just (GHC.IEThingAbs t)) -> pure $ typ t
         (Just (GHC.IEThingAll t)) -> pure $ typ t
-        (Just (GHC.IEThingWith t vs)) -> [typ t] ++ map var vs
+        (Just (GHC.IEThingWith t _ vs _fls)) ->
+          [typ t] ++ map var vs
         _ -> empty
     typ (GHC.L sspan name) = (sspan, RtkType name)
     var (GHC.L sspan name) = (sspan, RtkVar name)
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 124debfb..ae1905bf 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -270,24 +270,25 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
   ) <+>
 
   ppFamDeclBinderWithVars summary d <+>
-
-  (case result of
-    NoSig               -> noHtml
-    KindSig kind        -> dcolon unicode  <+> ppLKind unicode qual kind
-    TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
-  ) <+>
+  ppResultSig result unicode qual <+>
 
   (case injectivity of
      Nothing                   -> noHtml
      Just (L _ injectivityAnn) -> ppInjectivityAnn unicode qual injectivityAnn
   )
 
+ppResultSig :: FamilyResultSig DocName -> Unicode -> Qualification -> Html
+ppResultSig result unicode qual = case result of
+    NoSig               -> noHtml
+    KindSig kind        -> dcolon unicode  <+> ppLKind unicode qual kind
+    TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr
+
 ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocName
                      -> Html
 ppPseudoFamilyHeader unicode qual (PseudoFamilyDecl { .. }) =
     ppFamilyInfo True pfdInfo <+>
     ppAppNameTypes (unLoc pfdLName) [] (map unLoc pfdTyVars) unicode qual <+>
-    ppFamilyKind unicode qual pfdKindSig
+    ppResultSig (unLoc pfdKindSig) unicode qual
 
 ppInjectivityAnn :: Bool -> Qualification -> InjectivityAnn DocName -> Html
 ppInjectivityAnn unicode qual (InjectivityAnn lhs rhs) =
@@ -530,7 +531,7 @@ ppClassDecl summary links instances fixities loc d subdocs
     minimalBit = case [ s | MinimalSig _ (L _ s) <- sigs ] of
       -- Miminal complete definition = every shown method
       And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] ==
-                   sort [getName n | TypeSig ns _ _ <- sigs, L _ n <- ns]
+                   sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns]
         -> noHtml
 
       -- Minimal complete definition = the only shown method
@@ -612,9 +613,12 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification
               -> [Sig DocName]
               -> [Html]
 ppInstanceSigs links splice unicode qual sigs = do
-    TypeSig lnames (L loc typ) _ <- sigs
+    TypeSig lnames typ <- sigs
     let names = map unLoc lnames
-    return $ ppSimpleSig links splice unicode qual loc names typ
+        L loc rtyp = get_type typ
+    return $ ppSimpleSig links splice unicode qual loc names rtyp
+    where
+      get_type = hswc_body . hsib_body
 
 
 lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 664598ab..4a7ad162 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -100,14 +100,8 @@ tyThingToLHsDecl t = case t of
     (synifySigWcType ImplicitizeForAll (dataConUserType dc)))
 
   AConLike (PatSynCon ps) ->
-      let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps
-          qtvs = univ_tvs ++ ex_tvs
-          ty = mkFunTys arg_tys res_ty
-      in allOK . SigD $ PatSynSig (synifyName ps)
-                          (Implicit, synifyTyVars qtvs)
-                          (synifyCtx req_theta)
-                          (synifyCtx prov_theta)
-                          (synifyType WithinType ty)
+    allOK . SigD $ PatSynSig (synifyName ps) (synifySigType WithinType
+                                  (patSynType ps))
   where
     withErrs e x = return (e, x)
     allOK x = return (mempty, x)
@@ -457,5 +451,5 @@ synifyFamInst fi opaque = do
         return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi
     ityp (DataFamilyInst c) =
         DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c
-    (ks,ts) = partitionInvisibles (classTyCon cls) id $ fi_tys fi
+    (ks,ts) = partitionInvisibles (famInstTyCon fi) id $ fi_tys fi
     synifyTypes = map (unLoc. synifyType WithinType)
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index e3a5a7d5..859afe6e 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -294,7 +294,7 @@ renameInstHead InstHead {..} = do
   itype <- case ihdInstType of
     ClassInst { .. } -> ClassInst
         <$> mapM renameType clsiCtx
-        <*> renameLTyVarBndrs clsiTyVars
+        <*> renameLHsQTyVars clsiTyVars
         <*> mapM renameSig clsiSigs
         <*> mapM renamePseudoFamilyDecl clsiAssocTys
     TypeInst  ts -> TypeInst  <$> traverse renameType ts
@@ -390,7 +390,7 @@ renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) =  PseudoFamilyDecl
     <$> renameFamilyInfo pfdInfo
     <*> renameL pfdLName
     <*> mapM renameLType pfdTyVars
-    <*> renameMaybeLKind pfdKindSig
+    <*> renameFamilyResultSig pfdKindSig
 
 
 renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName)
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index d6466570..e9b9c60a 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -36,7 +36,7 @@ specialize :: (Eq name, Typeable name)
 specialize name details =
     everywhere $ mkT step
   where
-    step (HsTyVar name') | name == name' = details
+    step (HsTyVar (L _ name')) | name == name' = details
     step typ = typ
 
 
@@ -56,18 +56,18 @@ specialize' = flip $ foldr (uncurry specialize)
 -- length of type list should be the same as the number of binders.
 specializeTyVarBndrs :: (Eq name, Typeable name, DataId name)
                      => Data a
-                     => LHsTyVarBndrs name -> [HsType name]
+                     => LHsQTyVars name -> [HsType name]
                      -> a -> a
 specializeTyVarBndrs bndrs typs =
     specialize' $ zip bndrs' typs
   where
-    bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs
-    bname (UserTyVar name) = name
+    bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs
+    bname (UserTyVar (L _ name)) = name
     bname (KindedTyVar (L _ name) _) = name
 
 
 specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name)
-                           => LHsTyVarBndrs name -> [HsType name]
+                           => LHsQTyVars name -> [HsType name]
                            -> PseudoFamilyDecl name
                            -> PseudoFamilyDecl name
 specializePseudoFamilyDecl bndrs typs decl =
@@ -76,14 +76,17 @@ specializePseudoFamilyDecl bndrs typs decl =
     specializeTyVars = specializeTyVarBndrs bndrs typs
 
 
-specializeSig :: (Eq name, Typeable name, DataId name, SetName name)
-              => LHsTyVarBndrs name -> [HsType name]
+specializeSig :: forall name . (Eq name, Typeable name, DataId name, SetName name)
+              => LHsQTyVars name -> [HsType name]
               -> Sig name
               -> Sig name
-specializeSig bndrs typs (TypeSig lnames (L loc typ) prn) =
-    TypeSig lnames (L loc typ') prn
+specializeSig bndrs typs (TypeSig lnames typ) =
+    TypeSig lnames (typ { hsib_body = (hsib_body typ) { hswc_body = noLoc typ'}})
   where
-    typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs typ
+    true_type :: HsType name
+    true_type = unLoc (hswc_body (hsib_body typ))
+    typ' :: HsType name
+    typ' = rename fv . sugar $ specializeTyVarBndrs bndrs typs true_type
     fv = foldr Set.union Set.empty . map freeVariables $ typs
 specializeSig _ _ sig = sig
 
@@ -120,7 +123,7 @@ sugar =
 
 
 sugarLists :: NamedThing name => HsType name -> HsType name
-sugarLists (HsAppTy (L _ (HsTyVar name)) ltyp)
+sugarLists (HsAppTy (L _ (HsTyVar (L _ name))) ltyp)
     | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
   where
     name' = getName name
@@ -134,7 +137,7 @@ sugarTuples typ =
   where
     aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
     aux apps (HsParTy (L _ typ')) = aux apps typ'
-    aux apps (HsTyVar name)
+    aux apps (HsTyVar (L _ name))
         | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
       where
         name' = getName name
@@ -146,8 +149,8 @@ sugarTuples typ =
 
 
 sugarOperators :: NamedThing name => HsType name -> HsType name
-sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar name)) la)) lb)
-    | isSymOcc $ getOccName name' = mkHsOpTy la (L loc name) lb
+sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar (L l name))) la)) lb)
+    | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
     | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
   where
     name' = getName name
@@ -219,13 +222,13 @@ freeVariables =
     everythingWithState Set.empty Set.union query
   where
     query term ctx = case cast term :: Maybe (HsType name) of
-        Just (HsForAllTy _ _ bndrs _ _) ->
+        Just (HsForAllTy bndrs _) ->
             (Set.empty, Set.union ctx (bndrsNames bndrs))
-        Just (HsTyVar name)
+        Just (HsTyVar (L _ name))
             | getName name `Set.member` ctx -> (Set.empty, ctx)
             | otherwise -> (Set.singleton $ getNameRep name, ctx)
         _ -> (Set.empty, ctx)
-    bndrsNames = Set.fromList . map (getName . tyVarName . unLoc) . hsq_tvs
+    bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)
 
 
 -- | Make given type visually unambiguous.
@@ -256,26 +259,26 @@ data RenameEnv name = RenameEnv
 
 
 renameType :: SetName name => HsType name -> Rename name (HsType name)
-renameType (HsForAllTy ex mspan lbndrs lctx lt) = rebind lbndrs $ \lbndrs' ->
+renameType (HsForAllTy bndrs lt) = rebind bndrs $ \bndrs' ->
     HsForAllTy
-        <$> pure ex
-        <*> pure mspan
-        <*> pure lbndrs'
-        <*> located renameContext lctx
+        <$> pure bndrs'
         <*> renameLType lt
-renameType (HsTyVar name) = HsTyVar <$> renameName name
+renameType (HsQualTy lctxt lt) =
+  HsQualTy
+        <$> located renameContext lctxt
+        <*> renameLType lt
+renameType (HsTyVar name) = HsTyVar <$> located renameName name
 renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la
 renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
 renameType (HsListTy lt) = HsListTy <$> renameLType lt
 renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
 renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
 renameType (HsOpTy la lop lb) =
-    HsOpTy <$> renameLType la <*> renameLTyOp lop <*> renameLType lb
+    HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb
 renameType (HsParTy lt) = HsParTy <$> renameLType lt
 renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt
 renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb
 renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk
-renameType t@(HsQuasiQuoteTy _) = pure t
 renameType t@(HsSpliceTy _ _) = pure t
 renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc
 renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
@@ -286,9 +289,7 @@ renameType (HsExplicitListTy ph ltys) =
 renameType (HsExplicitTupleTy phs ltys) =
     HsExplicitTupleTy phs <$> renameLTypes ltys
 renameType t@(HsTyLit _) = pure t
-renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t
-renameType HsWildcardTy = pure HsWildcardTy
-renameType (HsNamedWildcardTy name) = HsNamedWildcardTy <$> renameName name
+renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
 
 
 renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
@@ -302,21 +303,20 @@ renameLTypes = mapM renameLType
 renameContext :: SetName name => HsContext name -> Rename name (HsContext name)
 renameContext = renameLTypes
 
-
+{-
 renameLTyOp :: SetName name => LHsTyOp name -> Rename name (LHsTyOp name)
 renameLTyOp (wrap, lname) = (,) wrap <$> located renameName lname
+-}
 
 
 renameName :: SetName name => name -> Rename name name
 renameName name = do
     RenameEnv { rneCtx = ctx } <- ask
-    pure $ case Map.lookup (getName name) ctx of
-        Just name' -> name'
-        Nothing -> name
+    pure $ fromMaybe name (Map.lookup (getName name) ctx)
 
 
 rebind :: SetName name
-       => LHsTyVarBndrs name -> (LHsTyVarBndrs name -> Rename name a)
+       => [LHsTyVarBndr name] -> ([LHsTyVarBndr name] -> Rename name a)
        -> Rename name a
 rebind lbndrs action = do
     (lbndrs', env') <- runState (rebindLTyVarBndrs lbndrs) <$> ask
@@ -324,16 +324,14 @@ rebind lbndrs action = do
 
 
 rebindLTyVarBndrs :: SetName name
-                  => LHsTyVarBndrs name -> Rebind name (LHsTyVarBndrs name)
-rebindLTyVarBndrs lbndrs = do
-    tys' <- mapM (located rebindTyVarBndr) $ hsq_tvs lbndrs
-    pure $ lbndrs { hsq_tvs = tys' }
+                  => [LHsTyVarBndr name] -> Rebind name [LHsTyVarBndr name]
+rebindLTyVarBndrs lbndrs = mapM (located rebindTyVarBndr) lbndrs
 
 
 rebindTyVarBndr :: SetName name
                 => HsTyVarBndr name -> Rebind name (HsTyVarBndr name)
-rebindTyVarBndr (UserTyVar name) =
-    UserTyVar <$> rebindName name
+rebindTyVarBndr (UserTyVar (L l name)) =
+    UserTyVar . L l <$> rebindName name
 rebindTyVarBndr (KindedTyVar name kinds) =
     KindedTyVar <$> located rebindName name <*> pure kinds
 
@@ -403,5 +401,5 @@ located f (L loc e) = L loc <$> f e
 
 
 tyVarName :: HsTyVarBndr name -> name
-tyVarName (UserTyVar name) = name
+tyVarName (UserTyVar name) = unLoc name
 tyVarName (KindedTyVar (L _ name) _) = name
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index e07f55f1..6bc00f63 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -326,7 +326,7 @@ instance SetName DocName where
 data InstType name
   = ClassInst
       { clsiCtx :: [HsType name]
-      , clsiTyVars :: LHsTyVarBndrs name
+      , clsiTyVars :: LHsQTyVars name
       , clsiSigs :: [Sig name]
       , clsiAssocTys :: [PseudoFamilyDecl name]
       }
@@ -353,7 +353,7 @@ data PseudoFamilyDecl name = PseudoFamilyDecl
     { pfdInfo :: FamilyInfo name
     , pfdLName :: Located name
     , pfdTyVars :: [LHsType name]
-    , pfdKindSig :: Maybe (LHsKind name)
+    , pfdKindSig :: LFamilyResultSig name
     }
 
 
@@ -361,14 +361,14 @@ mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name
 mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl
     { pfdInfo = fdInfo
     , pfdLName = fdLName
-    , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_tvs fdTyVars ]
-    , pfdKindSig = fdKindSig
+    , pfdTyVars = [ L loc (mkType bndr) | L loc bndr <- hsq_explicit fdTyVars ]
+    , pfdKindSig = fdResultSig
     }
   where
     mkType (KindedTyVar (L loc name) lkind) =
         HsKindSig tvar lkind
       where
-        tvar = L loc (HsTyVar name)
+        tvar = L loc (HsTyVar (L loc name))
     mkType (UserTyVar name) = HsTyVar name
 
 
-- 
cgit v1.2.3


From a89c8083c2c08d9cd9607a91d6ea11420bd72a70 Mon Sep 17 00:00:00 2001
From: Matthew Pickering <matthewtpickering@gmail.com>
Date: Mon, 14 Dec 2015 18:47:12 +0000
Subject: Warnings

---
 haddock-api/src/Haddock/Backends/Hoogle.hs           |  2 --
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs  |  1 -
 haddock-api/src/Haddock/Backends/LaTeX.hs            |  3 +--
 haddock-api/src/Haddock/Backends/Xhtml/Decl.hs       |  9 +--------
 haddock-api/src/Haddock/Convert.hs                   |  3 +--
 haddock-api/src/Haddock/Interface/AttachInstances.hs |  2 --
 haddock-api/src/Haddock/Interface/LexParseRn.hs      |  1 -
 haddock-api/src/Haddock/Interface/Specialize.hs      | 11 ++++++-----
 8 files changed, 9 insertions(+), 23 deletions(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index 1adcddfc..a9bc9a8b 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -21,7 +21,6 @@ import Haddock.GhcUtils
 import Haddock.Types hiding (Version)
 import Haddock.Utils hiding (out)
 
-import Bag
 import GHC
 import Outputable
 import NameSet
@@ -140,7 +139,6 @@ ppSigWithDoc dflags (TypeSig names sig) subdocs
         getDoc :: Located Name -> [Documentation Name]
         getDoc n = maybe [] (return . fst) (lookup (unL n) subdocs)
 
-        typ = unL (hsSigWcType sig)
 ppSigWithDoc _ _ _ = []
 
 ppSig :: DynFlags -> Sig Name -> [String]
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 060534bf..1f396df5 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -11,7 +11,6 @@ import Haddock.Syb
 import Haddock.Backends.Hyperlinker.Types
 
 import qualified GHC
-import qualified FieldLabel as GHC
 
 import Control.Applicative
 import Data.Data
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 75a4edba..ab6bb41c 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -25,10 +25,9 @@ import qualified Pretty
 import GHC
 import OccName
 import Name                 ( nameOccName )
-import RdrName              ( rdrNameOcc, mkRdrUnqual )
+import RdrName              ( rdrNameOcc )
 import FastString           ( unpackFS, unpackLitString, zString )
 import Outputable           ( panic)
-import PrelNames            ( mkUnboundName )
 
 import qualified Data.Map as Map
 import System.Directory
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index ae1905bf..d27cb2bc 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -38,8 +38,7 @@ import GHC
 import GHC.Exts
 import Name
 import BooleanFormula
-import RdrName ( rdrNameOcc, mkRdrUnqual )
-import PrelNames            ( mkUnboundName )
+import RdrName ( rdrNameOcc )
 
 ppDecl :: Bool -> LinksInfo -> LHsDecl DocName
        -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)]
@@ -246,12 +245,6 @@ ppFamilyInfo assoc DataFamily
 ppFamilyInfo _ (ClosedTypeFamily _) = keyword "type family"
 
 
-ppFamilyKind :: Unicode -> Qualification -> Maybe (LHsKind DocName) -> Html
-ppFamilyKind unicode qual (Just kind) =
-    dcolon unicode <+> ppLKind unicode qual kind
-ppFamilyKind _ _ Nothing = noHtml
-
-
 ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName
               -> Unicode -> Qualification -> Html
 ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info
diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs
index 4a7ad162..bc293731 100644
--- a/haddock-api/src/Haddock/Convert.hs
+++ b/haddock-api/src/Haddock/Convert.hs
@@ -22,14 +22,13 @@ import Class
 import CoAxiom
 import ConLike
 import Data.Either (lefts, rights)
-import Data.List( partition )
 import DataCon
 import FamInstEnv
 import HsSyn
 import Name
 import RdrName ( mkVarUnqual )
 import PatSyn
-import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )
+import SrcLoc ( Located, noLoc, unLoc )
 import TcType ( tcSplitSigmaTy )
 import TyCon
 import Type
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 56382341..faf043aa 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -33,7 +33,6 @@ import FamInstEnv
 import FastString
 import GHC
 import GhcMonad (withSession)
-import Id
 import InstEnv
 import MonadUtils (liftIO)
 import Name
@@ -41,7 +40,6 @@ import Outputable (text, sep, (<+>))
 import PrelNames
 import SrcLoc
 import TcRnDriver (tcRnGetInfo)
-import TcType (tcSplitSigmaTy)
 import TyCon
 import TyCoRep
 import TysPrim( funTyCon )
diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs
index 0f6add36..661bd6be 100644
--- a/haddock-api/src/Haddock/Interface/LexParseRn.hs
+++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs
@@ -28,7 +28,6 @@ import Haddock.Interface.ParseModuleHeader
 import Haddock.Parser
 import Haddock.Types
 import Name
-import RdrHsSyn   ( setRdrNameSpace )
 import Outputable ( showPpr )
 import RdrName
 import RnEnv (dataTcOccs)
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index e9b9c60a..ab719fe8 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -54,7 +54,7 @@ specialize' = flip $ foldr (uncurry specialize)
 --
 -- Again, it is just a convenience function around 'specialize'. Note that
 -- length of type list should be the same as the number of binders.
-specializeTyVarBndrs :: (Eq name, Typeable name, DataId name)
+specializeTyVarBndrs :: (Eq name, DataId name)
                      => Data a
                      => LHsQTyVars name -> [HsType name]
                      -> a -> a
@@ -66,7 +66,7 @@ specializeTyVarBndrs bndrs typs =
     bname (KindedTyVar (L _ name) _) = name
 
 
-specializePseudoFamilyDecl :: (Eq name, Typeable name, DataId name)
+specializePseudoFamilyDecl :: (Eq name, DataId name)
                            => LHsQTyVars name -> [HsType name]
                            -> PseudoFamilyDecl name
                            -> PseudoFamilyDecl name
@@ -76,7 +76,7 @@ specializePseudoFamilyDecl bndrs typs decl =
     specializeTyVars = specializeTyVarBndrs bndrs typs
 
 
-specializeSig :: forall name . (Eq name, Typeable name, DataId name, SetName name)
+specializeSig :: forall name . (Eq name, DataId name, SetName name)
               => LHsQTyVars name -> [HsType name]
               -> Sig name
               -> Sig name
@@ -93,7 +93,7 @@ specializeSig _ _ sig = sig
 
 -- | Make all details of instance head (signatures, associated types)
 -- specialized to that particular instance type.
-specializeInstHead :: (Eq name, Typeable name, DataId name, SetName name)
+specializeInstHead :: (Eq name, DataId name, SetName name)
                    => InstHead name -> InstHead name
 specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
     ihd { ihdInstType = instType' }
@@ -149,7 +149,7 @@ sugarTuples typ =
 
 
 sugarOperators :: NamedThing name => HsType name -> HsType name
-sugarOperators (HsAppTy (L _ (HsAppTy (L loc (HsTyVar (L l name))) la)) lb)
+sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar (L l name))) la)) lb)
     | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
     | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
   where
@@ -290,6 +290,7 @@ renameType (HsExplicitTupleTy phs ltys) =
     HsExplicitTupleTy phs <$> renameLTypes ltys
 renameType t@(HsTyLit _) = pure t
 renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
+renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming"
 
 
 renameLType :: SetName name => LHsType name -> Rename name (LHsType name)
-- 
cgit v1.2.3


From fa03f80d76f1511a811a0209ea7a6a8b6c58704f Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Wed, 16 Dec 2015 23:32:38 +0100
Subject: Fix Hyperlinker

GHC.con_names is now GHC.getConNames
---
 haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'haddock-api/src/Haddock/Backends/Hyperlinker')

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 1f396df5..e8baae88 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -127,7 +127,7 @@ decls (group, _, _, _) = concatMap ($ group)
         _ -> empty
     con term = case cast term of
         (Just cdcl) ->
-            map decl (GHC.con_names cdcl) ++ everything (<|>) fld cdcl
+            map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl
         Nothing -> empty
     ins term = case cast term of
         (Just (GHC.DataFamInstD inst)) -> pure . tyref $ GHC.dfid_tycon inst
-- 
cgit v1.2.3