haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74

{-# LANGUAGE RankNTypes #-}

module Haddock.Backends.Hyperlinker.Ast
    ( enrich
    , RichToken(..), RichTokenType(..), TokenDetails(..)
    ) where

import Haddock.Backends.Hyperlinker.Parser

import qualified GHC

import Control.Applicative
import Data.Data
import Data.Maybe

data RichToken = RichToken
    { rtkToken :: Token
    , rtkDetails :: Maybe TokenDetails
    }

data TokenDetails = TokenDetails
    { rtkType :: RichTokenType
    , rtkName :: GHC.Name
    }

data RichTokenType
    = RtkVar
    | RtkType

enrich :: GHC.RenamedSource -> [Token] -> [RichToken]
enrich src =
    map $ \token -> RichToken
        { rtkToken = token
        , rtkDetails = lookupBySpan (tkSpan token) detailsMap
        }
  where
    detailsMap = variables src ++ types src

type DetailsMap = [(GHC.SrcSpan, TokenDetails)]

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)

variables :: GHC.RenamedSource -> DetailsMap
variables =
    everything (<|>) var
  where
    var term = case cast term of
        (Just (GHC.L sspan (GHC.HsVar name))) ->
            pure (sspan, TokenDetails RtkVar name)
        _ -> empty

types :: GHC.RenamedSource -> DetailsMap
types =
    everything (<|>) ty
  where
    ty term = case cast term of
        (Just (GHC.L sspan (GHC.HsTyVar name))) ->
            pure (sspan, TokenDetails RtkType name)
        _ -> 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.srcSpanEndCol aspan
matches _ _ = False