{-# 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 = [
	('&',	String -> Builder
forall a. IsString a => String -> a
fromString "amp"  ),
	('\"',	String -> Builder
forall a. IsString a => String -> a
fromString "quot" ),
	('<',	String -> Builder
forall a. IsString a => String -> a
fromString "lt"	  ),
	('>',	String -> Builder
forall a. IsString a => String -> a
fromString "gt"	  )
	]

renderTag :: TagType -> Int -> NSName -> Attributes -> Builder
renderTag :: TagType -> Int -> NSName -> Attributes -> Builder
renderTag typ :: TagType
typ n :: Int
n name :: NSName
name attrs :: Attributes
attrs =
        let (start :: Builder
start,end :: Builder
end) = case TagType
typ of
                           Open   -> (Char -> Builder
singleton '<', Char -> Builder
singleton '>')
                           Close  -> (String -> Builder
forall a. IsString a => String -> a
fromString "</", Char -> Builder
singleton '>')
            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 attrs' :: Attributes
attrs' = Char -> Builder
singleton ' ' 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 ' ') ([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 (nam :: NSName
nam, (Value needsEscape :: Bool
needsEscape val :: Text
val))) =
            NSName -> Builder
showName NSName
nam Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton '=' 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 (nam :: NSName
nam, NoValue)) = NSName -> Builder
showName NSName
nam

        renderAttrVal :: Builder -> Builder
        renderAttrVal :: Builder -> Builder
renderAttrVal s :: Builder
s = Char -> Builder
singleton '\"' 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 '\"'

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

        nl :: Builder
nl = Char -> Builder
singleton '\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 ' ')

renderElement :: Int -> XML -> Builder
renderElement :: Int -> XML -> Builder
renderElement n :: Int
n (Element name :: NSName
name attrs :: Attributes
attrs children :: 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 n' :: Int
n' cs :: 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
+2)) Children
cs
renderElement _ _ = String -> Builder
forall a. HasCallStack => String -> a
error "internal error: renderElement only suports the Element constructor."

renderAsHTML' :: Int -> XML -> Builder
renderAsHTML' :: Int -> XML -> Builder
renderAsHTML' _ (CDATA needsEscape :: Bool
needsEscape cd :: Text
cd) = if Bool
needsEscape then ([(Char, Builder)] -> Text -> Builder
escaper [(Char, Builder)]
htmlEscapeChars Text
cd) else Text -> Builder
fromLazyText Text
cd
renderAsHTML' n :: Int
n elm :: XML
elm@(Element name :: NSName
name@(Nothing,nm :: Text
nm) attrs :: Attributes
attrs children :: Children
children)
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "area"	= Children -> Builder
renderTagEmpty Children
children
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "base"	= Children -> Builder
renderTagEmpty Children
children
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "br"        = Children -> Builder
renderTagEmpty Children
children
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "col"       = Children -> Builder
renderTagEmpty Children
children
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "hr"        = Children -> Builder
renderTagEmpty Children
children
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "img"       = Children -> Builder
renderTagEmpty Children
children
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "input"     = Children -> Builder
renderTagEmpty Children
children
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "link"      = Children -> Builder
renderTagEmpty Children
children
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "meta"      = Children -> Builder
renderTagEmpty Children
children
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "param"     = Children -> Builder
renderTagEmpty Children
children
    | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "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
== "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 _ = 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 _ cd :: Text
cd) = (Bool -> Text -> XML
CDATA Bool
False Text
cd)
      asCDATA o :: XML
o = XML
o -- this case should not happen in valid HTML
renderAsHTML' n :: Int
n e :: 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
xml = Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Int -> XML -> Builder
renderAsHTML' 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, "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n")
                , contentType :: Text
contentType = "text/html;charset=utf-8"
                , preferredRenderer :: XML -> Builder
preferredRenderer = Int -> XML -> Builder
renderAsHTML' 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, "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n")
                , contentType :: Text
contentType = "text/html;charset=utf-8"
                , preferredRenderer :: XML -> Builder
preferredRenderer = Int -> XML -> Builder
renderAsHTML' 0
                }