diff options
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 30 |
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 |