{-# 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 = [
('&', 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
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
renderAsHTML' n :: Int
n e :: XML
e = Int -> XML -> Builder
renderElement Int
n XML
e
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
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
}