    {-# LANGUAGE OverloadedStrings #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  HSP.HTML4
    -- Copyright   :  (c) Niklas Broberg, Jeremy Shaw 2008-2012
    -- License     :  BSD-style (see the file LICENSE.txt)
    --
    -- Maintainer  :  Niklas Broberg, niklas.broberg@gmail.com
    -- Stability   :  experimental
    -- Portability :  Haskell 98
    --
    -- Attempt to render XHTML as well-formed HTML 4.01:
    --
    --  1. no short tags are used, e.g., \<script\>\<\/script\> instead of \<script \/\>
    --
    --  2. the end tag is forbidden for some elements, for these we:
    --
    --    * render only the open tag, e.g., \<br\>
    --
    --    * throw an error if the tag contains children
    --
    --  3. optional end tags are always rendered
    --
    -- Currently no validation is performed.
    -----------------------------------------------------------------------------
    module HSP.HTML4
        ( -- * Functions
          renderAsHTML
        , htmlEscapeChars
        -- * Predefined XMLMetaData
        , html4Strict
        , html4StrictFrag
        ) where

    import Data.List                (intersperse)
    import Data.Monoid              ((<>), mconcat)
    import Data.String              (fromString)
    import Data.Text.Lazy.Builder   (Builder, fromLazyText, singleton, toLazyText)
    import Data.Text.Lazy           (Text)
    import HSP.XML                  ( Attribute(..), Attributes, AttrValue(..), Children
                                    , NSName, XML(..), XMLMetaData(..))
    import HSP.XML.PCDATA           (escaper)

    data TagType = Open | Close

    -- This list should be extended.
    htmlEscapeChars :: [(Char, Builder)]
    htmlEscapeChars :: [(Char, Builder)]
    htmlEscapeChars = [
    	(Char
    '&',	String -> Builder
    forall a. IsString a => String -> a
    fromString String
    "amp"  ),
    	(Char
    '\"',	String -> Builder
    forall a. IsString a => String -> a
    fromString String
    "quot" ),
    	(Char
    '<',	String -> Builder
    forall a. IsString a => String -> a
    fromString String
    "lt"	  ),
    	(Char
    '>',	String -> Builder
    forall a. IsString a => String -> a
    fromString String
    "gt"	  )
    	]

    renderTag :: TagType -> Int -> NSName -> Attributes -> Builder
    renderTag :: TagType -> Int -> NSName -> Attributes -> Builder
    renderTag TagType
    typ Int
    n NSName
    name Attributes
    attrs =
            let (Builder
    start,Builder
    end) = case TagType
    typ of
                               TagType
    Open   -> (Char -> Builder
    singleton Char
    '<', Char -> Builder
    singleton Char
    '>')
                               TagType
    Close  -> (String -> Builder
    forall a. IsString a => String -> a
    fromString String
    "</", Char -> Builder
    singleton Char
    '>')
                nam :: Builder
    nam = NSName -> Builder
    showName NSName
    name
                as :: Builder
    as  = Attributes -> Builder
    renderAttrs Attributes
    attrs
             in [Builder] -> Builder
    forall a. Monoid a => [a] -> a
    mconcat [Builder
    start, Builder
    nam, Builder
    as, Builder
    end]

      where renderAttrs :: Attributes -> Builder
            renderAttrs :: Attributes -> Builder
    renderAttrs [] = Builder
    nl
            renderAttrs Attributes
    attrs' = Char -> Builder
    singleton Char
    ' ' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> [Builder] -> Builder
    forall a. Monoid a => [a] -> a
    mconcat [Builder]
    ats  Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder
    nl
              where ats :: [Builder]
    ats = Builder -> [Builder] -> [Builder]
    forall a. a -> [a] -> [a]
    intersperse (Char -> Builder
    singleton Char
    ' ') ([Builder] -> [Builder]) -> [Builder] -> [Builder]
    forall a b. (a -> b) -> a -> b
    $ (Attribute -> Builder) -> Attributes -> [Builder]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Attribute -> Builder
    renderAttr Attributes
    attrs'

            renderAttr :: Attribute -> Builder
            renderAttr :: Attribute -> Builder
    renderAttr (MkAttr (NSName
    nam, (Value Bool
    needsEscape Text
    val))) =
                NSName -> Builder
    showName NSName
    nam Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Char -> Builder
    singleton Char
    '=' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder -> Builder
    renderAttrVal (if Bool
    needsEscape then ([(Char, Builder)] -> Text -> Builder
    escaper [(Char, Builder)]
    htmlEscapeChars Text
    val) else Text -> Builder
    fromLazyText Text
    val)
            renderAttr (MkAttr (NSName
    nam, AttrValue
    NoValue)) = NSName -> Builder
    showName NSName
    nam

            renderAttrVal :: Builder -> Builder
            renderAttrVal :: Builder -> Builder
    renderAttrVal Builder
    s = Char -> Builder
    singleton Char
    '\"' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder
    s Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Char -> Builder
    singleton Char
    '\"'

            showName :: NSName -> Builder
    showName (Maybe Text
    Nothing, Text
    s) = Text -> Builder
    fromLazyText Text
    s
            showName (Just Text
    d, Text
    s)  = Text -> Builder
    fromLazyText Text
    d Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Char -> Builder
    singleton Char
    ':' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Text -> Builder
    fromLazyText Text
    s

            nl :: Builder
    nl = Char -> Builder
    singleton Char
    '\n' Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> String -> Builder
    forall a. IsString a => String -> a
    fromString (Int -> Char -> String
    forall a. Int -> a -> [a]
    replicate Int
    n Char
    ' ')

    renderElement :: Int -> XML -> Builder
    renderElement :: Int -> XML -> Builder
    renderElement Int
    n (Element NSName
    name Attributes
    attrs Children
    children) =
            let open :: Builder
    open  = TagType -> Int -> NSName -> Attributes -> Builder
    renderTag TagType
    Open Int
    n NSName
    name Attributes
    attrs
                cs :: Builder
    cs    = Int -> Children -> Builder
    renderChildren Int
    n Children
    children
                close :: Builder
    close = TagType -> Int -> NSName -> Attributes -> Builder
    renderTag TagType
    Close Int
    n NSName
    name []
             in Builder
    open Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder
    cs Builder -> Builder -> Builder
    forall a. Semigroup a => a -> a -> a
    <> Builder
    close
      where renderChildren :: Int -> Children -> Builder
            renderChildren :: Int -> Children -> Builder
    renderChildren Int
    n' Children
    cs = [Builder] -> Builder
    forall a. Monoid a => [a] -> a
    mconcat ([Builder] -> Builder) -> [Builder] -> Builder
    forall a b. (a -> b) -> a -> b
    $ (XML -> Builder) -> Children -> [Builder]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> XML -> Builder
    renderAsHTML' (Int
    n'Int -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    2)) Children
    cs
    renderElement Int
    _ XML
    _ = String -> Builder
    forall a. HasCallStack => String -> a
    error String
    "internal error: renderElement only suports the Element constructor."

    renderAsHTML' :: Int -> XML -> Builder
    renderAsHTML' :: Int -> XML -> Builder
    renderAsHTML' Int
    _ (CDATA Bool
    needsEscape Text
    cd) = if Bool
    needsEscape then ([(Char, Builder)] -> Text -> Builder
    escaper [(Char, Builder)]
    htmlEscapeChars Text
    cd) else Text -> Builder
    fromLazyText Text
    cd
    renderAsHTML' Int
    n elm :: XML
    elm@(Element name :: NSName
    name@(Maybe Text
    Nothing,Text
    nm) Attributes
    attrs Children
    children)
        | Text
    nm Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "area"	= Children -> Builder
    renderTagEmpty Children
    children
        | Text
    nm Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "base"	= Children -> Builder
    renderTagEmpty Children
    children
        | Text
    nm Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "br"        = Children -> Builder
    renderTagEmpty Children
    children
        | Text
    nm Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "col"       = Children -> Builder
    renderTagEmpty Children
    children
        | Text
    nm Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "hr"        = Children -> Builder
    renderTagEmpty Children
    children
        | Text
    nm Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "img"       = Children -> Builder
    renderTagEmpty Children
    children
        | Text
    nm Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "input"     = Children -> Builder
    renderTagEmpty Children
    children
        | Text
    nm Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "link"      = Children -> Builder
    renderTagEmpty Children
    children
        | Text
    nm Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "meta"      = Children -> Builder
    renderTagEmpty Children
    children
        | Text
    nm Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "param"     = Children -> Builder
    renderTagEmpty Children
    children
        | Text
    nm Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "script"    = Int -> XML -> Builder
    renderElement Int
    n (NSName -> Attributes -> Children -> XML
    Element NSName
    name Attributes
    attrs ((XML -> XML) -> Children -> Children
    forall a b. (a -> b) -> [a] -> [b]
    map XML -> XML
    asCDATA Children
    children))
        | Text
    nm Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "style"     = Int -> XML -> Builder
    renderElement Int
    n (NSName -> Attributes -> Children -> XML
    Element NSName
    name Attributes
    attrs ((XML -> XML) -> Children -> Children
    forall a b. (a -> b) -> [a] -> [b]
    map XML -> XML
    asCDATA Children
    children))
        where
          renderTagEmpty :: Children -> Builder
    renderTagEmpty [] = TagType -> Int -> NSName -> Attributes -> Builder
    renderTag TagType
    Open Int
    n NSName
    name Attributes
    attrs
          renderTagEmpty Children
    _ = Int -> XML -> Builder
    renderElement Int
    n XML
    elm -- this case should not happen in valid HTML
          -- for and script\/style, render text in element as CDATA not PCDATA
          asCDATA :: XML -> XML
          asCDATA :: XML -> XML
    asCDATA (CDATA Bool
    _ Text
    cd) = (Bool -> Text -> XML
    CDATA Bool
    False Text
    cd)
          asCDATA XML
    o = XML
    o -- this case should not happen in valid HTML
    renderAsHTML' Int
    n XML
    e = Int -> XML -> Builder
    renderElement Int
    n XML
    e

    -- | Pretty-prints HTML values.
    --
    -- Error Handling:
    --
    -- Some tags (such as img) can not contain children in HTML. However,
    -- there is nothing to stop the caller from passing in XML which
    -- contains an img tag with children. There are three basic ways to
    -- handle this:
    --
    --  1. drop the bogus children silently
    --
    --  2. call 'error' \/ raise an exception
    --
    --  3. render the img tag with children -- even though it is invalid
    --
    -- Currently we are taking approach #3, since no other attempts to
    -- validate the data are made in this function. Instead, you can run
    -- the output through a full HTML validator to detect the errors.
    --
    -- #1 seems like a poor choice, since it makes is easy to overlook the
    -- fact that data went missing.
    --
    -- We could raising errors, but you have to be in the IO monad to
    -- catch them. Also, you have to use evaluate if you want to check for
    -- errors. This means you can not start sending the page until the
    -- whole page has been rendered. And you have to store the whole page
    -- in RAM at once. Similar problems occur if we return Either
    -- instead. We mostly care about catching errors and showing them in
    -- the browser during testing, so perhaps this can be configurable.
    --
    -- Another solution would be a compile time error if an empty-only
    -- tag contained children.
    --
    -- FIXME: also verify that the domain is correct
    --
    -- FIXME: what to do if a namespace is encountered
    renderAsHTML :: XML -> Text
    renderAsHTML :: XML -> Text
    renderAsHTML XML
    xml = Builder -> Text
    toLazyText (Builder -> Text) -> Builder -> Text
    forall a b. (a -> b) -> a -> b
    $ Int -> XML -> Builder
    renderAsHTML' Int
    0 XML
    xml

    -- * Pre-defined XMLMetaData

    html4Strict :: Maybe XMLMetaData
    html4Strict :: Maybe XMLMetaData
    html4Strict = XMLMetaData -> Maybe XMLMetaData
    forall a. a -> Maybe a
    Just (XMLMetaData -> Maybe XMLMetaData)
    -> XMLMetaData -> Maybe XMLMetaData
    forall a b. (a -> b) -> a -> b
    $
        XMLMetaData { doctype :: (Bool, Text)
    doctype = (Bool
    True, Text
    "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n")
                    , contentType :: Text
    contentType = Text
    "text/html;charset=utf-8"
                    , preferredRenderer :: XML -> Builder
    preferredRenderer = Int -> XML -> Builder
    renderAsHTML' Int
    0
                    }

    html4StrictFrag :: Maybe XMLMetaData
    html4StrictFrag :: Maybe XMLMetaData
    html4StrictFrag = XMLMetaData -> Maybe XMLMetaData
    forall a. a -> Maybe a
    Just (XMLMetaData -> Maybe XMLMetaData)
    -> XMLMetaData -> Maybe XMLMetaData
    forall a b. (a -> b) -> a -> b
    $
        XMLMetaData { doctype :: (Bool, Text)
    doctype = (Bool
    False, Text
    "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n")
                    , contentType :: Text
    contentType = Text
    "text/html;charset=utf-8"
                    , preferredRenderer :: XML -> Builder
    preferredRenderer = Int -> XML -> Builder
    renderAsHTML' Int
    0
                    }