aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
authorŁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-06-08 00:13:12 +0200
committerŁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-06-30 22:37:48 +0200
commit70656933ca6935bde0a00310f37440e02c3f21ff (patch)
tree872218122b3acf9d0040cb11da597f11edfc994f /haddock-api
parent666af8d2f29c05d22bb5930d115c42509528bb90 (diff)
Add support for binding token recognition.
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs20
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs1
2 files changed, 20 insertions, 1 deletions
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"]