blob: b05a5b8a0ae74bc745e1b472f27f98c10888fb24 (
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.Types
import Haddock.Backends.Hyperlinker.Parser
import Haddock.Backends.Hyperlinker.Ast
import Haddock.Backends.Hyperlinker.Utils
import qualified GHC
import qualified Name as GHC
import qualified Unique as GHC
import System.FilePath.Posix ((</>))
import Data.List
import Data.Maybe
import Data.Monoid
import qualified Data.Map as Map
import Text.XHtml (Html, HtmlAttr, (!))
import qualified Text.XHtml as Html
type StyleClass = String
render :: Maybe FilePath -> Maybe FilePath
-> GHC.PackageKey -> SrcMap -> [RichToken]
-> Html
render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens
body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html
body pkg srcs = Html.body . Html.pre . mconcat . map (richToken pkg srcs)
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 scriptFile) = Html.script Html.noHtml !
[ Html.thetype "text/javascript"
, Html.src scriptFile
]
richToken :: GHC.PackageKey -> SrcMap -> RichToken -> Html
richToken _ _ (RichToken tok Nothing) =
tokenSpan tok ! attrs
where
attrs = [ multiclass . tokenStyle . tkType $ tok ]
richToken pkg srcs (RichToken tok (Just det)) =
externalAnchor det . internalAnchor det . hyperlink pkg srcs 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 = hypSrcNameUrl
internalAnchorIdent :: GHC.Name -> String
internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
hyperlink :: GHC.PackageKey -> SrcMap -> TokenDetails -> Html -> Html
hyperlink pkg srcs details = case rtkName details of
Left name ->
if GHC.isInternalName name
then internalHyperlink name
else externalNameHyperlink pkg srcs name
Right name -> externalModHyperlink name
internalHyperlink :: GHC.Name -> Html -> Html
internalHyperlink name content =
Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
externalNameHyperlink :: GHC.PackageKey -> SrcMap -> GHC.Name -> Html -> Html
externalNameHyperlink pkg srcs name content
| namePkg == pkg = Html.anchor content !
[ Html.href $ hypSrcModuleNameUrl mdl name ]
| Just path <- Map.lookup namePkg srcs = Html.anchor content !
[ Html.href $ path </> hypSrcModuleNameUrl mdl name ]
| otherwise = content
where
mdl = GHC.nameModule name
namePkg = GHC.modulePackageKey mdl
externalModHyperlink :: GHC.ModuleName -> Html -> Html
externalModHyperlink mdl content =
Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ]
|
