{-# OPTIONS_HADDOCK hide #-}

{-# language OverloadedStrings #-}

-- | 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
import qualified Data.Text.Lazy as LText

import Data.List (uncons)

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

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

    treeHtml' :: [LText.Text] -> HtmlTree -> HtmlTable
    treeHtml' :: [Text] -> HtmlTree -> HtmlTable
treeHtml' [Text]
_ (HtmlLeaf Html
leaf) = Html -> HtmlTable
forall ht. HTMLTABLE ht => ht -> HtmlTable
cell
                                        (Html -> Html
td (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Text -> HtmlAttr
width Text
"100%"]
                                          (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
bold
                                              (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
leaf)
    treeHtml' (Text
c:cs :: [Text]
cs@(Text
c2:[Text]
_)) (HtmlNode Html
hopen [HtmlTree]
ts Html
hclose)
        | [HtmlTree] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HtmlTree]
ts Bool -> Bool -> Bool
&& Html -> Bool
isNoHtml Html
hclose = Html -> HtmlTable
forall ht. HTMLTABLE ht => ht -> HtmlTable
cell Html
hd
        | [HtmlTree] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HtmlTree]
ts = Html
hd Html -> HtmlTable -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
</> Html
bar Html -> Html -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
`beside` (Html -> Html
td (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Text -> HtmlAttr
bgcolor' Text
c2] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
spaceHtml) HtmlTable -> Html -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
</> Html
tl
        | Bool
otherwise = Html
hd Html -> HtmlTable -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
</> (Html
bar Html -> HtmlTable -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
`beside` [[Text]] -> [HtmlTree] -> HtmlTable
treeHtmls [[Text]]
morecolors [HtmlTree]
ts) HtmlTable -> Html -> HtmlTable
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 immediately outside nesting bar.
        morecolors :: [[Text]]
morecolors = ([Text] -> Bool) -> [[Text]] -> [[Text]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> ((Text, [Text]) -> Bool) -> Maybe (Text, [Text]) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
c) (Text -> Bool)
-> ((Text, [Text]) -> Text) -> (Text, [Text]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, [Text]) -> Text
forall a b. (a, b) -> a
fst) (Maybe (Text, [Text]) -> Bool)
-> ([Text] -> Maybe (Text, [Text])) -> [Text] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe (Text, [Text])
forall a. [a] -> Maybe (a, [a])
uncons) ([Text] -> [[Text]]
forall {a}. [a] -> [[a]]
manycolors [Text]
cs)
        bar :: Html
bar = Html -> Html
td (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Text -> HtmlAttr
bgcolor' Text
c,Text -> HtmlAttr
width Text
"10"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
spaceHtml
        hd :: Html
hd = Html -> Html
td (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Text -> HtmlAttr
bgcolor' Text
c] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
hopen
        tl :: Html
tl = Html -> Html
td (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Text -> HtmlAttr
bgcolor' Text
c] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
hclose
    treeHtml' [Text]
_ HtmlTree
_ = [Char] -> HtmlTable
forall a. HasCallStack => [Char] -> a
error [Char]
"The imposible happens"

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

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

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

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

bgcolor' :: LText.Text -> HtmlAttr
bgcolor' :: Text -> HtmlAttr
bgcolor' Text
c = Text -> HtmlAttr
thestyle (Text
"background-color:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c)

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

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