blob: 7052475903ba8907072de5c9fa148e587fa9e4f3 (
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
|
module Haddock.Backends.Hyperlinker.Renderer (render) where
import Haddock.Backends.Hyperlinker.Parser
import Haddock.Backends.Hyperlinker.Ast
import qualified GHC
import qualified Name as GHC
import qualified Unique as GHC
import Data.List
import Data.Maybe
import Data.Monoid
import Text.XHtml (Html, HtmlAttr, (!))
import qualified Text.XHtml as Html
type StyleClass = String
render :: Maybe FilePath -> [RichToken] -> Html
render css tokens = header css <> body tokens
body :: [RichToken] -> Html
body = Html.body . Html.pre . mconcat . map richToken
header :: Maybe FilePath -> Html
header Nothing = Html.noHtml
header (Just css) =
Html.header $ Html.thelink Html.noHtml ! attrs
where
attrs =
[ Html.rel "stylesheet"
, Html.href css
, Html.thetype "text/css"
]
richToken :: RichToken -> Html
richToken (RichToken tok Nothing) =
tokenSpan tok ! attrs
where
attrs = [ multiclass . tokenStyle . tkType $ tok ]
richToken (RichToken tok (Just det)) =
externalAnchor det . internalAnchor det . hyperlink 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 :: TokenDetails -> Html -> Html
hyperlink details = case rtkName details of
Left name ->
if GHC.isInternalName name
then internalHyperlink name
else externalHyperlink mname (Just name)
where
mname = GHC.moduleName <$> GHC.nameModule_maybe name
Right name -> externalHyperlink (Just name) Nothing
internalHyperlink :: GHC.Name -> Html -> Html
internalHyperlink name content =
Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
externalHyperlink :: Maybe GHC.ModuleName -> Maybe GHC.Name -> Html -> Html
externalHyperlink mmname miname content =
Html.anchor content ! [ Html.href $ path ++ anchor ]
where
path = fromMaybe "" $ modulePath <$> mmname
anchor = fromMaybe "" $ ("#" ++) . externalAnchorIdent <$> miname
modulePath :: GHC.ModuleName -> String
modulePath name = GHC.moduleNameString name ++ ".html"
|
