    {-# 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

    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 :: [String] -> HtmlTree -> Html
    treeHtml :: [String] -> HtmlTree -> Html
    treeHtml [String]
    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
    << [String] -> HtmlTree -> HtmlTable
    treeHtml' [String]
    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 :: [[String]] -> [HtmlTree] -> HtmlTable
          treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
    treeHtmls [[String]]
    c [HtmlTree]
    ts = [HtmlTable] -> HtmlTable
    forall ht. HTMLTABLE ht => [ht] -> HtmlTable
    aboves (([String] -> HtmlTree -> HtmlTable)
    -> [[String]] -> [HtmlTree] -> [HtmlTable]
    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) = Html -> HtmlTable
    forall ht. HTMLTABLE ht => ht -> HtmlTable
    cell
                                             (Html -> Html
    td (Html -> Html) -> [HtmlAttr] -> Html -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    width String
    "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' (String
    c:cs :: [String]
    cs@(String
    c2:[String]
    _)) (HtmlNode Html
    hopen [HtmlTree]
    ts Html
    hclose) =
              if [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
              then
                  Html -> HtmlTable
    forall ht. HTMLTABLE ht => ht -> HtmlTable
    cell Html
    hd
              else if [HtmlTree] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [HtmlTree]
    ts
              then
                  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
    ! [String -> HtmlAttr
    bgcolor' String
    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
              else
                  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` [[String]] -> [HtmlTree] -> HtmlTable
    treeHtmls [[String]]
    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 :: [[String]]
    morecolors = ([String] -> Bool) -> [[String]] -> [[String]]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool
    -> ((String, [String]) -> Bool) -> Maybe (String, [String]) -> Bool
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Bool
    True ((String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= String
    c) (String -> Bool)
    -> ((String, [String]) -> String) -> (String, [String]) -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String, [String]) -> String
    forall a b. (a, b) -> a
    fst) (Maybe (String, [String]) -> Bool)
    -> ([String] -> Maybe (String, [String])) -> [String] -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [String] -> Maybe (String, [String])
    forall a. [a] -> Maybe (a, [a])
    uncons) ([String] -> [[String]]
    forall {a}. [a] -> [[a]]
    manycolors [String]
    cs)
                  bar :: Html
    bar = Html -> Html
    td (Html -> Html) -> [HtmlAttr] -> Html -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    bgcolor' String
    c,String -> HtmlAttr
    width String
    "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
    ! [String -> HtmlAttr
    bgcolor' String
    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
    ! [String -> HtmlAttr
    bgcolor' String
    c] (Html -> Html) -> Html -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    << Html
    hclose
          treeHtml' [String]
    _ HtmlTree
    _ = String -> HtmlTable
    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"] [String] -> [String] -> [String]
    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 (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
    ! [String -> HtmlAttr
    bgcolor' String
    "#008888"]
                         (Html -> Html) -> Html -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    << Html -> Html
    underline'
                           (Html -> Html) -> String -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    << String
    "Debugging Output"
                   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]
    markups) = (HtmlElement -> HtmlTree) -> [HtmlElement] -> [HtmlTree]
    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 Html -> Html -> Html
    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 ((HtmlElement -> HtmlTree) -> [HtmlElement] -> [HtmlTree]
    forall a b. (a -> b) -> [a] -> [b]
    map HtmlElement -> HtmlTree
    debug [HtmlElement]
    xs) Html
    tl
            where
                  args :: String
    args = if [HtmlAttr] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [HtmlAttr]
    attrs
                         then String
    ""
                         else String
    "  " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [String] -> String
    unwords ((HtmlAttr -> String) -> [HtmlAttr] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map HtmlAttr -> String
    forall a. Show a => a -> String
    show [HtmlAttr]
    attrs)
                  hd :: Html
    hd = Html -> Html
    xsmallFont (Html -> Html) -> String -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    << (String
    "<" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    tag' String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    args String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ">")
                  tl :: Html
    tl = Html -> Html
    xsmallFont (Html -> Html) -> String -> Html
    forall a b. HTML a => (Html -> b) -> a -> b
    << (String
    "</" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    tag' String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ">")

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

    underline' :: Html -> Html
    underline' :: Html -> Html
    underline' = Html -> Html
    thespan (Html -> Html) -> [HtmlAttr] -> Html -> Html
    forall a. ADDATTRS a => a -> [HtmlAttr] -> a
    ! [String -> HtmlAttr
    thestyle (String
    "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
    ! [String -> HtmlAttr
    thestyle (String
    "font-size:x-small")]