aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
authorŁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-06-06 20:04:02 +0200
committerŁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-06-30 22:37:48 +0200
commitd06a2b502e7909dff517a7c825e772b493bade24 (patch)
tree67dd74d97dde42b3f1789409c27801d8c3c0070c /haddock-api
parent74de0021815f0642a89017fbb1fbdf18064cb5ea (diff)
Create simple mechanism for associating tokens with AST names.
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs30
1 files changed, 23 insertions, 7 deletions
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