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
|
{-# OPTIONS_HADDOCK hide #-}
-- | This module contains functions for displaying
-- HTML as a pretty tree.
module Text.XHtml.Debug ( HtmlTree(..), treeHtml, treeColors, debugHtml ) where
import Text.XHtml.Internals
import Text.XHtml.Extras
import Text.XHtml.Table
import Text.XHtml.Strict.Elements
import Text.XHtml.Strict.Attributes
--
-- * Tree Displaying Combinators
--
-- | The basic idea is you render your structure in the form
-- of this tree, and then use treeHtml to turn it into a Html
-- object with the structure explicit.
data HtmlTree
= HtmlLeaf Html
| HtmlNode Html [HtmlTree] Html
treeHtml :: [String] -> HtmlTree -> Html
treeHtml colors h = table ! [
border 0,
cellpadding 0,
cellspacing 2] << treeHtml' colors h
where
manycolors = scanr (:) []
treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
treeHtmls c ts = aboves (zipWith treeHtml' c ts)
treeHtml' :: [String] -> HtmlTree -> HtmlTable
treeHtml' _ (HtmlLeaf leaf) = cell
(td ! [width "100%"]
<< bold
<< leaf)
treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) =
if null ts && isNoHtml hclose
then
cell hd
else if null ts
then
hd </> bar `beside` (td ! [bgcolor' c2] << spaceHtml)
</> tl
else
hd </> (bar `beside` treeHtmls morecolors ts)
</> tl
where
-- This stops a column of colors being the same
-- color as the immeduately outside nesting bar.
morecolors = filter ((/= c).head) (manycolors cs)
bar = td ! [bgcolor' c,width "10"] << spaceHtml
hd = td ! [bgcolor' c] << hopen
tl = td ! [bgcolor' c] << hclose
treeHtml' _ _ = error "The imposible happens"
instance HTML HtmlTree where
toHtml x = treeHtml treeColors x
-- type "length treeColors" to see how many colors are here.
treeColors :: [String]
treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors
--
-- * Html Debugging Combinators
--
-- | This uses the above tree rendering function, and displays the
-- Html as a tree structure, allowing debugging of what is
-- actually getting produced.
debugHtml :: (HTML a) => a -> Html
debugHtml obj = table ! [border 0] <<
( th ! [bgcolor' "#008888"]
<< underline'
<< "Debugging Output"
</> td << (toHtml (debug' (toHtml obj)))
)
where
debug' :: Html -> [HtmlTree]
debug' (Html markups) = map debug markups
debug :: HtmlElement -> HtmlTree
debug (HtmlString str) = HtmlLeaf (spaceHtml +++
linesToHtml (lines str))
debug (HtmlTag {
markupTag = tag',
markupContent = content',
markupAttrs = attrs
}) =
case content' of
Html [] -> HtmlNode hd [] noHtml
Html xs -> HtmlNode hd (map debug xs) tl
where
args = if null attrs
then ""
else " " ++ unwords (map show attrs)
hd = xsmallFont << ("<" ++ tag' ++ args ++ ">")
tl = xsmallFont << ("</" ++ tag' ++ ">")
bgcolor' :: String -> HtmlAttr
bgcolor' c = thestyle ("background-color:" ++ c)
underline' :: Html -> Html
underline' = thespan ! [thestyle ("text-decoration:underline")]
xsmallFont :: Html -> Html
xsmallFont = thespan ! [thestyle ("font-size:x-small")]
|
