diff options
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs | 56 |
1 files changed, 46 insertions, 10 deletions
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 |