{-#LANGUAGE OverloadedStrings #-} {-#LANGUAGE TypeSynonymInstances #-} {-#LANGUAGE FlexibleInstances #-} module Text.Tamper.Render.Html ( htmlReducer , htmlEncode ) where import Text.Tamper import Data.Monoid import Data.String import qualified Text.Tamper.DOM as DOM import qualified Data.Text as Text import qualified Data.Text.Lazy as LText class Encode t where encode :: (Char -> t) -> t -> t instance Encode String where encode = concatMap instance Encode Text.Text where encode f = mconcat . map f . Text.unpack instance Encode LText.Text where encode f = mconcat . map f . LText.unpack htmlEncode :: (Encode t, IsString t) => t -> t htmlEncode = encode htmlEncodeChar htmlEncodeChar :: IsString t => Char -> t htmlEncodeChar '<' = "<" htmlEncodeChar '>' = ">" htmlEncodeChar '&' = "&" htmlEncodeChar '"' = """ htmlEncodeChar '\'' = "'" htmlEncodeChar c = fromString [c] htmlReducer :: (Monoid t, Encode t, IsString t) => DOM.NodeList t -> t htmlReducer = nodeListToHtml nodeListToHtml :: (Monoid t, Encode t, IsString t) => DOM.NodeList t -> t nodeListToHtml nodeList = mconcat $ map nodeToHtml $ DOM.unNodeList nodeList nodeToHtml :: (Monoid t, Encode t, IsString t) => DOM.Node t -> t nodeToHtml (DOM.Document children) = "<!DOCTYPE html>\n" <> nodeListToHtml children nodeToHtml (DOM.Element name attribs children DOM.AutoClosingElement) | null (DOM.unNodeList children) = nodeToHtml (DOM.Element name attribs children DOM.SingletonElement) | otherwise = nodeToHtml (DOM.Element name attribs children DOM.ElaborateElement) nodeToHtml (DOM.Element name attribs children DOM.SingletonElement) = "<" <> name <> attribsToHtml attribs <> ">" nodeToHtml (DOM.Element name attribs children DOM.ElaborateElement) = "<" <> name <> attribsToHtml attribs <> ">" <> nodeListToHtml children <> "</" <> name <> ">" nodeToHtml (DOM.TextNode text) = htmlEncode text nodeToHtml (DOM.CDataSection cdata) = "<[!CDATA[" <> cdata <> "]]>" nodeToHtml (DOM.Comment comment) = "<!-- " <> comment <> " -->" nodeToHtml (DOM.RawHtml html) = html attribsToHtml :: (Monoid t, Encode t, IsString t) => DOM.AttribList t -> t attribsToHtml attribs = mconcat [ " " <> attribToHtml name value | (name, value) <- DOM.attribItems attribs ] attribToHtml :: (Monoid t, Encode t, IsString t) => t -> t -> t attribToHtml name value = htmlEncode name <> "=\"" <> htmlEncode value <> "\""