{-# 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 (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 :: (Bool, Text) -> Text -> (XML -> Builder) -> XMLMetaData
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 :: (Bool, Text) -> Text -> (XML -> Builder) -> XMLMetaData
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
                }