1{-# OPTIONS_HADDOCK hide #-}
2
3-- | This module contains functions for displaying
4--   HTML as a pretty tree.
5module Text.XHtml.Debug ( HtmlTree(..), treeHtml, treeColors, debugHtml ) where
6
7import Text.XHtml.Internals
8import Text.XHtml.Extras
9import Text.XHtml.Table
10import Text.XHtml.Strict.Elements
11import Text.XHtml.Strict.Attributes
12
13--
14-- * Tree Displaying Combinators
15--
16
17-- | The basic idea is you render your structure in the form
18-- of this tree, and then use treeHtml to turn it into a Html
19-- object with the structure explicit.
20data HtmlTree
21      = HtmlLeaf Html
22      | HtmlNode Html [HtmlTree] Html
23
24treeHtml :: [String] -> HtmlTree -> Html
25treeHtml colors h = table ! [
26                    border 0,
27                    cellpadding 0,
28                    cellspacing 2] << treeHtml' colors h
29     where
30      manycolors = scanr (:) []
31
32      treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
33      treeHtmls c ts = aboves (zipWith treeHtml' c ts)
34
35      treeHtml' :: [String] -> HtmlTree -> HtmlTable
36      treeHtml' _ (HtmlLeaf leaf) = cell
37                                         (td ! [width "100%"]
38                                            << bold
39                                               << leaf)
40      treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) =
41          if null ts && isNoHtml hclose
42          then
43              cell hd
44          else if null ts
45          then
46              hd </> bar `beside` (td ! [bgcolor' c2] << spaceHtml)
47                 </> tl
48          else
49              hd </> (bar `beside` treeHtmls morecolors ts)
50                 </> tl
51        where
52              -- This stops a column of colors being the same
53              -- color as the immeduately outside nesting bar.
54              morecolors = filter ((/= c).head) (manycolors cs)
55              bar = td ! [bgcolor' c,width "10"] << spaceHtml
56              hd = td ! [bgcolor' c] << hopen
57              tl = td ! [bgcolor' c] << hclose
58      treeHtml' _ _ = error "The imposible happens"
59
60instance HTML HtmlTree where
61      toHtml x = treeHtml treeColors x
62
63-- type "length treeColors" to see how many colors are here.
64treeColors :: [String]
65treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors
66
67
68--
69-- * Html Debugging Combinators
70--
71
72-- | This uses the above tree rendering function, and displays the
73-- Html as a tree structure, allowing debugging of what is
74-- actually getting produced.
75debugHtml :: (HTML a) => a -> Html
76debugHtml obj = table ! [border 0] <<
77                  ( th ! [bgcolor' "#008888"]
78                     << underline'
79                       << "Debugging Output"
80               </>  td << (toHtml (debug' (toHtml obj)))
81              )
82  where
83
84      debug' :: Html -> [HtmlTree]
85      debug' (Html markups) = map debug markups
86
87      debug :: HtmlElement -> HtmlTree
88      debug (HtmlString str) = HtmlLeaf (spaceHtml +++
89                                              linesToHtml (lines str))
90      debug (HtmlTag {
91              markupTag = tag',
92              markupContent = content',
93              markupAttrs  = attrs
94              }) =
95              case content' of
96                Html [] -> HtmlNode hd [] noHtml
97                Html xs -> HtmlNode hd (map debug xs) tl
98        where
99              args = if null attrs
100                     then ""
101                     else "  " ++ unwords (map show attrs)
102              hd = xsmallFont << ("<" ++ tag' ++ args ++ ">")
103              tl = xsmallFont << ("</" ++ tag' ++ ">")
104
105bgcolor' :: String -> HtmlAttr
106bgcolor' c = thestyle ("background-color:" ++ c)
107
108underline' :: Html -> Html
109underline' = thespan ! [thestyle ("text-decoration:underline")]
110
111xsmallFont :: Html -> Html
112xsmallFont  = thespan ! [thestyle ("font-size:x-small")]
113