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