{-# 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 :: [String] -> HtmlTree -> Html
treeHtml [String]
colors HtmlTree
h = Html -> Html
table forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [
                    Int -> HtmlAttr
border Int
0,
                    Int -> HtmlAttr
cellpadding Int
0,
                    Int -> HtmlAttr
cellspacing Int
2] forall a b. HTML a => (Html -> b) -> a -> b
<< [String] -> HtmlTree -> HtmlTable
treeHtml' [String]
colors HtmlTree
h
     where
      manycolors :: [a] -> [[a]]
manycolors = forall a b. (a -> b -> b) -> b -> [a] -> [b]
scanr (:) []

      treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
      treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
treeHtmls [[String]]
c [HtmlTree]
ts = forall ht. HTMLTABLE ht => [ht] -> HtmlTable
aboves (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [String] -> HtmlTree -> HtmlTable
treeHtml' [[String]]
c [HtmlTree]
ts)

      treeHtml' :: [String] -> HtmlTree -> HtmlTable
      treeHtml' :: [String] -> HtmlTree -> HtmlTable
treeHtml' [String]
_ (HtmlLeaf Html
leaf) = forall ht. HTMLTABLE ht => ht -> HtmlTable
cell
                                         (Html -> Html
td forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
width String
"100%"] 
                                            forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
bold  
                                               forall a b. HTML a => (Html -> b) -> a -> b
<< Html
leaf)
      treeHtml' (String
c:cs :: [String]
cs@(String
c2:[String]
_)) (HtmlNode Html
hopen [HtmlTree]
ts Html
hclose) =
          if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HtmlTree]
ts Bool -> Bool -> Bool
&& Html -> Bool
isNoHtml Html
hclose
          then
              forall ht. HTMLTABLE ht => ht -> HtmlTable
cell Html
hd 
          else if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HtmlTree]
ts
          then
              Html
hd forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
</> Html
bar forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
`beside` (Html -> Html
td forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
bgcolor' String
c2] forall a b. HTML a => (Html -> b) -> a -> b
<< Html
spaceHtml)
                 forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
</> Html
tl
          else
              Html
hd forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
</> (Html
bar forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
`beside` [[String]] -> [HtmlTree] -> HtmlTable
treeHtmls [[String]]
morecolors [HtmlTree]
ts)
                 forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
</> Html
tl
        where
              -- This stops a column of colors being the same
              -- color as the immeduately outside nesting bar.
              morecolors :: [[String]]
morecolors = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= String
c)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. [a] -> a
head) (forall {a}. [a] -> [[a]]
manycolors [String]
cs)
              bar :: Html
bar = Html -> Html
td forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
bgcolor' String
c,String -> HtmlAttr
width String
"10"] forall a b. HTML a => (Html -> b) -> a -> b
<< Html
spaceHtml
              hd :: Html
hd = Html -> Html
td forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
bgcolor' String
c] forall a b. HTML a => (Html -> b) -> a -> b
<< Html
hopen
              tl :: Html
tl = Html -> Html
td forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
bgcolor' String
c] forall a b. HTML a => (Html -> b) -> a -> b
<< Html
hclose
      treeHtml' [String]
_ HtmlTree
_ = forall a. HasCallStack => String -> a
error String
"The imposible happens"

instance HTML HtmlTree where
      toHtml :: HtmlTree -> Html
toHtml HtmlTree
x = [String] -> HtmlTree -> Html
treeHtml [String]
treeColors HtmlTree
x

-- type "length treeColors" to see how many colors are here.
treeColors :: [String]
treeColors :: [String]
treeColors = [String
"#88ccff",String
"#ffffaa",String
"#ffaaff",String
"#ccffff"] forall a. [a] -> [a] -> [a]
++ [String]
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 :: forall a. HTML a => a -> Html
debugHtml a
obj = Html -> Html
table forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Int -> HtmlAttr
border Int
0] forall a b. HTML a => (Html -> b) -> a -> b
<< 
                  ( Html -> Html
th forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
bgcolor' String
"#008888"]
                     forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
underline'
                       forall a b. HTML a => (Html -> b) -> a -> b
<< String
"Debugging Output"
               forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
</>  Html -> Html
td forall a b. HTML a => (Html -> b) -> a -> b
<< (forall a. HTML a => a -> Html
toHtml (Html -> [HtmlTree]
debug' (forall a. HTML a => a -> Html
toHtml a
obj)))
              )
  where

      debug' :: Html -> [HtmlTree]
      debug' :: Html -> [HtmlTree]
debug' (Html [HtmlElement]
markups) = forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> HtmlTree
debug [HtmlElement]
markups

      debug :: HtmlElement -> HtmlTree
      debug :: HtmlElement -> HtmlTree
debug (HtmlString String
str) = Html -> HtmlTree
HtmlLeaf (Html
spaceHtml forall a b. (HTML a, HTML b) => a -> b -> Html
+++
                                              [String] -> Html
linesToHtml (String -> [String]
lines String
str))
      debug (HtmlTag {
              markupTag :: HtmlElement -> String
markupTag = String
tag',
              markupContent :: HtmlElement -> Html
markupContent = Html
content',
              markupAttrs :: HtmlElement -> [HtmlAttr]
markupAttrs  = [HtmlAttr]
attrs
              }) =
              case Html
content' of
                Html [] -> Html -> [HtmlTree] -> Html -> HtmlTree
HtmlNode Html
hd [] Html
noHtml
                Html [HtmlElement]
xs -> Html -> [HtmlTree] -> Html -> HtmlTree
HtmlNode Html
hd (forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> HtmlTree
debug [HtmlElement]
xs) Html
tl
        where
              args :: String
args = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HtmlAttr]
attrs
                     then String
""
                     else String
"  " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [HtmlAttr]
attrs)
              hd :: Html
hd = Html -> Html
xsmallFont forall a b. HTML a => (Html -> b) -> a -> b
<< (String
"<" forall a. [a] -> [a] -> [a]
++ String
tag' forall a. [a] -> [a] -> [a]
++ String
args forall a. [a] -> [a] -> [a]
++ String
">")
              tl :: Html
tl = Html -> Html
xsmallFont forall a b. HTML a => (Html -> b) -> a -> b
<< (String
"</" forall a. [a] -> [a] -> [a]
++ String
tag' forall a. [a] -> [a] -> [a]
++ String
">")

bgcolor' :: String -> HtmlAttr
bgcolor' :: String -> HtmlAttr
bgcolor' String
c = String -> HtmlAttr
thestyle (String
"background-color:" forall a. [a] -> [a] -> [a]
++ String
c)

underline' :: Html -> Html
underline' :: Html -> Html
underline' = Html -> Html
thespan forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thestyle (String
"text-decoration:underline")]

xsmallFont :: Html -> Html
xsmallFont :: Html -> Html
xsmallFont  = Html -> Html
thespan forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [String -> HtmlAttr
thestyle (String
"font-size:x-small")]