{-# LANGUAGE OverloadedStrings #-}
module HSP.HTML4
(
renderAsHTML
, htmlEscapeChars
, 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
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
asCDATA :: XML -> XML
asCDATA :: XML -> XML
asCDATA (CDATA Bool
_ Text
cd) = (Bool -> Text -> XML
CDATA Bool
False Text
cd)
asCDATA XML
o = XML
o
renderAsHTML' Int
n XML
e = Int -> XML -> Builder
renderElement Int
n XML
e
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
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
}