{-# OPTIONS_HADDOCK hide #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.XHtml.internals
-- Copyright   :  (c) Andy Gill, and the Oregon Graduate Institute of
--                Science and Technology, 1999-2001,
--                (c) Bjorn Bringert, 2004-2006
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Chris Dornan <chris@chrisdornan.com>
-- Stability   :  Stable
-- Portability :  Portable
--
-- Internals of the XHTML combinator library.
-----------------------------------------------------------------------------
module Text.XHtml.Internals where

import Data.Char
import qualified Data.Semigroup as Sem
import qualified Data.Monoid as Mon

infixr 2 +++  -- combining Html
infixr 7 <<   -- nesting Html
infixl 8 !    -- adding optional arguments

--
-- * Data types
--

-- | A important property of Html is that all strings inside the
-- structure are already in Html friendly format.
data HtmlElement
      = HtmlString String
        -- ^ ..just..plain..normal..text... but using &copy; and &amb;, etc.
      | HtmlTag {
              HtmlElement -> [Char]
markupTag      :: String,
              HtmlElement -> [HtmlAttr]
markupAttrs    :: [HtmlAttr],
              HtmlElement -> Html
markupContent  :: Html
              }
        -- ^ tag with internal markup

-- | Attributes with name and value.
data HtmlAttr = HtmlAttr String String


htmlAttrPair :: HtmlAttr -> (String,String)
htmlAttrPair :: HtmlAttr -> ([Char], [Char])
htmlAttrPair (HtmlAttr [Char]
n [Char]
v) = ([Char]
n,[Char]
v)


newtype Html = Html { Html -> [HtmlElement]
getHtmlElements :: [HtmlElement] }


--
-- * Classes
--

instance Show Html where
      showsPrec :: Int -> Html -> ShowS
showsPrec Int
_ Html
html = [Char] -> ShowS
showString (Html -> [Char]
forall html. HTML html => html -> [Char]
renderHtmlFragment Html
html)
      showList :: [Html] -> ShowS
showList [Html]
htmls   = (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id ((Html -> ShowS) -> [Html] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map Html -> ShowS
forall a. Show a => a -> ShowS
shows [Html]
htmls)

instance Show HtmlAttr where
      showsPrec :: Int -> HtmlAttr -> ShowS
showsPrec Int
_ (HtmlAttr [Char]
str [Char]
val) =
              [Char] -> ShowS
showString [Char]
str ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              [Char] -> ShowS
showString [Char]
"=" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              [Char] -> ShowS
forall a. Show a => a -> ShowS
shows [Char]
val

-- | @since 3000.2.2
instance Sem.Semigroup Html where
    <> :: Html -> Html -> Html
(<>) = Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
(+++)

instance Mon.Monoid Html where
    mempty :: Html
mempty = Html
noHtml
    mappend :: Html -> Html -> Html
mappend = Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
(Sem.<>)

-- | HTML is the class of things that can be validly put
-- inside an HTML tag. So this can be one or more 'Html' elements,
-- or a 'String', for example.
class HTML a where
      toHtml     :: a -> Html
      toHtmlFromList :: [a] -> Html

      toHtmlFromList [a]
xs = [HtmlElement] -> Html
Html ([[HtmlElement]] -> [HtmlElement]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [HtmlElement]
x | (Html [HtmlElement]
x) <- (a -> Html) -> [a] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map a -> Html
forall a. HTML a => a -> Html
toHtml [a]
xs])

instance HTML Html where
      toHtml :: Html -> Html
toHtml Html
a    = Html
a

instance HTML Char where
      toHtml :: Char -> Html
toHtml       Char
a = [Char] -> Html
forall a. HTML a => a -> Html
toHtml [Char
a]
      toHtmlFromList :: [Char] -> Html
toHtmlFromList []  = [HtmlElement] -> Html
Html []
      toHtmlFromList [Char]
str = [HtmlElement] -> Html
Html [[Char] -> HtmlElement
HtmlString (ShowS
stringToHtmlString [Char]
str)]

instance (HTML a) => HTML [a] where
      toHtml :: [a] -> Html
toHtml [a]
xs = [a] -> Html
forall a. HTML a => [a] -> Html
toHtmlFromList [a]
xs

instance HTML a => HTML (Maybe a) where
      toHtml :: Maybe a -> Html
toHtml = Html -> (a -> Html) -> Maybe a -> Html
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Html
noHtml a -> Html
forall a. HTML a => a -> Html
toHtml

class ADDATTRS a where
      (!) :: a -> [HtmlAttr] -> a

-- | CHANGEATTRS is a more expressive alternative to ADDATTRS
class CHANGEATTRS a where
      changeAttrs :: a -> ([HtmlAttr]->[HtmlAttr]) -> a

instance (ADDATTRS b) => ADDATTRS (a -> b) where
      a -> b
fn ! :: (a -> b) -> [HtmlAttr] -> a -> b
! [HtmlAttr]
attr        = \ a
arg -> a -> b
fn a
arg b -> [HtmlAttr] -> b
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [HtmlAttr]
attr

instance (CHANGEATTRS b) => CHANGEATTRS (a -> b) where
      changeAttrs :: (a -> b) -> ([HtmlAttr] -> [HtmlAttr]) -> a -> b
changeAttrs a -> b
fn [HtmlAttr] -> [HtmlAttr]
f = \ a
arg -> b -> ([HtmlAttr] -> [HtmlAttr]) -> b
forall a. CHANGEATTRS a => a -> ([HtmlAttr] -> [HtmlAttr]) -> a
changeAttrs (a -> b
fn a
arg) [HtmlAttr] -> [HtmlAttr]
f

instance ADDATTRS Html where
      (Html [HtmlElement]
htmls) ! :: Html -> [HtmlAttr] -> Html
! [HtmlAttr]
attr = [HtmlElement] -> Html
Html ((HtmlElement -> HtmlElement) -> [HtmlElement] -> [HtmlElement]
forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> HtmlElement
addAttrs [HtmlElement]
htmls)
        where
              addAttrs :: HtmlElement -> HtmlElement
addAttrs (html :: HtmlElement
html@(HtmlTag { markupAttrs :: HtmlElement -> [HtmlAttr]
markupAttrs = [HtmlAttr]
attrs }) )
                            = HtmlElement
html { markupAttrs = attrs ++ attr }
              addAttrs HtmlElement
html = HtmlElement
html

instance CHANGEATTRS Html where
      changeAttrs :: Html -> ([HtmlAttr] -> [HtmlAttr]) -> Html
changeAttrs (Html [HtmlElement]
htmls) [HtmlAttr] -> [HtmlAttr]
f = [HtmlElement] -> Html
Html ((HtmlElement -> HtmlElement) -> [HtmlElement] -> [HtmlElement]
forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> HtmlElement
addAttrs [HtmlElement]
htmls)
        where
              addAttrs :: HtmlElement -> HtmlElement
addAttrs (html :: HtmlElement
html@(HtmlTag { markupAttrs :: HtmlElement -> [HtmlAttr]
markupAttrs = [HtmlAttr]
attrs }) )
                            = HtmlElement
html { markupAttrs = f attrs }
              addAttrs HtmlElement
html = HtmlElement
html


--
-- * Html primitives and basic combinators
--

-- | Put something inside an HTML element.
(<<) :: (HTML a) =>
        (Html -> b) -- ^ Parent
     -> a -- ^ Child
     -> b
Html -> b
fn << :: forall a b. HTML a => (Html -> b) -> a -> b
<< a
arg = Html -> b
fn (a -> Html
forall a. HTML a => a -> Html
toHtml a
arg)


concatHtml :: (HTML a) => [a] -> Html
concatHtml :: forall a. HTML a => [a] -> Html
concatHtml [a]
as = [HtmlElement] -> Html
Html ([[HtmlElement]] -> [HtmlElement]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((a -> [HtmlElement]) -> [a] -> [[HtmlElement]]
forall a b. (a -> b) -> [a] -> [b]
map (Html -> [HtmlElement]
getHtmlElements(Html -> [HtmlElement]) -> (a -> Html) -> a -> [HtmlElement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> Html
forall a. HTML a => a -> Html
toHtml) [a]
as))

-- | Create a piece of HTML which is the concatenation
--   of two things which can be made into HTML.
(+++) :: (HTML a,HTML b) => a -> b -> Html
a
a +++ :: forall a b. (HTML a, HTML b) => a -> b -> Html
+++ b
b = [HtmlElement] -> Html
Html (Html -> [HtmlElement]
getHtmlElements (a -> Html
forall a. HTML a => a -> Html
toHtml a
a) [HtmlElement] -> [HtmlElement] -> [HtmlElement]
forall a. [a] -> [a] -> [a]
++ Html -> [HtmlElement]
getHtmlElements (b -> Html
forall a. HTML a => a -> Html
toHtml b
b))

-- | An empty piece of HTML.
noHtml :: Html
noHtml :: Html
noHtml = [HtmlElement] -> Html
Html []

-- | Checks whether the given piece of HTML is empty.
isNoHtml :: Html -> Bool
isNoHtml :: Html -> Bool
isNoHtml (Html [HtmlElement]
xs) = [HtmlElement] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HtmlElement]
xs

-- | Constructs an element with a custom name.
tag :: String -- ^ Element name
    -> Html -- ^ Element contents
    -> Html
tag :: [Char] -> Html -> Html
tag [Char]
str       Html
htmls = [HtmlElement] -> Html
Html [
      HtmlTag {
              markupTag :: [Char]
markupTag = [Char]
str,
              markupAttrs :: [HtmlAttr]
markupAttrs = [],
              markupContent :: Html
markupContent = Html
htmls }]

-- | Constructs an element with a custom name, and
--   without any children.
itag :: String -> Html
itag :: [Char] -> Html
itag [Char]
str = [Char] -> Html -> Html
tag [Char]
str Html
noHtml

emptyAttr :: String -> HtmlAttr
emptyAttr :: [Char] -> HtmlAttr
emptyAttr [Char]
s = [Char] -> [Char] -> HtmlAttr
HtmlAttr [Char]
s [Char]
s

intAttr :: String -> Int -> HtmlAttr
intAttr :: [Char] -> Int -> HtmlAttr
intAttr [Char]
s Int
i = [Char] -> [Char] -> HtmlAttr
HtmlAttr [Char]
s (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)

strAttr :: String -> String -> HtmlAttr
strAttr :: [Char] -> [Char] -> HtmlAttr
strAttr [Char]
s [Char]
t = [Char] -> [Char] -> HtmlAttr
HtmlAttr [Char]
s (ShowS
stringToHtmlString [Char]
t)

htmlAttr :: String -> Html -> HtmlAttr
htmlAttr :: [Char] -> Html -> HtmlAttr
htmlAttr [Char]
s Html
t = [Char] -> [Char] -> HtmlAttr
HtmlAttr [Char]
s (Html -> [Char]
forall a. Show a => a -> [Char]
show Html
t)


{-
foldHtml :: (String -> [HtmlAttr] -> [a] -> a)
      -> (String -> a)
      -> Html
      -> a
foldHtml f g (HtmlTag str attr fmls)
      = f str attr (map (foldHtml f g) fmls)
foldHtml f g (HtmlString  str)
      = g str

-}

-- | Processing Strings into Html friendly things.
stringToHtmlString :: String -> String
stringToHtmlString :: ShowS
stringToHtmlString = (Char -> [Char]) -> ShowS
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> [Char]
fixChar
    where
      fixChar :: Char -> [Char]
fixChar Char
'<' = [Char]
"&lt;"
      fixChar Char
'>' = [Char]
"&gt;"
      fixChar Char
'&' = [Char]
"&amp;"
      fixChar Char
'"' = [Char]
"&quot;"
      fixChar Char
c | Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x80 = [Char
c]
      fixChar Char
c = [Char]
"&#" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Char -> Int
ord Char
c) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
";"


-- | This is not processed for special chars.
-- use stringToHtml or lineToHtml instead, for user strings,
-- because they understand special chars, like @'<'@.
primHtml :: String -> Html
primHtml :: [Char] -> Html
primHtml [Char]
x | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
x    = [HtmlElement] -> Html
Html []
           | Bool
otherwise = [HtmlElement] -> Html
Html [[Char] -> HtmlElement
HtmlString [Char]
x]



--
-- * Html Rendering
--

mkHtml :: HTML html => html -> Html
mkHtml :: forall a. HTML a => a -> Html
mkHtml = ([Char] -> Html -> Html
tag [Char]
"html" (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [[Char] -> [Char] -> HtmlAttr
strAttr [Char]
"xmlns" [Char]
"http://www.w3.org/1999/xhtml"] (Html -> Html) -> html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<)

-- | Output the HTML without adding newlines or spaces within the markup.
--   This should be the most time and space efficient way to
--   render HTML, though the output is quite unreadable.
showHtmlInternal :: HTML html =>
                    String -- ^ DOCTYPE declaration
                 -> html -> String
showHtmlInternal :: forall html. HTML html => [Char] -> html -> [Char]
showHtmlInternal [Char]
docType html
theHtml =
    [Char]
docType [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Html -> [Char]
forall html. HTML html => html -> [Char]
showHtmlFragment (html -> Html
forall a. HTML a => a -> Html
mkHtml html
theHtml)

-- | Outputs indented HTML. Because space matters in
--   HTML, the output is quite messy.
renderHtmlInternal :: HTML html =>
                      String  -- ^ DOCTYPE declaration
                   -> html -> String
renderHtmlInternal :: forall html. HTML html => [Char] -> html -> [Char]
renderHtmlInternal [Char]
docType html
theHtml =
      [Char]
docType [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Html -> [Char]
forall html. HTML html => html -> [Char]
renderHtmlFragment (html -> Html
forall a. HTML a => a -> Html
mkHtml html
theHtml) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"

-- | Outputs indented HTML, with indentation inside elements.
--   This can change the meaning of the HTML document, and
--   is mostly useful for debugging the HTML output.
--   The implementation is inefficient, and you are normally
--   better off using 'showHtml' or 'renderHtml'.
prettyHtmlInternal :: HTML html =>
                      String -- ^ DOCTYPE declaration
                   -> html -> String
prettyHtmlInternal :: forall html. HTML html => [Char] -> html -> [Char]
prettyHtmlInternal [Char]
docType html
theHtml =
    [Char]
docType [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Html -> [Char]
forall html. HTML html => html -> [Char]
prettyHtmlFragment (html -> Html
forall a. HTML a => a -> Html
mkHtml html
theHtml)

-- | Render a piece of HTML without adding a DOCTYPE declaration
--   or root element. Does not add any extra whitespace.
showHtmlFragment :: HTML html => html -> String
showHtmlFragment :: forall html. HTML html => html -> [Char]
showHtmlFragment html
h =
    ((ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id ([ShowS] -> ShowS) -> [ShowS] -> ShowS
forall a b. (a -> b) -> a -> b
$ (HtmlElement -> ShowS) -> [HtmlElement] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> ShowS
showHtml' ([HtmlElement] -> [ShowS]) -> [HtmlElement] -> [ShowS]
forall a b. (a -> b) -> a -> b
$ Html -> [HtmlElement]
getHtmlElements (Html -> [HtmlElement]) -> Html -> [HtmlElement]
forall a b. (a -> b) -> a -> b
$ html -> Html
forall a. HTML a => a -> Html
toHtml html
h) [Char]
""

-- | Render a piece of indented HTML without adding a DOCTYPE declaration
--   or root element. Only adds whitespace where it does not change
--   the meaning of the document.
renderHtmlFragment :: HTML html => html -> String
renderHtmlFragment :: forall html. HTML html => html -> [Char]
renderHtmlFragment html
h =
    ((ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id ([ShowS] -> ShowS) -> [ShowS] -> ShowS
forall a b. (a -> b) -> a -> b
$ (HtmlElement -> ShowS) -> [HtmlElement] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> HtmlElement -> ShowS
renderHtml' Int
0) ([HtmlElement] -> [ShowS]) -> [HtmlElement] -> [ShowS]
forall a b. (a -> b) -> a -> b
$ Html -> [HtmlElement]
getHtmlElements (Html -> [HtmlElement]) -> Html -> [HtmlElement]
forall a b. (a -> b) -> a -> b
$ html -> Html
forall a. HTML a => a -> Html
toHtml html
h) [Char]
""

-- | Render a piece of indented HTML without adding a DOCTYPE declaration
--   or a root element.
--   The indentation is done inside elements.
--   This can change the meaning of the HTML document, and
--   is mostly useful for debugging the HTML output.
--   The implementation is inefficient, and you are normally
--   better off using 'showHtmlFragment' or 'renderHtmlFragment'.
prettyHtmlFragment :: HTML html => html -> String
prettyHtmlFragment :: forall html. HTML html => html -> [Char]
prettyHtmlFragment =
    [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> (html -> [[Char]]) -> html -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> [[Char]])
-> (html -> [[[Char]]]) -> html -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HtmlElement -> [[Char]]) -> [HtmlElement] -> [[[Char]]]
forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> [[Char]]
prettyHtml' ([HtmlElement] -> [[[Char]]])
-> (html -> [HtmlElement]) -> html -> [[[Char]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [HtmlElement]
getHtmlElements (Html -> [HtmlElement]) -> (html -> Html) -> html -> [HtmlElement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. html -> Html
forall a. HTML a => a -> Html
toHtml

-- | Show a single HTML element, without adding whitespace.
showHtml' :: HtmlElement -> ShowS
showHtml' :: HtmlElement -> ShowS
showHtml' (HtmlString [Char]
str) = [Char] -> ShowS
forall a. [a] -> [a] -> [a]
(++) [Char]
str
showHtml'(HtmlTag { markupTag :: HtmlElement -> [Char]
markupTag = [Char]
name,
                    markupContent :: HtmlElement -> Html
markupContent = Html
html,
                    markupAttrs :: HtmlElement -> [HtmlAttr]
markupAttrs = [HtmlAttr]
attrs })
    = if Html -> Bool
isNoHtml Html
html Bool -> Bool -> Bool
&& [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char]
name [[Char]]
validHtmlITags
      then Bool -> [Char] -> [HtmlAttr] -> [Char] -> ShowS
renderTag Bool
True [Char]
name [HtmlAttr]
attrs [Char]
""
      else (Bool -> [Char] -> [HtmlAttr] -> [Char] -> ShowS
renderTag Bool
False [Char]
name [HtmlAttr]
attrs [Char]
""
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id ((HtmlElement -> ShowS) -> [HtmlElement] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> ShowS
showHtml' (Html -> [HtmlElement]
getHtmlElements Html
html))
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> ShowS
renderEndTag [Char]
name [Char]
"")

renderHtml' :: Int -> HtmlElement -> ShowS
renderHtml' :: Int -> HtmlElement -> ShowS
renderHtml' Int
_ (HtmlString [Char]
str) = [Char] -> ShowS
forall a. [a] -> [a] -> [a]
(++) [Char]
str
renderHtml' Int
n (HtmlTag
              { markupTag :: HtmlElement -> [Char]
markupTag = [Char]
name,
                markupContent :: HtmlElement -> Html
markupContent = Html
html,
                markupAttrs :: HtmlElement -> [HtmlAttr]
markupAttrs = [HtmlAttr]
attrs })
      = if Html -> Bool
isNoHtml Html
html Bool -> Bool -> Bool
&& [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char]
name [[Char]]
validHtmlITags
        then Bool -> [Char] -> [HtmlAttr] -> [Char] -> ShowS
renderTag Bool
True [Char]
name [HtmlAttr]
attrs (Int -> [Char]
nl Int
n)
        else (Bool -> [Char] -> [HtmlAttr] -> [Char] -> ShowS
renderTag Bool
False [Char]
name [HtmlAttr]
attrs (Int -> [Char]
nl Int
n)
             ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ShowS
forall a. a -> a
id ((HtmlElement -> ShowS) -> [HtmlElement] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> HtmlElement -> ShowS
renderHtml' (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)) (Html -> [HtmlElement]
getHtmlElements Html
html))
             ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> ShowS
renderEndTag [Char]
name (Int -> [Char]
nl Int
n))
    where
      nl :: Int -> [Char]
nl Int
n' = [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
n' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8) Char
'\t'
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
n' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8) Char
' '


prettyHtml' :: HtmlElement -> [String]
prettyHtml' :: HtmlElement -> [[Char]]
prettyHtml' (HtmlString [Char]
str) = [[Char]
str]
prettyHtml' (HtmlTag
              { markupTag :: HtmlElement -> [Char]
markupTag = [Char]
name,
                markupContent :: HtmlElement -> Html
markupContent = Html
html,
                markupAttrs :: HtmlElement -> [HtmlAttr]
markupAttrs = [HtmlAttr]
attrs })
      = if Html -> Bool
isNoHtml Html
html Bool -> Bool -> Bool
&& [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char]
name [[Char]]
validHtmlITags
        then
         [ShowS
rmNL (Bool -> [Char] -> [HtmlAttr] -> [Char] -> ShowS
renderTag Bool
True [Char]
name [HtmlAttr]
attrs [Char]
"" [Char]
"")]
        else
         [ShowS
rmNL (Bool -> [Char] -> [HtmlAttr] -> [Char] -> ShowS
renderTag Bool
False [Char]
name [HtmlAttr]
attrs [Char]
"" [Char]
"")] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
          [[Char]] -> [[Char]]
shift ([[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((HtmlElement -> [[Char]]) -> [HtmlElement] -> [[[Char]]]
forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> [[Char]]
prettyHtml' (Html -> [HtmlElement]
getHtmlElements Html
html))) [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
         [ShowS
rmNL ([Char] -> [Char] -> ShowS
renderEndTag [Char]
name [Char]
"" [Char]
"")]
  where
      shift :: [[Char]] -> [[Char]]
shift = ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
x -> [Char]
"   " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
x)
      rmNL :: ShowS
rmNL = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')


-- | Show a start tag
renderTag :: Bool       -- ^ 'True' if the empty tag shorthand should be used
          -> String     -- ^ Tag name
          -> [HtmlAttr] -- ^ Attributes
          -> String     -- ^ Whitespace to add after attributes
          -> ShowS
renderTag :: Bool -> [Char] -> [HtmlAttr] -> [Char] -> ShowS
renderTag Bool
empty [Char]
name [HtmlAttr]
attrs [Char]
nl [Char]
r
      = [Char]
"<" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
shownAttrs [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
nl [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
close [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
r
  where
      close :: [Char]
close = if Bool
empty then [Char]
" />" else [Char]
">"

      shownAttrs :: [Char]
shownAttrs = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:HtmlAttr -> [Char]
showPair HtmlAttr
attr | HtmlAttr
attr <- [HtmlAttr]
attrs ]

      showPair :: HtmlAttr -> String
      showPair :: HtmlAttr -> [Char]
showPair (HtmlAttr [Char]
key [Char]
val)
              = [Char]
key [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"=\"" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
val  [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\""

-- | Show an end tag
renderEndTag :: String -- ^ Tag name
             -> String -- ^ Whitespace to add after tag name
             -> ShowS
renderEndTag :: [Char] -> [Char] -> ShowS
renderEndTag [Char]
name [Char]
nl [Char]
r = [Char]
"</" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
nl [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
">" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
r


-- | The names of all elements which can represented using the empty tag
--   short-hand.
validHtmlITags :: [String]
validHtmlITags :: [[Char]]
validHtmlITags = [
                  [Char]
"area",
                  [Char]
"base",
                  [Char]
"basefont",
                  [Char]
"br",
                  [Char]
"col",
                  [Char]
"frame",
                  [Char]
"hr",
                  [Char]
"img",
                  [Char]
"input",
                  [Char]
"isindex",
                  [Char]
"link",
                  [Char]
"meta",
                  [Char]
"param"
                 ]