blob: 2df6293806c7bce3fe030f05c2cde7493ad211e5 (
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
|
module Haddock.Backends.Hyperlinker.Renderer (render) where
import Haddock.Backends.Hyperlinker.Parser
import Haddock.Backends.Hyperlinker.Ast
import Haddock.Backends.Hyperlinker.Utils
import Haddock.Backends.Xhtml.Types
import Haddock.Backends.Xhtml.Utils
import qualified GHC
import qualified Name as GHC
import qualified Unique as GHC
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Text.XHtml (Html, HtmlAttr, (!))
import qualified Text.XHtml as Html
type StyleClass = String
render :: Maybe FilePath -> Maybe FilePath -> SourceURLs -> [RichToken] -> Html
render mcss mjs urls tokens = header mcss mjs <> body urls tokens
body :: SourceURLs -> [RichToken] -> Html
body urls = Html.body . Html.pre . mconcat . map (richToken urls)
header :: Maybe FilePath -> Maybe FilePath -> Html
header mcss mjs
| isNothing mcss && isNothing mjs = 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 jsFile) = Html.script Html.noHtml !
[ Html.thetype "text/javascript"
, Html.src jsFile
]
richToken :: SourceURLs -> RichToken -> Html
richToken _ (RichToken tok Nothing) =
tokenSpan tok ! attrs
where
attrs = [ multiclass . tokenStyle . tkType $ tok ]
richToken urls (RichToken tok (Just det)) =
externalAnchor det . internalAnchor det . hyperlink urls det $ content
where
content = tokenSpan tok ! [ multiclass style]
style = (tokenStyle . tkType) tok ++ richTokenStyle det
tokenSpan :: Token -> Html
tokenSpan = Html.thespan . Html.toHtml . tkValue
richTokenStyle :: TokenDetails -> [StyleClass]
richTokenStyle (RtkVar _) = ["hs-var"]
richTokenStyle (RtkType _) = ["hs-type"]
richTokenStyle _ = []
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 . intercalate " "
externalAnchor :: TokenDetails -> Html -> Html
externalAnchor (RtkDecl name) content =
Html.anchor content ! [ Html.name $ externalAnchorIdent name ]
externalAnchor _ content = content
internalAnchor :: TokenDetails -> Html -> Html
internalAnchor (RtkBind name) content =
Html.anchor content ! [ Html.name $ internalAnchorIdent name ]
internalAnchor _ content = content
externalAnchorIdent :: GHC.Name -> String
externalAnchorIdent = GHC.occNameString . GHC.nameOccName
internalAnchorIdent :: GHC.Name -> String
internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
hyperlink :: SourceURLs -> TokenDetails -> Html -> Html
hyperlink urls details = case rtkName details of
Left name ->
if GHC.isInternalName name
then internalHyperlink name
else externalNameHyperlink urls name
Right name -> externalModHyperlink name
internalHyperlink :: GHC.Name -> Html -> Html
internalHyperlink name content =
Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
externalNameHyperlink :: SourceURLs -> GHC.Name -> Html -> Html
externalNameHyperlink urls name =
case Map.lookup key $ srcNameUrlMap urls of
Just url -> externalNameHyperlink' url name
Nothing -> id
where
key = GHC.modulePackageKey . GHC.nameModule $ name
externalNameHyperlink' :: String -> GHC.Name -> Html -> Html
externalNameHyperlink' url name content =
Html.anchor content ! [ Html.href $ href ]
where
mdl = GHC.nameModule name
href = spliceURL Nothing (Just mdl) (Just name) Nothing url
externalModHyperlink :: GHC.ModuleName -> Html -> Html
externalModHyperlink _ = id -- TODO
|
