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