src/Text/XHtmlCombinators/Combinators.lhs

> {-# LANGUAGE OverloadedStrings #-}
> module Text.XHtmlCombinators.Combinators where
>
> import Control.Applicative hiding (empty)
> import Data.Text.Lazy (Text)
> import qualified Data.Sequence as Seq
> import qualified Data.Text.Lazy as T
>
> import Text.XHtmlCombinators.Internal

%HTMLlat1; %HTMLsymbol; %HTMLspecial;

> class CData c where
>     cdata :: Text -> c
>
> text :: CData c => Text -> XHtml c
> text = tellS . cdata
>
> newtype InlineContent = Inline { inlineToNode :: Node }
>
> instance Content InlineContent where 
>     toContent = inlineToNode
>
> instance CData InlineContent where
>     cdata = Inline . TextNode
> 
> class Inline c where
>     inline :: Node -> c
>
> instance Inline InlineContent where inline = Inline
> instance Inline FlowContent where inline = Flow

> newtype BlockContent = Block { blockToNode :: Node }
>
> instance Content BlockContent where 
>     toContent = blockToNode
>
> class Block c where
>     block :: Node -> c
>
> instance Block BlockContent where block = Block
> instance Block FlowContent where block = Flow

> newtype FlowContent = Flow { flowToNode :: Node }
>
> instance Content FlowContent where 
>     toContent = flowToNode
>
> instance CData FlowContent where
>     cdata = Flow . TextNode
>
> class Flow c where
>     flow :: Node -> c
>
> instance Flow BlockContent where flow = Block
> instance Flow InlineContent where flow = Inline
> instance Flow FlowContent where flow = Flow

> newtype Page = Page { pageToNode :: Node }
>
> newtype TopLevelContent = TopLevel { topLevelToNode :: Node }
>
> instance Content Page where toContent = pageToNode
>
> instance Content TopLevelContent where 
>     toContent = topLevelToNode

> xhtml10strict :: Text
> xhtml10strict = "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\
>                 \ \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"
>
> doctype = tellS . Page . TextNode $ xhtml10strict
>
> xmlDec = tellS . Page . TextNode $ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
>
> html' :: Bool -- ^ True for XML declaration, false to omit.
>      -> Attrs -> XHtml TopLevelContent -> XHtml Page
> html' useXmlDec attrs x = do
>     if useXmlDec then xmlDec else empty
>     doctype 
>     tellNode Page "html" [Attr "xmlns" "http://www.w3.org/1999/xhtml"] attrs x
>
> html :: Bool -> XHtml TopLevelContent -> XHtml Page
> html useXmlDec = html' useXmlDec []

> newtype HeadContent = Head { headToNode :: Node }
>
> instance Content HeadContent where 
>     toContent = headToNode

> head' :: Attrs -> XHtml HeadContent -> XHtml TopLevelContent
> head' = tellNode TopLevel "head" []
>
> head_ :: XHtml HeadContent -> XHtml TopLevelContent
> head_ = head' []

> title' :: Attrs -> Text -> XHtml HeadContent
> title' = tellTextNode Head "title" []
>
> title :: Text -> XHtml HeadContent
> title = title' []

> base' :: Text -> Attrs -> XHtml HeadContent
> base' href = tellEmptyNode Head "base" [Attr "href" href]
>
> base :: Text -> XHtml HeadContent
> base = flip base' []

> meta' :: Text -- ^ Required content attribute.
>       -> Attrs -> XHtml HeadContent
> meta' content = tellEmptyNode Head "meta" [Attr "content" content]
>
> meta :: Text -> XHtml HeadContent
> meta = flip meta' []

> link' :: Attrs -> XHtml HeadContent
> link' = tellEmptyNode Head "link" []
>
> link :: XHtml HeadContent
> link = link' []
> -- ^ 'link' is a bit useless without any attributes, but it's 
> -- included anyway for consistency reasons.

> style' :: Text -- ^ Required type attribute.
>        -> Attrs -> Text -> XHtml HeadContent
> style' sType = tellTextNode Head "style" [Attr "type" sType]
>
> style :: Text -> Text -> XHtml HeadContent
> style = flip style' []

> script' :: Text -- ^ Required type attribute.
>         -> Attrs -> Text -> XHtml HeadContent
> script' sType = tellTextNode Head "script" [Attr "type" sType]
>
> script :: Text -> Text -> XHtml HeadContent
> script = flip script' []

> noscript' :: Block c => Attrs -> XHtml BlockContent -> XHtml c
> noscript' = tellNode block "noscript" []
>
> noscript :: Block c => XHtml BlockContent -> XHtml c
> noscript = noscript' []

> body' :: Attrs -> XHtml BlockContent -> XHtml TopLevelContent
> body' = tellNode TopLevel "body" []
>
> body :: XHtml BlockContent -> XHtml TopLevelContent
> body = body' []

> div' :: Block c => Attrs -> XHtml FlowContent -> XHtml c
> div' = tellNode block "div" []
> 
> div_ :: Block c => XHtml FlowContent -> XHtml c
> div_ = div' []

> p' :: Block c => Attrs -> XHtml InlineContent -> XHtml c
> p' = tellNode block "p" []
>
> p :: Block c => XHtml InlineContent -> XHtml c
> p = p' []

> h1' :: Block c => Attrs -> XHtml InlineContent -> XHtml c
> h1' = tellNode block "h1" []
>
> h1 :: Block c => XHtml InlineContent -> XHtml c
> h1 = h1' []

> h2' :: Block c => Attrs -> XHtml InlineContent -> XHtml c
> h2' = tellNode block "h2" []
>
> h2 :: Block c => XHtml InlineContent -> XHtml c
> h2 = h2' []

> h3' :: Block c => Attrs -> XHtml InlineContent -> XHtml c
> h3' = tellNode block "h3" []
>
> h3 :: Block c => XHtml InlineContent -> XHtml c
> h3 = h3' []

> h4' :: Block c => Attrs -> XHtml InlineContent -> XHtml c
> h4' = tellNode block "h4" []
>
> h4 :: Block c => XHtml InlineContent -> XHtml c
> h4 = h4' []

> h5' :: Block c => Attrs -> XHtml InlineContent -> XHtml c
> h5' = tellNode block "h5" []
>
> h5 :: Block c => XHtml InlineContent -> XHtml c
> h5 = h5' []

> h6' :: Block c => Attrs -> XHtml InlineContent -> XHtml c
> h6' = tellNode block "h6" []
>
> h6 :: Block c => XHtml InlineContent -> XHtml c
> h6 = h6' []

> newtype ListContent = List { listToNode :: Node }
>
> instance Content ListContent where
>     toContent = listToNode

> ul' :: Block c => Attrs -> XHtml ListContent -> XHtml c
> ul' = tellNode block "ul" []
>
> ul :: Block c => XHtml ListContent -> XHtml c
> ul = ul' []

> ol' :: Block c => Attrs -> XHtml ListContent -> XHtml c
> ol' = tellNode block "ol" []
>
> ol :: Block c => XHtml ListContent -> XHtml c
> ol = ol' []

> li' :: Attrs -> XHtml FlowContent -> XHtml ListContent
> li' = tellNode List "li" []
>
> li :: XHtml FlowContent -> XHtml ListContent
> li = li' []

> newtype DefinitionListContent = 
>     DefinitionList { definitionListToNode :: Node }
>
> instance Content DefinitionListContent where
>     toContent = definitionListToNode

> dl' :: Block c => Attrs -> XHtml DefinitionListContent -> XHtml c
> dl' = tellNode block "dl" []
>
> dl :: Block c => XHtml DefinitionListContent -> XHtml c
> dl = dl' []

> dt' :: Attrs -> XHtml InlineContent -> XHtml DefinitionListContent
> dt' = tellNode DefinitionList "dt" []
>
> dt :: XHtml InlineContent -> XHtml DefinitionListContent
> dt = dt' []

> dd' :: Attrs -> XHtml InlineContent -> XHtml DefinitionListContent
> dd' = tellNode DefinitionList "dd" []
>
> dd :: XHtml InlineContent -> XHtml DefinitionListContent
> dd = dd' []

> address' :: Block c => Attrs -> XHtml InlineContent -> XHtml c
> address' = tellNode block "address" []
>
> address :: Block c => XHtml InlineContent -> XHtml c
> address = address' []

> hr' :: Block c => Attrs -> XHtml c
> hr' = tellEmptyNode block "hr" []
>
> hr :: Block c => XHtml c
> hr = hr' []

> pre' :: Block c => Attrs -> XHtml InlineContent -> XHtml c
> pre' = tellNode block "pre" []
>
> pre :: Block c => XHtml InlineContent -> XHtml c
> pre = pre' []

> blockquote' :: Block c => Attrs -> XHtml BlockContent -> XHtml c
> blockquote' = tellNode block "blockquote" []
>
> blockquote :: Block c => XHtml BlockContent -> XHtml c
> blockquote = blockquote' []

> ins' :: (Flow c, Content c) => Attrs -> XHtml c -> XHtml c
> ins' = tellNode flow "ins" []
>
> ins :: (Flow c, Content c) => XHtml c -> XHtml c
> ins = ins' []

> del' :: (Flow c, Content c) => Attrs -> XHtml c -> XHtml c
> del' = tellNode flow "del" []
>
> del :: (Flow c, Content c) => XHtml c -> XHtml c
> del = del' []

> a' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> a' = tellNode inline "a" []
>
> a :: Inline c => XHtml InlineContent -> XHtml c
> a = a' []

> span' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> span' = tellNode inline "span" []
>
> span_ :: Inline c => XHtml InlineContent -> XHtml c
> span_ = span' []

> bdo' :: Inline c 
>      => Text -- ^ Required language direction code.
>      -> Attrs -> XHtml InlineContent -> XHtml c
> bdo' dir = tellNode inline "bdo" [Attr "dir" dir]
>
> bdo :: Inline c => Text -> XHtml InlineContent -> XHtml c
> bdo = flip bdo' []

> br' :: Inline c => Attrs -> XHtml c
> br' = tellEmptyNode inline "br" []
>
> br :: Inline c => XHtml c
> br = br' []

> em' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> em' = tellNode inline "em" []
>
> em :: Inline c => XHtml InlineContent -> XHtml c
> em = em' []

> strong' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> strong' = tellNode inline "strong" []
>
> strong :: Inline c => XHtml InlineContent -> XHtml c
> strong = strong' []

> dfn' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> dfn' = tellNode inline "dfn" []
>
> dfn :: Inline c => XHtml InlineContent -> XHtml c
> dfn = dfn' []

> code' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> code' = tellNode inline "code" []
>
> code :: Inline c => XHtml InlineContent -> XHtml c
> code = code' []

> samp' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> samp' = tellNode inline "samp" []
>
> samp :: Inline c => XHtml InlineContent -> XHtml c
> samp = samp' []

> kbd' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> kbd' = tellNode inline "kbd" []
>
> kbd :: Inline c => XHtml InlineContent -> XHtml c
> kbd = kbd' []

> var' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> var' = tellNode inline "var" []
>
> var :: Inline c => XHtml InlineContent -> XHtml c
> var = var' []

> cite' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> cite' = tellNode inline "cite" []
>
> cite :: Inline c => XHtml InlineContent -> XHtml c
> cite = cite' []

> abbr' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> abbr' = tellNode inline "abbr" []
>
> abbr :: Inline c => XHtml InlineContent -> XHtml c
> abbr = abbr' []

> acronym' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> acronym' = tellNode inline "acronym" []
>
> acronym :: Inline c => XHtml InlineContent -> XHtml c
> acronym = acronym' []

> q' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> q' = tellNode inline "q" []
>
> q :: Inline c => XHtml InlineContent -> XHtml c
> q = q' []

> sub' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> sub' = tellNode inline "sub" []
>
> sub :: Inline c => XHtml InlineContent -> XHtml c
> sub = sub' []

> sup' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> sup' = tellNode inline "sup" []
>
> sup :: Inline c => XHtml InlineContent -> XHtml c
> sup = sup' []

> tt' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> tt' = tellNode inline "tt" []
>
> tt :: Inline c => XHtml InlineContent -> XHtml c
> tt = tt' []

> i' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> i' = tellNode inline "i" []
>
> i :: Inline c => XHtml InlineContent -> XHtml c
> i = i' []

> b' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> b' = tellNode inline "b" []
>
> b :: Inline c => XHtml InlineContent -> XHtml c
> b = b' []

> big' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> big' = tellNode inline "big" []
>
> big :: Inline c => XHtml InlineContent -> XHtml c
> big = big' []

> small' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> small' = tellNode inline "small" []
>
> small :: Inline c => XHtml InlineContent -> XHtml c
> small = small' []

> newtype ObjectContent = Object { objectToNode :: Node }
>
> instance Content ObjectContent where 
>     toContent = objectToNode
>
> instance Flow ObjectContent where flow = Object
> instance Inline ObjectContent where inline = Object
> instance Block ObjectContent where block = Object

> object' :: Flow c => Attrs -> XHtml ObjectContent -> XHtml c
> object' = tellNode flow "object" []
>
> object :: Flow c => XHtml ObjectContent -> XHtml c
> object = object' []

> param' :: Attrs -> XHtml ObjectContent
> param' = tellEmptyNode Object "param" []
>
> param :: XHtml ObjectContent
> param = param' []

> img' :: Flow c 
>      => Text -- ^ Required src attribute. 
>      -> Text -- ^ Required alt attribute.
>      -> Attrs -> XHtml c
> img' src alt = tellEmptyNode flow "img" []
>
> img :: Flow c => Text -> Text -> XHtml c
> img src alt = img' src alt [Attr "src" src, Attr "alt" alt]

> newtype MapContent = Map { mapToNode :: Node }
>
> instance Content MapContent where 
>     toContent = mapToNode
>
> instance Flow MapContent where flow = Map
> instance Inline MapContent where inline = Map
> instance Block MapContent where block = Map

> map' :: Flow c 
>      => Text -- ^ Required id attribute. 
>      -> Attrs -> XHtml MapContent -> XHtml c
> map' id = tellNode flow "map" [Attr "id" id]
>
> map_ :: Flow c => Text -> XHtml MapContent -> XHtml c
> map_ = flip map' []

> area' :: Text -- ^ Required alt attribute.
>       -> Attrs -> XHtml MapContent
> area' alt = tellEmptyNode Map "area" [Attr "alt" alt]
>
> area :: Text -> XHtml MapContent
> area = flip area' []

> form' :: Block c 
>       => Text -- ^ Required action attribute. 
>       -> Attrs -> XHtml FlowContent -> XHtml c
> form' action = tellNode block "form" [Attr "action" action]
>
> form :: Block c => Text -> XHtml FlowContent -> XHtml c
> form = flip form' []

> label' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c
> label' = tellNode inline "label" []
>
> label :: Inline c => XHtml InlineContent -> XHtml c
> label = label' []

> input' :: Inline c => Attrs -> XHtml c
> input' = tellEmptyNode inline "input" []
>
> input :: Inline c => XHtml c
> input = input' []

> newtype OptionContent = Option { optionToNode :: Node }
>
> instance Content OptionContent where 
>     toContent = optionToNode
>
> select' :: Inline c => Attrs -> XHtml OptionContent -> XHtml c 
> select' = tellNode inline "select" []
>
> select :: Inline c => XHtml OptionContent -> XHtml c
> select = select' []

> optgroup' :: Text -- ^ Required label attribute. 
>           -> Attrs -> XHtml OptionContent -> XHtml OptionContent
> optgroup' label = tellNode Option "optgroup" [Attr "label" label]
>
> optgroup :: Text -> XHtml OptionContent -> XHtml OptionContent
> optgroup = flip optgroup' []

> option' :: Attrs -> Text -> XHtml OptionContent
> option' = tellTextNode Option "option" []
>
> option :: Text -> XHtml OptionContent
> option = option' []

> textarea' :: Inline c
>           => Int -- ^ Required rows attribute.
>           -> Int -- ^ Required cols attribute.
>           -> Attrs -> Text -> XHtml c
> textarea' rows cols = tellTextNode inline "textarea" 
>                           [ Attr "rows" (T.pack (show rows))
>                           , Attr "cols" (T.pack (show cols))
>                           ]
> 
> textarea :: Inline c => Int -> Int -> Text -> XHtml c
> textarea  rows cols = textarea' rows cols []

> newtype FieldSetContent = FieldSet { fieldSetToNode :: Node }
>
> instance Content FieldSetContent where 
>     toContent = fieldSetToNode
>
> instance Flow FieldSetContent where flow = FieldSet
> instance Inline FieldSetContent where inline = FieldSet
> instance Block FieldSetContent where block = FieldSet

> fieldset' :: Block c => Attrs -> XHtml FieldSetContent -> XHtml c
> fieldset' = tellNode block "fieldset" []
>
> fieldset :: Block c => XHtml FieldSetContent -> XHtml c
> fieldset = fieldset' []

> legend' :: Attrs -> XHtml InlineContent -> XHtml FieldSetContent 
> legend' = tellNode FieldSet "legend" []
>
> legend :: XHtml InlineContent -> XHtml FieldSetContent
> legend = legend' []

> button' :: Inline c => Attrs -> XHtml FlowContent -> XHtml c
> button' = tellNode inline "button" []
>
> button :: Inline c => XHtml FlowContent -> XHtml c
> button = button' []

> newtype Table1Content = Table1 { table1ToNode :: Node }
>
> instance Content Table1Content where 
>     toContent = table1ToNode

> newtype Table2Content = Table2 { table2ToNode :: Node }
>
> instance Content Table2Content where 
>     toContent = table2ToNode
>
> newtype Table3Content = Table3 { table3ToNode :: Node }
>
> instance Content Table3Content where 
>     toContent = table3ToNode
>
> newtype TableColContent = TableCol { tableColToNode :: Node }
>
> instance Content TableColContent where 
>     toContent = tableColToNode

> table' :: Block c => Attrs -> XHtml Table1Content -> XHtml c
> table' = tellNode block "table" []
> 
> table :: Block c => XHtml Table1Content -> XHtml c
> table = table' []

> caption' :: Attrs -> XHtml InlineContent -> XHtml Table1Content
> caption' = tellNode Table1 "caption" []
>
> caption :: XHtml InlineContent -> XHtml Table1Content
> caption = caption' []

> thead' :: Attrs -> XHtml Table2Content -> XHtml Table1Content
> thead' = tellNode Table1 "thead" []
>
> thead :: XHtml Table2Content -> XHtml Table1Content
> thead = thead' []

> tfoot' :: Attrs -> XHtml Table2Content -> XHtml Table1Content
> tfoot' = tellNode Table1 "tfoot" []
>
> tfoot :: XHtml Table2Content -> XHtml Table1Content
> tfoot = tfoot' []

> tbody' :: Attrs -> XHtml Table2Content -> XHtml Table1Content
> tbody' = tellNode Table1 "tbody" []
>
> tbody :: XHtml Table2Content -> XHtml Table1Content
> tbody = tbody' []

> colgroup' :: Attrs -> XHtml TableColContent -> XHtml Table1Content
> colgroup' = tellNode Table1 "colgroup" []
>
> colgroup :: XHtml TableColContent -> XHtml Table1Content
> colgroup = colgroup' []

> col' :: Attrs -> XHtml TableColContent
> col' = tellEmptyNode TableCol "col" []
>
> col :: XHtml TableColContent
> col = col' []

> tr' :: Attrs -> XHtml Table3Content -> XHtml Table2Content
> tr' = tellNode Table2 "tr" []
> 
> tr :: XHtml Table3Content -> XHtml Table2Content
> tr = tr' []

> th' :: Attrs -> XHtml FlowContent -> XHtml Table3Content
> th' = tellNode Table3 "th" []
>
> th :: XHtml FlowContent -> XHtml Table3Content
> th = th' []

> td' :: Attrs -> XHtml FlowContent -> XHtml Table3Content
> td' = tellNode Table3 "td" []
>
> td :: XHtml FlowContent -> XHtml Table3Content
> td = td' []