aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
blob: 12f37cedf9a7a93614753889ee29bd395a5a6aba (plain) (blame)
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
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}

module Haddock.Backends.Hyperlinker.Renderer (render) where


import Haddock.Backends.Hyperlinker.Types
import Haddock.Backends.Hyperlinker.Utils

import qualified Data.ByteString as BS

import GHC.Iface.Ext.Types
import GHC.Iface.Ext.Utils ( isEvidenceContext , emptyNodeInfo )
import GHC.Unit.Module ( ModuleName, moduleNameString )
import GHC.Types.Name   ( getOccString, isInternalName, Name, nameModule, nameUnique )
import GHC.Types.SrcLoc
import GHC.Types.Unique ( getKey )
import GHC.Utils.Encoding ( utf8DecodeByteString )

import System.FilePath.Posix ((</>))

import qualified Data.Map as Map
import qualified Data.Set as Set

import Text.XHtml (Html, HtmlAttr, (!))
import qualified Text.XHtml as Html


type StyleClass = String

-- | Produce the HTML corresponding to a hyperlinked Haskell source
render
  :: Maybe FilePath    -- ^ path to the CSS file
  -> Maybe FilePath    -- ^ path to the JS file
  -> SrcMaps            -- ^ Paths to sources
  -> HieAST PrintedType  -- ^ ASTs from @.hie@ files
  -> [Token]       -- ^ tokens to render
  -> Html
render mcss mjs srcs ast tokens = header mcss mjs <> body srcs ast tokens

body :: SrcMaps -> HieAST PrintedType -> [Token] -> Html
body srcs ast tokens = Html.body . Html.pre $ hypsrc
  where
    hypsrc = renderWithAst srcs ast tokens

header :: Maybe FilePath -> Maybe FilePath -> Html
header Nothing Nothing = Html.noHtml
header mcss mjs = Html.header $ css mcss <> js mjs
  where
    css Nothing = Html.noHtml
    css (Just cssFile) = Html.thelink Html.noHtml !
        [ Html.rel "stylesheet"
        , Html.thetype "text/css"
        , Html.href cssFile
        ]
    js Nothing = Html.noHtml
    js (Just scriptFile) = Html.script Html.noHtml !
        [ Html.thetype "text/javascript"
        , Html.src scriptFile
        ]


splitTokens :: HieAST PrintedType -> [Token] -> ([Token],[Token],[Token])
splitTokens ast toks = (before,during,after)
  where
    (before,rest) = span leftOf toks
    (during,after) = span inAst rest
    leftOf t = realSrcSpanEnd (tkSpan t) <= realSrcSpanStart nodeSp
    inAst t = nodeSp `containsSpan` tkSpan t
    nodeSp = nodeSpan ast

-- | Turn a list of tokens into hyperlinked sources, threading in relevant link
-- information from the 'HieAST'.
renderWithAst :: SrcMaps -> HieAST PrintedType -> [Token] -> Html
renderWithAst srcs Node{..} toks = anchored $ case toks of

    [tok] | nodeSpan == tkSpan tok -> richToken srcs nodeInfo tok

    -- NB: the GHC lexer lexes backquoted identifiers and parenthesized operators
    -- as multiple tokens.
    --
    --  * @a `elem` b@ turns into @[a, `, elem, `, b]@ (excluding space tokens)
    --  * @(+) 1 2@    turns into @[(, +, ), 1, 2]@    (excluding space tokens)
    --
    -- However, the HIE ast considers @`elem`@ and @(+)@ to be single nodes. In
    -- order to make sure these get hyperlinked properly, we intercept these
    -- special sequences of tokens and merge them into just one identifier or
    -- operator token.
    [BacktickTok s1, tok@Token{ tkType = TkIdentifier }, BacktickTok s2]
          | realSrcSpanStart s1 == realSrcSpanStart nodeSpan
          , realSrcSpanEnd s2   == realSrcSpanEnd nodeSpan
          -> richToken srcs nodeInfo
                       (Token{ tkValue = "`" <> tkValue tok <> "`"
                             , tkType = TkOperator
                             , tkSpan = nodeSpan })
    [OpenParenTok s1, tok@Token{ tkType = TkOperator }, CloseParenTok s2]
          | realSrcSpanStart s1 == realSrcSpanStart nodeSpan
          , realSrcSpanEnd s2   == realSrcSpanEnd nodeSpan
          -> richToken srcs nodeInfo
                       (Token{ tkValue = "(" <> tkValue tok <> ")"
                             , tkType = TkOperator
                             , tkSpan = nodeSpan })

    _ -> go nodeChildren toks
  where
    nodeInfo = maybe emptyNodeInfo id (Map.lookup SourceInfo $ getSourcedNodeInfo sourcedNodeInfo)
    go _ [] = mempty
    go [] xs = foldMap renderToken xs
    go (cur:rest) xs =
        foldMap renderToken before <> renderWithAst srcs cur during <> go rest after
      where
        (before,during,after) = splitTokens cur xs
    anchored c = Map.foldrWithKey anchorOne c (nodeIdentifiers nodeInfo)
    anchorOne n dets c = externalAnchor n d $ internalAnchor n d c
      where d = identInfo dets

renderToken :: Token -> Html
renderToken Token{..}
    | BS.null tkValue = mempty
    | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue'
    | otherwise = tokenSpan ! [ multiclass style ]
  where
    tkValue' = filterCRLF $ utf8DecodeByteString tkValue
    style = tokenStyle tkType
    tokenSpan = Html.thespan (Html.toHtml tkValue')


-- | Given information about the source position of definitions, render a token
richToken :: SrcMaps -> NodeInfo PrintedType -> Token -> Html
richToken srcs details Token{..}
    | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue'
    | otherwise = annotate details $ linked content
  where
    tkValue' = filterCRLF $ utf8DecodeByteString tkValue
    content = tokenSpan ! [ multiclass style ]
    tokenSpan = Html.thespan (Html.toHtml tkValue')
    style = tokenStyle tkType ++ concatMap (richTokenStyle (null (nodeType details))) contexts

    contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details

    -- pick an arbitary non-evidence identifier to hyperlink with
    identDet = Map.lookupMin $ Map.filter notEvidence $ nodeIdentifiers $ details
    notEvidence = not . any isEvidenceContext . identInfo

    -- If we have name information, we can make links
    linked = case identDet of
      Just (n,_) -> hyperlink srcs n
      Nothing -> id

-- | Remove CRLFs from source
filterCRLF :: String -> String
filterCRLF ('\r':'\n':cs) = '\n' : filterCRLF cs
filterCRLF (c:cs) = c : filterCRLF cs
filterCRLF [] = []

annotate :: NodeInfo PrintedType -> Html -> Html
annotate  ni content =
    Html.thespan (annot <> content) ! [ Html.theclass "annot" ]
  where
    annot
      | not (null annotation) =
          Html.thespan (Html.toHtml annotation) ! [ Html.theclass "annottext" ]
      | otherwise = mempty
    annotation = typ ++ identTyps
    typ = unlines (nodeType ni)
    typedIdents = [ (n,t) | (n, c@(identType -> Just t)) <- Map.toList $ nodeIdentifiers ni
                          , not (any isEvidenceContext $ identInfo c) ]
    identTyps
      | length typedIdents > 1 || null (nodeType ni)
          = concatMap (\(n,t) -> printName n ++ " :: " ++ t ++ "\n") typedIdents
      | otherwise = ""

    printName :: Either ModuleName Name -> String
    printName = either moduleNameString getOccString

richTokenStyle
  :: Bool         -- ^ are we lacking a type annotation?
  -> ContextInfo  -- ^ in what context did this token show up?
  -> [StyleClass]
richTokenStyle True  Use               = ["hs-type"]
richTokenStyle False Use               = ["hs-var"]
richTokenStyle  _    RecField{}        = ["hs-var"]
richTokenStyle  _    PatternBind{}     = ["hs-var"]
richTokenStyle  _    MatchBind{}       = ["hs-var"]
richTokenStyle  _    TyVarBind{}       = ["hs-type"]
richTokenStyle  _    ValBind{}         = ["hs-var"]
richTokenStyle  _    TyDecl            = ["hs-type"]
richTokenStyle  _    ClassTyDecl{}     = ["hs-type"]
richTokenStyle  _    Decl{}            = ["hs-var"]
richTokenStyle  _    IEThing{}         = []  -- could be either a value or type
richTokenStyle  _    EvidenceVarBind{} = []
richTokenStyle  _    EvidenceVarUse{}  = []

tokenStyle :: TokenType -> [StyleClass]
tokenStyle TkIdentifier = ["hs-identifier"]
tokenStyle TkKeyword = ["hs-keyword"]
tokenStyle TkString = ["hs-string"]
tokenStyle TkChar = ["hs-char"]
tokenStyle TkNumber = ["hs-number"]
tokenStyle TkOperator = ["hs-operator"]
tokenStyle TkGlyph = ["hs-glyph"]
tokenStyle TkSpecial = ["hs-special"]
tokenStyle TkSpace = []
tokenStyle TkComment = ["hs-comment"]
tokenStyle TkCpp = ["hs-cpp"]
tokenStyle TkPragma = ["hs-pragma"]
tokenStyle TkUnknown = []

multiclass :: [StyleClass] -> HtmlAttr
multiclass = Html.theclass . unwords

externalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html
externalAnchor (Right name) contexts content
  | not (isInternalName name)
  , any isBinding contexts
  = Html.thespan content ! [ Html.identifier $ externalAnchorIdent name ]
externalAnchor _ _ content = content

isBinding :: ContextInfo -> Bool
isBinding (ValBind RegularBind _ _) = True
isBinding PatternBind{} = True
isBinding Decl{} = True
isBinding (RecField RecFieldDecl _) = True
isBinding TyVarBind{} = True
isBinding ClassTyDecl{} = True
isBinding _ = False

internalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html
internalAnchor (Right name) contexts content
  | isInternalName name
  , any isBinding contexts
  = Html.thespan content ! [ Html.identifier $ internalAnchorIdent name ]
internalAnchor _ _ content = content

externalAnchorIdent :: Name -> String
externalAnchorIdent = hypSrcNameUrl

internalAnchorIdent :: Name -> String
internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique

-- | Generate the HTML hyperlink for an identifier
hyperlink :: SrcMaps -> Identifier -> Html -> Html
hyperlink (srcs, srcs') ident = case ident of
    Right name | isInternalName name -> internalHyperlink name
               | otherwise -> externalNameHyperlink name
    Left name -> externalModHyperlink name

  where
    internalHyperlink name content =
        Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]

    externalNameHyperlink name content = case Map.lookup mdl srcs of
        Just SrcLocal -> Html.anchor content !
            [ Html.href $ hypSrcModuleNameUrl mdl name ]
        Just (SrcExternal path) -> Html.anchor content !
            [ Html.href $ spliceURL Nothing (Just mdl) (Just name) Nothing (".." </> path) ]
        Nothing -> content
      where
        mdl = nameModule name

    externalModHyperlink moduleName content =
        case Map.lookup moduleName srcs' of
          Just SrcLocal -> Html.anchor content !
            [ Html.href $ hypSrcModuleUrl' moduleName ]
          Just (SrcExternal path) -> Html.anchor content !
            [ Html.href $ spliceURL' Nothing (Just moduleName) Nothing Nothing (".." </> path) ]
          Nothing -> content


renderSpace :: Int -> String -> Html
renderSpace !_ "" = Html.noHtml
renderSpace !line ('\n':rest) = mconcat
    [ Html.thespan (Html.toHtml '\n')
    , lineAnchor (line + 1)
    , renderSpace (line + 1) rest
    ]
renderSpace line space =
    let (hspace, rest) = span (/= '\n') space
    in (Html.thespan . Html.toHtml) hspace <> renderSpace line rest


lineAnchor :: Int -> Html
lineAnchor line = Html.thespan Html.noHtml ! [ Html.identifier $ hypSrcLineUrl line ]