1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE ViewPatterns #-}
3{-# LANGUAGE PatternSynonyms #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE BangPatterns #-}
6
7module Haddock.Backends.Hyperlinker.Renderer (render) where
8
9
10import Haddock.Backends.Hyperlinker.Types
11import Haddock.Backends.Hyperlinker.Utils
12
13import qualified Data.ByteString as BS
14
15import HieTypes
16import Module   ( ModuleName, moduleNameString )
17import Name     ( getOccString, isInternalName, Name, nameModule, nameUnique )
18import SrcLoc
19import Unique   ( getKey )
20import Encoding ( utf8DecodeByteString )
21
22import System.FilePath.Posix ((</>))
23
24import qualified Data.Map as Map
25import qualified Data.Set as Set
26
27import Text.XHtml (Html, HtmlAttr, (!))
28import qualified Text.XHtml as Html
29
30
31type StyleClass = String
32
33-- | Produce the HTML corresponding to a hyperlinked Haskell source
34render
35  :: Maybe FilePath    -- ^ path to the CSS file
36  -> Maybe FilePath    -- ^ path to the JS file
37  -> SrcMaps            -- ^ Paths to sources
38  -> HieAST PrintedType  -- ^ ASTs from @.hie@ files
39  -> [Token]       -- ^ tokens to render
40  -> Html
41render mcss mjs srcs ast tokens = header mcss mjs <> body srcs ast tokens
42
43body :: SrcMaps -> HieAST PrintedType -> [Token] -> Html
44body srcs ast tokens = Html.body . Html.pre $ hypsrc
45  where
46    hypsrc = renderWithAst srcs ast tokens
47
48header :: Maybe FilePath -> Maybe FilePath -> Html
49header Nothing Nothing = Html.noHtml
50header mcss mjs = Html.header $ css mcss <> js mjs
51  where
52    css Nothing = Html.noHtml
53    css (Just cssFile) = Html.thelink Html.noHtml !
54        [ Html.rel "stylesheet"
55        , Html.thetype "text/css"
56        , Html.href cssFile
57        ]
58    js Nothing = Html.noHtml
59    js (Just scriptFile) = Html.script Html.noHtml !
60        [ Html.thetype "text/javascript"
61        , Html.src scriptFile
62        ]
63
64
65splitTokens :: HieAST PrintedType -> [Token] -> ([Token],[Token],[Token])
66splitTokens ast toks = (before,during,after)
67  where
68    (before,rest) = span leftOf toks
69    (during,after) = span inAst rest
70    leftOf t = realSrcSpanEnd (tkSpan t) <= realSrcSpanStart nodeSp
71    inAst t = nodeSp `containsSpan` tkSpan t
72    nodeSp = nodeSpan ast
73
74-- | Turn a list of tokens into hyperlinked sources, threading in relevant link
75-- information from the 'HieAST'.
76renderWithAst :: SrcMaps -> HieAST PrintedType -> [Token] -> Html
77renderWithAst srcs Node{..} toks = anchored $ case toks of
78
79    [tok] | nodeSpan == tkSpan tok -> richToken srcs nodeInfo tok
80
81    -- NB: the GHC lexer lexes backquoted identifiers and parenthesized operators
82    -- as multiple tokens.
83    --
84    --  * @a `elem` b@ turns into @[a, `, elem, `, b]@ (excluding space tokens)
85    --  * @(+) 1 2@    turns into @[(, +, ), 1, 2]@    (excluding space tokens)
86    --
87    -- However, the HIE ast considers @`elem`@ and @(+)@ to be single nodes. In
88    -- order to make sure these get hyperlinked properly, we intercept these
89    -- special sequences of tokens and merge them into just one identifier or
90    -- operator token.
91    [BacktickTok s1, tok@Token{ tkType = TkIdentifier }, BacktickTok s2]
92          | realSrcSpanStart s1 == realSrcSpanStart nodeSpan
93          , realSrcSpanEnd s2   == realSrcSpanEnd nodeSpan
94          -> richToken srcs nodeInfo
95                       (Token{ tkValue = "`" <> tkValue tok <> "`"
96                             , tkType = TkOperator
97                             , tkSpan = nodeSpan })
98    [OpenParenTok s1, tok@Token{ tkType = TkOperator }, CloseParenTok s2]
99          | realSrcSpanStart s1 == realSrcSpanStart nodeSpan
100          , realSrcSpanEnd s2   == realSrcSpanEnd nodeSpan
101          -> richToken srcs nodeInfo
102                       (Token{ tkValue = "(" <> tkValue tok <> ")"
103                             , tkType = TkOperator
104                             , tkSpan = nodeSpan })
105
106    _ -> go nodeChildren toks
107  where
108    go _ [] = mempty
109    go [] xs = foldMap renderToken xs
110    go (cur:rest) xs =
111        foldMap renderToken before <> renderWithAst srcs cur during <> go rest after
112      where
113        (before,during,after) = splitTokens cur xs
114    anchored c = Map.foldrWithKey anchorOne c (nodeIdentifiers nodeInfo)
115    anchorOne n dets c = externalAnchor n d $ internalAnchor n d c
116      where d = identInfo dets
117
118renderToken :: Token -> Html
119renderToken Token{..}
120    | BS.null tkValue = mempty
121    | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue'
122    | otherwise = tokenSpan ! [ multiclass style ]
123  where
124    tkValue' = filterCRLF $ utf8DecodeByteString tkValue
125    style = tokenStyle tkType
126    tokenSpan = Html.thespan (Html.toHtml tkValue')
127
128
129-- | Given information about the source position of definitions, render a token
130richToken :: SrcMaps -> NodeInfo PrintedType -> Token -> Html
131richToken srcs details Token{..}
132    | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue'
133    | otherwise = annotate details $ linked content
134  where
135    tkValue' = filterCRLF $ utf8DecodeByteString tkValue
136    content = tokenSpan ! [ multiclass style ]
137    tokenSpan = Html.thespan (Html.toHtml tkValue')
138    style = tokenStyle tkType ++ concatMap (richTokenStyle (null (nodeType details))) contexts
139
140    contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details
141
142    -- pick an arbitary identifier to hyperlink with
143    identDet = Map.lookupMin . nodeIdentifiers $ details
144
145    -- If we have name information, we can make links
146    linked = case identDet of
147      Just (n,_) -> hyperlink srcs n
148      Nothing -> id
149
150-- | Remove CRLFs from source
151filterCRLF :: String -> String
152filterCRLF ('\r':'\n':cs) = '\n' : filterCRLF cs
153filterCRLF (c:cs) = c : filterCRLF cs
154filterCRLF [] = []
155
156annotate :: NodeInfo PrintedType -> Html -> Html
157annotate  ni content =
158    Html.thespan (annot <> content) ! [ Html.theclass "annot" ]
159  where
160    annot
161      | not (null annotation) =
162          Html.thespan (Html.toHtml annotation) ! [ Html.theclass "annottext" ]
163      | otherwise = mempty
164    annotation = typ ++ identTyps
165    typ = unlines (nodeType ni)
166    typedIdents = [ (n,t) | (n, identType -> Just t) <- Map.toList $ nodeIdentifiers ni ]
167    identTyps
168      | length typedIdents > 1 || null (nodeType ni)
169          = concatMap (\(n,t) -> printName n ++ " :: " ++ t ++ "\n") typedIdents
170      | otherwise = ""
171
172    printName :: Either ModuleName Name -> String
173    printName = either moduleNameString getOccString
174
175richTokenStyle
176  :: Bool         -- ^ are we lacking a type annotation?
177  -> ContextInfo  -- ^ in what context did this token show up?
178  -> [StyleClass]
179richTokenStyle True  Use           = ["hs-type"]
180richTokenStyle False Use           = ["hs-var"]
181richTokenStyle  _    RecField{}    = ["hs-var"]
182richTokenStyle  _    PatternBind{} = ["hs-var"]
183richTokenStyle  _    MatchBind{}   = ["hs-var"]
184richTokenStyle  _    TyVarBind{}   = ["hs-type"]
185richTokenStyle  _    ValBind{}     = ["hs-var"]
186richTokenStyle  _    TyDecl        = ["hs-type"]
187richTokenStyle  _    ClassTyDecl{} = ["hs-type"]
188richTokenStyle  _    Decl{}        = ["hs-var"]
189richTokenStyle  _    IEThing{}     = []  -- could be either a value or type
190
191tokenStyle :: TokenType -> [StyleClass]
192tokenStyle TkIdentifier = ["hs-identifier"]
193tokenStyle TkKeyword = ["hs-keyword"]
194tokenStyle TkString = ["hs-string"]
195tokenStyle TkChar = ["hs-char"]
196tokenStyle TkNumber = ["hs-number"]
197tokenStyle TkOperator = ["hs-operator"]
198tokenStyle TkGlyph = ["hs-glyph"]
199tokenStyle TkSpecial = ["hs-special"]
200tokenStyle TkSpace = []
201tokenStyle TkComment = ["hs-comment"]
202tokenStyle TkCpp = ["hs-cpp"]
203tokenStyle TkPragma = ["hs-pragma"]
204tokenStyle TkUnknown = []
205
206multiclass :: [StyleClass] -> HtmlAttr
207multiclass = Html.theclass . unwords
208
209externalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html
210externalAnchor (Right name) contexts content
211  | not (isInternalName name)
212  , any isBinding contexts
213  = Html.thespan content ! [ Html.identifier $ externalAnchorIdent name ]
214externalAnchor _ _ content = content
215
216isBinding :: ContextInfo -> Bool
217isBinding (ValBind RegularBind _ _) = True
218isBinding PatternBind{} = True
219isBinding Decl{} = True
220isBinding (RecField RecFieldDecl _) = True
221isBinding TyVarBind{} = True
222isBinding ClassTyDecl{} = True
223isBinding _ = False
224
225internalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html
226internalAnchor (Right name) contexts content
227  | isInternalName name
228  , any isBinding contexts
229  = Html.thespan content ! [ Html.identifier $ internalAnchorIdent name ]
230internalAnchor _ _ content = content
231
232externalAnchorIdent :: Name -> String
233externalAnchorIdent = hypSrcNameUrl
234
235internalAnchorIdent :: Name -> String
236internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique
237
238-- | Generate the HTML hyperlink for an identifier
239hyperlink :: SrcMaps -> Identifier -> Html -> Html
240hyperlink (srcs, srcs') ident = case ident of
241    Right name | isInternalName name -> internalHyperlink name
242               | otherwise -> externalNameHyperlink name
243    Left name -> externalModHyperlink name
244
245  where
246    internalHyperlink name content =
247        Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
248
249    externalNameHyperlink name content = case Map.lookup mdl srcs of
250        Just SrcLocal -> Html.anchor content !
251            [ Html.href $ hypSrcModuleNameUrl mdl name ]
252        Just (SrcExternal path) -> Html.anchor content !
253            [ Html.href $ spliceURL Nothing (Just mdl) (Just name) Nothing (".." </> path) ]
254        Nothing -> content
255      where
256        mdl = nameModule name
257
258    externalModHyperlink moduleName content =
259        case Map.lookup moduleName srcs' of
260          Just SrcLocal -> Html.anchor content !
261            [ Html.href $ hypSrcModuleUrl' moduleName ]
262          Just (SrcExternal path) -> Html.anchor content !
263            [ Html.href $ spliceURL' Nothing (Just moduleName) Nothing Nothing (".." </> path) ]
264          Nothing -> content
265
266
267renderSpace :: Int -> String -> Html
268renderSpace !_ "" = Html.noHtml
269renderSpace !line ('\n':rest) = mconcat
270    [ Html.thespan (Html.toHtml '\n')
271    , lineAnchor (line + 1)
272    , renderSpace (line + 1) rest
273    ]
274renderSpace line space =
275    let (hspace, rest) = span (/= '\n') space
276    in (Html.thespan . Html.toHtml) hspace <> renderSpace line rest
277
278
279lineAnchor :: Int -> Html
280lineAnchor line = Html.thespan Html.noHtml ! [ Html.identifier $ hypSrcLineUrl line ]
281