xhtml-combinators (empty) → 0.1
raw patch · 8 files changed
+2016/−0 lines, 8 filesdep +basedep +containersdep +mtlsetup-changed
Dependencies added: base, containers, mtl, text, xml
Files
- LICENSE +24/−0
- Setup.lhs +3/−0
- src/Text/XHtmlCombinators.hs +120/−0
- src/Text/XHtmlCombinators/Attributes.hs +117/−0
- src/Text/XHtmlCombinators/Combinators.lhs +1616/−0
- src/Text/XHtmlCombinators/Internal.hs +56/−0
- src/Text/XHtmlCombinators/Render.hs +52/−0
- xhtml-combinators.cabal +28/−0
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2010, Alasdair Armstrong+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * The names of contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ src/Text/XHtmlCombinators.hs view
@@ -0,0 +1,120 @@+module Text.XHtmlCombinators+ ( -- * Types+ -- ** XHtml+ XHtmlM, XHtml+ , Page+ , Content+ , Attrs, Attr (Attr)+ -- ** Element Types+ , TopLevelContent+ , HeadContent+ , Flow, FlowContent+ , Block, BlockContent+ , Inline, InlineContent+ -- *** Misc Element Types+ , ObjectContent+ , MapContent+ -- *** List Element Types+ , ListContent, DefinitionListContent+ -- *** Field Element Types+ , FieldSetContent+ -- *** Table Element Types+ , Table1Content, Table2Content, Table3Content+ , TableColContent+ -- * Combinators+ , html', html+ , text, empty+ -- ** Document Head+ , head', head_+ , title', title+ , base', base+ , meta', meta+ , link', link+ , style', style+ , script', script+ , noscript', noscript+ -- ** Document Body+ , body', body+ , div', div_+ -- ** Paragraphs+ , p', p+ -- ** Headings+ , h1', h1, h2', h2, h3', h3+ , h4', h4, h5', h5, h6', h6+ -- ** Lists+ , ul', ul+ , ol', ol+ , li', li+ -- *** Definition Lists+ , dl', dl+ , dt', dt+ , dd', dd+ -- ** Address+ , address', address+ -- ** Horizontal Rule+ , hr', hr+ -- ** Preformatted Text+ , pre', pre+ -- ** Block-like Quotes+ , blockquote', blockquote+ -- ** Inserted/Deleted Text+ , ins', ins, del', del+ -- ** The Anchor Element+ , a', a+ -- ** Inline Elements+ , span', span_+ , bdo', bdo+ , br', br+ , em', em+ , strong', strong+ , dfn', dfn+ , code', code+ , samp', samp+ , kbd', kbd+ , var', var+ , cite', cite+ , abbr', abbr+ , acronym', acronym+ , q', q+ , sub', sub+ , tt', tt+ , i', i+ , b', b+ , big', big+ , small', small+ -- ** Object+ , object', object, param', param+ -- ** Images+ , img', img + -- ** Client-side image maps+ , map', map_+ , area', area+ -- ** Forms+ , form', form+ , label', label+ , input', input+ , select', select+ , optgroup', optgroup+ , option', option+ , textarea', textarea+ , fieldset', fieldset+ , legend', legend+ , button', button+ -- ** Tables+ , table', table+ , caption', caption+ , thead', thead+ , tfoot', tfoot+ , tbody', tbody+ , colgroup', colgroup+ , col', col+ , tr', tr+ , th', th+ , td', td+ -- * Rendering+ , render+ ) where++import Text.XHtmlCombinators.Combinators+import Text.XHtmlCombinators.Internal+import Text.XHtmlCombinators.Render
+ src/Text/XHtmlCombinators/Attributes.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.XHtmlCombinators.Attributes where++import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T++import Text.XHtmlCombinators.Internal++-- the following was copied almost verbatim from Bjorn Bringert's xhtml library.+-- See: http://hackage.haskell.org/package/xhtml++emptyAttr :: Text -> Attr+emptyAttr name = Attr name name++intAttr :: Text -> Int -> Attr+intAttr name = Attr name . T.pack . show++textAttr :: Text -> Text -> Attr+textAttr name = Attr name++action :: Text -> Attr+align :: Text -> Attr+alt :: Text -> Attr+altcode :: Text -> Attr+archive :: Text -> Attr+base :: Text -> Attr+border :: Int -> Attr+bordercolor :: Text -> Attr+cellpadding :: Int -> Attr+cellspacing :: Int -> Attr+checked :: Attr+codebase :: Text -> Attr+cols :: Text -> Attr+colspan :: Int -> Attr+content :: Text -> Attr+coords :: Text -> Attr+disabled :: Attr+enctype :: Text -> Attr+height :: Text -> Attr+href :: Text -> Attr+hreflang :: Text -> Attr+httpEquiv :: Text -> Attr+id_ :: Text -> Attr+ismap :: Attr+lang :: Text -> Attr+maxlength :: Int -> Attr+method :: Text -> Attr+multiple :: Attr+name :: Text -> Attr+nohref :: Attr+rel :: Text -> Attr+rev :: Text -> Attr+rows :: Text -> Attr+rowspan :: Int -> Attr+rules :: Text -> Attr+selected :: Attr+shape :: Text -> Attr+size :: Text -> Attr+src :: Text -> Attr+class_ :: Text -> Attr+for :: Text -> Attr+style :: Text -> Attr+type_ :: Text -> Attr+title :: Text -> Attr+usemap :: Text -> Attr+valign :: Text -> Attr+value :: Text -> Attr+width :: Text -> Attr++action = textAttr "action"+align = textAttr "align"+alt = textAttr "alt"+altcode = textAttr "altcode"+archive = textAttr "archive"+base = textAttr "base"+border = intAttr "border"+bordercolor = textAttr "bordercolor"+cellpadding = intAttr "cellpadding"+cellspacing = intAttr "cellspacing"+checked = emptyAttr "checked"+codebase = textAttr "codebase"+cols = textAttr "cols"+colspan = intAttr "colspan"+content = textAttr "content"+coords = textAttr "coords"+disabled = emptyAttr "disabled"+enctype = textAttr "enctype"+height = textAttr "height"+href = textAttr "href"+hreflang = textAttr "hreflang"+httpEquiv = textAttr "http-equiv"+id_ = textAttr "id"+ismap = emptyAttr "ismap"+lang = textAttr "lang"+maxlength = intAttr "maxlength"+method = textAttr "method"+multiple = emptyAttr "multiple"+name = textAttr "name"+nohref = emptyAttr "nohref"+rel = textAttr "rel"+rev = textAttr "rev"+rows = textAttr "rows"+rowspan = intAttr "rowspan"+rules = textAttr "rules"+selected = emptyAttr "selected"+shape = textAttr "shape"+size = textAttr "size"+src = textAttr "src"+class_ = textAttr "class"+for = textAttr "for"+style = textAttr "style"+type_ = textAttr "type"+title = textAttr "title"+usemap = textAttr "usemap"+valign = textAttr "valign"+value = textAttr "value"+width = textAttr "width"
+ src/Text/XHtmlCombinators/Combinators.lhs view
@@ -0,0 +1,1616 @@+> {-# 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++<!--+ Extensible HTML version 1.0 Strict DTD++ This is the same as HTML 4 Strict except for+ changes due to the differences between XML and SGML.++ Namespace = http://www.w3.org/1999/xhtml++ For further information, see: http://www.w3.org/TR/xhtml1++ Copyright (c) 1998-2002 W3C (MIT, INRIA, Keio),+ All Rights Reserved. ++ This DTD module is identified by the PUBLIC and SYSTEM identifiers:++ PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"+ SYSTEM "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"++ $Revision: 1.1 $+ $Date: 2002/08/01 13:56:03 $++-->++<!--================ Character mnemonic entities =========================-->++<!ENTITY % HTMLlat1 PUBLIC+ "-//W3C//ENTITIES Latin 1 for XHTML//EN"+ "xhtml-lat1.ent">+%HTMLlat1;++<!ENTITY % HTMLsymbol PUBLIC+ "-//W3C//ENTITIES Symbols for XHTML//EN"+ "xhtml-symbol.ent">+%HTMLsymbol;++<!ENTITY % HTMLspecial PUBLIC+ "-//W3C//ENTITIES Special for XHTML//EN"+ "xhtml-special.ent">+%HTMLspecial;++<!--================== Imported Names ====================================-->++<!ENTITY % ContentType "CDATA">+ <!-- media type, as per [RFC2045] -->++<!ENTITY % ContentTypes "CDATA">+ <!-- comma-separated list of media types, as per [RFC2045] -->++<!ENTITY % Charset "CDATA">+ <!-- a character encoding, as per [RFC2045] -->++<!ENTITY % Charsets "CDATA">+ <!-- a space separated list of character encodings, as per [RFC2045] -->++<!ENTITY % LanguageCode "NMTOKEN">+ <!-- a language code, as per [RFC3066] -->++<!ENTITY % Character "CDATA">+ <!-- a single character, as per section 2.2 of [XML] -->++<!ENTITY % Number "CDATA">+ <!-- one or more digits -->++<!ENTITY % LinkTypes "CDATA">+ <!-- space-separated list of link types -->++<!ENTITY % MediaDesc "CDATA">+ <!-- single or comma-separated list of media descriptors -->++<!ENTITY % URI "CDATA">+ <!-- a Uniform Resource Identifier, see [RFC2396] -->++<!ENTITY % UriList "CDATA">+ <!-- a space separated list of Uniform Resource Identifiers -->++<!ENTITY % Datetime "CDATA">+ <!-- date and time information. ISO date format -->++<!ENTITY % Script "CDATA">+ <!-- script expression -->++<!ENTITY % StyleSheet "CDATA">+ <!-- style sheet data -->++<!ENTITY % Text "CDATA">+ <!-- used for titles etc. -->++<!ENTITY % Length "CDATA">+ <!-- nn for pixels or nn% for percentage length -->++<!ENTITY % MultiLength "CDATA">+ <!-- pixel, percentage, or relative -->++<!ENTITY % Pixels "CDATA">+ <!-- integer representing length in pixels -->++<!-- these are used for image maps -->++<!ENTITY % Shape "(rect|circle|poly|default)">++<!ENTITY % Coords "CDATA">+ <!-- comma separated list of lengths -->++<!--=================== Generic Attributes ===============================-->++<!-- core attributes common to most elements+ id document-wide unique id+ class space separated list of classes+ style associated style info+ title advisory title/amplification+-->+<!ENTITY % coreattrs+ "id ID #IMPLIED+ class CDATA #IMPLIED+ style %StyleSheet; #IMPLIED+ title %Text; #IMPLIED"+ >++<!-- internationalization attributes+ lang language code (backwards compatible)+ xml:lang language code (as per XML 1.0 spec)+ dir direction for weak/neutral text+-->+<!ENTITY % i18n+ "lang %LanguageCode; #IMPLIED+ xml:lang %LanguageCode; #IMPLIED+ dir (ltr|rtl) #IMPLIED"+ >++<!-- attributes for common UI events+ onclick a pointer button was clicked+ ondblclick a pointer button was double clicked+ onmousedown a pointer button was pressed down+ onmouseup a pointer button was released+ onmousemove a pointer was moved onto the element+ onmouseout a pointer was moved away from the element+ onkeypress a key was pressed and released+ onkeydown a key was pressed down+ onkeyup a key was released+-->+<!ENTITY % events+ "onclick %Script; #IMPLIED+ ondblclick %Script; #IMPLIED+ onmousedown %Script; #IMPLIED+ onmouseup %Script; #IMPLIED+ onmouseover %Script; #IMPLIED+ onmousemove %Script; #IMPLIED+ onmouseout %Script; #IMPLIED+ onkeypress %Script; #IMPLIED+ onkeydown %Script; #IMPLIED+ onkeyup %Script; #IMPLIED"+ >++<!-- attributes for elements that can get the focus+ accesskey accessibility key character+ tabindex position in tabbing order+ onfocus the element got the focus+ onblur the element lost the focus+-->+<!ENTITY % focus+ "accesskey %Character; #IMPLIED+ tabindex %Number; #IMPLIED+ onfocus %Script; #IMPLIED+ onblur %Script; #IMPLIED"+ >++<!ENTITY % attrs "%coreattrs; %i18n; %events;">++<!--=================== Text Elements ====================================-->++<!ENTITY % special.pre+ "br | span | bdo | map">++<!ENTITY % special+ "%special.pre; | object | img ">++<!ENTITY % fontstyle "tt | i | b | big | small ">++<!ENTITY % phrase "em | strong | dfn | code | q |+ samp | kbd | var | cite | abbr | acronym | sub | sup ">++<!ENTITY % inline.forms "input | select | textarea | label | button">++<!-- these can occur at block or inline level -->+<!ENTITY % misc.inline "ins | del | script">++<!-- these can only occur at block level -->+<!ENTITY % misc "noscript | %misc.inline;">++<!ENTITY % inline "a | %special; | %fontstyle; | %phrase; | %inline.forms;">++<!-- %Inline; covers inline or "text-level" elements -->+<!ENTITY % Inline "(#PCDATA | %inline; | %misc.inline;)*">++> 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++<!--================== Block level elements ==============================-->++<!ENTITY % heading "h1|h2|h3|h4|h5|h6">+<!ENTITY % lists "ul | ol | dl">+<!ENTITY % blocktext "pre | hr | blockquote | address">++<!ENTITY % block+ "p | %heading; | div | %lists; | %blocktext; | fieldset | table">++<!ENTITY % Block "(%block; | form | %misc;)*">++> 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++<!-- %Flow; mixes block and inline and is used for list items etc. -->+<!ENTITY % Flow "(#PCDATA | %block; | form | %inline; | %misc;)*">++> 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++<!--================== Content models for exclusions =====================-->++<!-- a elements use %Inline; excluding a -->++<!ENTITY % a.content+ "(#PCDATA | %special; | %fontstyle; | %phrase; | %inline.forms; | %misc.inline;)*">++<!-- pre uses %Inline excluding big, small, sup or sup -->++<!ENTITY % pre.content+ "(#PCDATA | a | %fontstyle; | %phrase; | %special.pre; | %misc.inline;+ | %inline.forms;)*">++<!-- form uses %Block; excluding form -->++<!ENTITY % form.content "(%block; | %misc;)*">++<!-- button uses %Flow; but excludes a, form and form controls -->++<!ENTITY % button.content+ "(#PCDATA | p | %heading; | div | %lists; | %blocktext; |+ table | %special; | %fontstyle; | %phrase; | %misc;)*">++<!--================ Document Structure ==================================-->++<!-- the namespace URI designates the document profile -->++<!ELEMENT html (head, body)>+<!ATTLIST html+ %i18n;+ id ID #IMPLIED+ xmlns %URI; #FIXED 'http://www.w3.org/1999/xhtml'+ >++> 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 []++<!--================ Document Head =======================================-->++<!ENTITY % head.misc "(script|style|meta|link|object)*">++> newtype HeadContent = Head { headToNode :: Node }+>+> instance Content HeadContent where +> toContent = headToNode++<!-- content model is %head.misc; combined with a single+ title and an optional base element in any order -->++<!ELEMENT head (%head.misc;,+ ((title, %head.misc;, (base, %head.misc;)?) |+ (base, %head.misc;, (title, %head.misc;))))>++<!ATTLIST head+ %i18n;+ id ID #IMPLIED+ profile %URI; #IMPLIED+ >++> head' :: Attrs -> XHtml HeadContent -> XHtml TopLevelContent+> head' = tellNode TopLevel "head" []+>+> head_ :: XHtml HeadContent -> XHtml TopLevelContent+> head_ = head' []++<!-- The title element is not considered part of the flow of text.+ It should be displayed, for example as the page header or+ window title. Exactly one title is required per document.+ -->+<!ELEMENT title (#PCDATA)>+<!ATTLIST title + %i18n;+ id ID #IMPLIED+ >++> title' :: Attrs -> Text -> XHtml HeadContent+> title' = tellTextNode Head "title" []+>+> title :: Text -> XHtml HeadContent+> title = title' []++<!-- document base URI -->++<!ELEMENT base EMPTY>+<!ATTLIST base+ href %URI; #REQUIRED+ id ID #IMPLIED+ >++> base' :: Text -> Attrs -> XHtml HeadContent+> base' href = tellEmptyNode Head "base" [Attr "href" href]+>+> base :: Text -> XHtml HeadContent+> base = flip base' []++<!-- generic metainformation -->+<!ELEMENT meta EMPTY>+<!ATTLIST meta+ %i18n;+ id ID #IMPLIED+ http-equiv CDATA #IMPLIED+ name CDATA #IMPLIED+ content CDATA #REQUIRED+ scheme CDATA #IMPLIED+ >++> meta' :: Text -- ^ Required content attribute.+> -> Attrs -> XHtml HeadContent+> meta' content = tellEmptyNode Head "meta" [Attr "content" content]+>+> meta :: Text -> XHtml HeadContent+> meta = flip meta' []++<!--+ Relationship values can be used in principle:++ a) for document specific toolbars/menus when used+ with the link element in document head e.g.+ start, contents, previous, next, index, end, help+ b) to link to a separate style sheet (rel="stylesheet")+ c) to make a link to a script (rel="script")+ d) by stylesheets to control how collections of+ html nodes are rendered into printed documents+ e) to make a link to a printable version of this document+ e.g. a PostScript or PDF version (rel="alternate" media="print")+-->++<!ELEMENT link EMPTY>+<!ATTLIST link+ %attrs;+ charset %Charset; #IMPLIED+ href %URI; #IMPLIED+ hreflang %LanguageCode; #IMPLIED+ type %ContentType; #IMPLIED+ rel %LinkTypes; #IMPLIED+ rev %LinkTypes; #IMPLIED+ media %MediaDesc; #IMPLIED+ >++> 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 info, which may include CDATA sections -->+<!ELEMENT style (#PCDATA)>+<!ATTLIST style+ %i18n;+ id ID #IMPLIED+ type %ContentType; #REQUIRED+ media %MediaDesc; #IMPLIED+ title %Text; #IMPLIED+ xml:space (preserve) #FIXED 'preserve'+ >++> 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 statements, which may include CDATA sections -->+<!ELEMENT script (#PCDATA)>+<!ATTLIST script+ id ID #IMPLIED+ charset %Charset; #IMPLIED+ type %ContentType; #REQUIRED+ src %URI; #IMPLIED+ defer (defer) #IMPLIED+ xml:space (preserve) #FIXED 'preserve'+ >++> 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' []++<!-- alternate content container for non script-based rendering -->++<!ELEMENT noscript %Block;>+<!ATTLIST noscript+ %attrs;+ >++> noscript' :: Block c => Attrs -> XHtml BlockContent -> XHtml c+> noscript' = tellNode block "noscript" []+>+> noscript :: Block c => XHtml BlockContent -> XHtml c+> noscript = noscript' []++<!--=================== Document Body ====================================-->++<!ELEMENT body %Block;>+<!ATTLIST body+ %attrs;+ onload %Script; #IMPLIED+ onunload %Script; #IMPLIED+ >++> body' :: Attrs -> XHtml BlockContent -> XHtml TopLevelContent+> body' = tellNode TopLevel "body" []+>+> body :: XHtml BlockContent -> XHtml TopLevelContent+> body = body' [] ++<!ELEMENT div %Flow;> <!-- generic language/style container -->+<!ATTLIST div+ %attrs;+ >++> div' :: Block c => Attrs -> XHtml FlowContent -> XHtml c+> div' = tellNode block "div" []+> +> div_ :: Block c => XHtml FlowContent -> XHtml c+> div_ = div' []++<!--=================== Paragraphs =======================================-->++<!ELEMENT p %Inline;>+<!ATTLIST p+ %attrs;+ >++> p' :: Block c => Attrs -> XHtml InlineContent -> XHtml c+> p' = tellNode block "p" []+>+> p :: Block c => XHtml InlineContent -> XHtml c+> p = p' []++<!--=================== Headings =========================================-->++<!--+ There are six levels of headings from h1 (the most important)+ to h6 (the least important).+-->++<!ELEMENT h1 %Inline;>+<!ATTLIST h1+ %attrs;+ >++> h1' :: Block c => Attrs -> XHtml InlineContent -> XHtml c+> h1' = tellNode block "h1" []+>+> h1 :: Block c => XHtml InlineContent -> XHtml c+> h1 = h1' []++<!ELEMENT h2 %Inline;>+<!ATTLIST h2+ %attrs;+ >++> h2' :: Block c => Attrs -> XHtml InlineContent -> XHtml c+> h2' = tellNode block "h2" []+>+> h2 :: Block c => XHtml InlineContent -> XHtml c+> h2 = h2' []++<!ELEMENT h3 %Inline;>+<!ATTLIST h3+ %attrs;+ >++> h3' :: Block c => Attrs -> XHtml InlineContent -> XHtml c+> h3' = tellNode block "h3" []+>+> h3 :: Block c => XHtml InlineContent -> XHtml c+> h3 = h3' []++<!ELEMENT h4 %Inline;>+<!ATTLIST h4+ %attrs;+ >++> h4' :: Block c => Attrs -> XHtml InlineContent -> XHtml c+> h4' = tellNode block "h4" []+>+> h4 :: Block c => XHtml InlineContent -> XHtml c+> h4 = h4' []++<!ELEMENT h5 %Inline;>+<!ATTLIST h5+ %attrs;+ >++> h5' :: Block c => Attrs -> XHtml InlineContent -> XHtml c+> h5' = tellNode block "h5" []+>+> h5 :: Block c => XHtml InlineContent -> XHtml c+> h5 = h5' []++<!ELEMENT h6 %Inline;>+<!ATTLIST h6+ %attrs;+ >++> h6' :: Block c => Attrs -> XHtml InlineContent -> XHtml c+> h6' = tellNode block "h6" []+>+> h6 :: Block c => XHtml InlineContent -> XHtml c+> h6 = h6' []++<!--=================== Lists ============================================-->++<!-- Unordered list -->++> newtype ListContent = List { listToNode :: Node }+>+> instance Content ListContent where+> toContent = listToNode++<!ELEMENT ul (li)+>+<!ATTLIST ul+ %attrs;+ >++> ul' :: Block c => Attrs -> XHtml ListContent -> XHtml c+> ul' = tellNode block "ul" []+>+> ul :: Block c => XHtml ListContent -> XHtml c+> ul = ul' []++<!-- Ordered (numbered) list -->++<!ELEMENT ol (li)+>+<!ATTLIST ol+ %attrs;+ >++> ol' :: Block c => Attrs -> XHtml ListContent -> XHtml c+> ol' = tellNode block "ol" []+>+> ol :: Block c => XHtml ListContent -> XHtml c+> ol = ol' []++<!-- list item -->++<!ELEMENT li %Flow;>+<!ATTLIST li+ %attrs;+ >++> li' :: Attrs -> XHtml FlowContent -> XHtml ListContent+> li' = tellNode List "li" []+>+> li :: XHtml FlowContent -> XHtml ListContent+> li = li' []++<!-- definition lists - dt for term, dd for its definition -->++> newtype DefinitionListContent = +> DefinitionList { definitionListToNode :: Node }+>+> instance Content DefinitionListContent where+> toContent = definitionListToNode++<!ELEMENT dl (dt|dd)+>+<!ATTLIST dl+ %attrs;+ >++> dl' :: Block c => Attrs -> XHtml DefinitionListContent -> XHtml c+> dl' = tellNode block "dl" []+>+> dl :: Block c => XHtml DefinitionListContent -> XHtml c+> dl = dl' []++<!ELEMENT dt %Inline;>+<!ATTLIST dt+ %attrs;+ >++> dt' :: Attrs -> XHtml InlineContent -> XHtml DefinitionListContent+> dt' = tellNode DefinitionList "dt" []+>+> dt :: XHtml InlineContent -> XHtml DefinitionListContent+> dt = dt' []++<!ELEMENT dd %Flow;>+<!ATTLIST dd+ %attrs;+ >++> dd' :: Attrs -> XHtml InlineContent -> XHtml DefinitionListContent+> dd' = tellNode DefinitionList "dd" []+>+> dd :: XHtml InlineContent -> XHtml DefinitionListContent+> dd = dd' []++<!--=================== Address ==========================================-->++<!-- information on author -->++<!ELEMENT address %Inline;>+<!ATTLIST address+ %attrs;+ >++> address' :: Block c => Attrs -> XHtml InlineContent -> XHtml c+> address' = tellNode block "address" []+>+> address :: Block c => XHtml InlineContent -> XHtml c+> address = address' []++<!--=================== Horizontal Rule ==================================-->++<!ELEMENT hr EMPTY>+<!ATTLIST hr+ %attrs;+ >++> hr' :: Block c => Attrs -> XHtml c+> hr' = tellEmptyNode block "hr" []+>+> hr :: Block c => XHtml c+> hr = hr' []++<!--=================== Preformatted Text ================================-->++<!-- content is %Inline; excluding "img|object|big|small|sub|sup" -->++<!ELEMENT pre %pre.content;>+<!ATTLIST pre+ %attrs;+ xml:space (preserve) #FIXED 'preserve'+ >++> pre' :: Block c => Attrs -> XHtml InlineContent -> XHtml c+> pre' = tellNode block "pre" []+>+> pre :: Block c => XHtml InlineContent -> XHtml c+> pre = pre' []++<!--=================== Block-like Quotes ================================-->++<!ELEMENT blockquote %Block;>+<!ATTLIST blockquote+ %attrs;+ cite %URI; #IMPLIED+ >++> blockquote' :: Block c => Attrs -> XHtml BlockContent -> XHtml c+> blockquote' = tellNode block "blockquote" []+>+> blockquote :: Block c => XHtml BlockContent -> XHtml c+> blockquote = blockquote' []++<!--=================== Inserted/Deleted Text ============================-->++<!--+ ins/del are allowed in block and inline content, but its+ inappropriate to include block content within an ins element+ occurring in inline content.+-->+<!ELEMENT ins %Flow;>+<!ATTLIST ins+ %attrs;+ cite %URI; #IMPLIED+ datetime %Datetime; #IMPLIED+ >++> 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' []++<!ELEMENT del %Flow;>+<!ATTLIST del+ %attrs;+ cite %URI; #IMPLIED+ datetime %Datetime; #IMPLIED+ >++> 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' []++<!--================== The Anchor Element ================================-->++<!-- content is %Inline; except that anchors shouldn't be nested -->++<!ELEMENT a %a.content;>+<!ATTLIST a+ %attrs;+ %focus;+ charset %Charset; #IMPLIED+ type %ContentType; #IMPLIED+ name NMTOKEN #IMPLIED+ href %URI; #IMPLIED+ hreflang %LanguageCode; #IMPLIED+ rel %LinkTypes; #IMPLIED+ rev %LinkTypes; #IMPLIED+ shape %Shape; "rect"+ coords %Coords; #IMPLIED+ >++> a' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> a' = tellNode inline "a" []+>+> a :: Inline c => XHtml InlineContent -> XHtml c+> a = a' []++<!--===================== Inline Elements ================================-->++<!ELEMENT span %Inline;> <!-- generic language/style container -->+<!ATTLIST span+ %attrs;+ >++> span' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> span' = tellNode inline "span" []+>+> span_ :: Inline c => XHtml InlineContent -> XHtml c+> span_ = span' []++<!ELEMENT bdo %Inline;> <!-- I18N BiDi over-ride -->+<!ATTLIST bdo+ %coreattrs;+ %events;+ lang %LanguageCode; #IMPLIED+ xml:lang %LanguageCode; #IMPLIED+ dir (ltr|rtl) #REQUIRED+ >++> 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' []++<!ELEMENT br EMPTY> <!-- forced line break -->+<!ATTLIST br+ %coreattrs;+ >++> br' :: Inline c => Attrs -> XHtml c+> br' = tellEmptyNode inline "br" []+>+> br :: Inline c => XHtml c+> br = br' []++<!ELEMENT em %Inline;> <!-- emphasis -->+<!ATTLIST em %attrs;>++> em' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> em' = tellNode inline "em" []+>+> em :: Inline c => XHtml InlineContent -> XHtml c+> em = em' []++<!ELEMENT strong %Inline;> <!-- strong emphasis -->+<!ATTLIST strong %attrs;>++> strong' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> strong' = tellNode inline "strong" []+>+> strong :: Inline c => XHtml InlineContent -> XHtml c+> strong = strong' []++<!ELEMENT dfn %Inline;> <!-- definitional -->+<!ATTLIST dfn %attrs;>++> dfn' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> dfn' = tellNode inline "dfn" []+>+> dfn :: Inline c => XHtml InlineContent -> XHtml c+> dfn = dfn' []++<!ELEMENT code %Inline;> <!-- program code -->+<!ATTLIST code %attrs;>++> code' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> code' = tellNode inline "code" []+>+> code :: Inline c => XHtml InlineContent -> XHtml c+> code = code' []++<!ELEMENT samp %Inline;> <!-- sample -->+<!ATTLIST samp %attrs;>++> samp' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> samp' = tellNode inline "samp" []+>+> samp :: Inline c => XHtml InlineContent -> XHtml c+> samp = samp' []++<!ELEMENT kbd %Inline;> <!-- something user would type -->+<!ATTLIST kbd %attrs;>++> kbd' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> kbd' = tellNode inline "kbd" []+>+> kbd :: Inline c => XHtml InlineContent -> XHtml c+> kbd = kbd' []++<!ELEMENT var %Inline;> <!-- variable -->+<!ATTLIST var %attrs;>++> var' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> var' = tellNode inline "var" []+>+> var :: Inline c => XHtml InlineContent -> XHtml c+> var = var' []++<!ELEMENT cite %Inline;> <!-- citation -->+<!ATTLIST cite %attrs;>++> cite' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> cite' = tellNode inline "cite" []+>+> cite :: Inline c => XHtml InlineContent -> XHtml c+> cite = cite' []++<!ELEMENT abbr %Inline;> <!-- abbreviation -->+<!ATTLIST abbr %attrs;>++> abbr' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> abbr' = tellNode inline "abbr" []+>+> abbr :: Inline c => XHtml InlineContent -> XHtml c+> abbr = abbr' []++<!ELEMENT acronym %Inline;> <!-- acronym -->+<!ATTLIST acronym %attrs;>++> acronym' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> acronym' = tellNode inline "acronym" []+>+> acronym :: Inline c => XHtml InlineContent -> XHtml c+> acronym = acronym' []++<!ELEMENT q %Inline;> <!-- inlined quote -->+<!ATTLIST q+ %attrs;+ cite %URI; #IMPLIED+ >++> q' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> q' = tellNode inline "q" []+>+> q :: Inline c => XHtml InlineContent -> XHtml c+> q = q' []++<!ELEMENT sub %Inline;> <!-- subscript -->+<!ATTLIST sub %attrs;>++> sub' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> sub' = tellNode inline "sub" []+>+> sub :: Inline c => XHtml InlineContent -> XHtml c+> sub = sub' []++<!ELEMENT sup %Inline;> <!-- superscript -->+<!ATTLIST sup %attrs;>++> sup' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> sup' = tellNode inline "sup" []+>+> sup :: Inline c => XHtml InlineContent -> XHtml c+> sup = sup' []++<!ELEMENT tt %Inline;> <!-- fixed pitch font -->+<!ATTLIST tt %attrs;>++> tt' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> tt' = tellNode inline "tt" []+>+> tt :: Inline c => XHtml InlineContent -> XHtml c+> tt = tt' []++<!ELEMENT i %Inline;> <!-- italic font -->+<!ATTLIST i %attrs;>++> i' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> i' = tellNode inline "i" []+>+> i :: Inline c => XHtml InlineContent -> XHtml c+> i = i' []++<!ELEMENT b %Inline;> <!-- bold font -->+<!ATTLIST b %attrs;>++> b' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> b' = tellNode inline "b" []+>+> b :: Inline c => XHtml InlineContent -> XHtml c+> b = b' []++<!ELEMENT big %Inline;> <!-- bigger font -->+<!ATTLIST big %attrs;>++> big' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> big' = tellNode inline "big" []+>+> big :: Inline c => XHtml InlineContent -> XHtml c+> big = big' []++<!ELEMENT small %Inline;> <!-- smaller font -->+<!ATTLIST small %attrs;>++> small' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> small' = tellNode inline "small" []+>+> small :: Inline c => XHtml InlineContent -> XHtml c+> small = small' []++<!--==================== Object ======================================-->++> 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 is used to embed objects as part of HTML pages.+ param elements should precede other content. Parameters+ can also be expressed as attribute/value pairs on the+ object element itself when brevity is desired.+-->++<!ELEMENT object (#PCDATA | param | %block; | form | %inline; | %misc;)*>+<!ATTLIST object+ %attrs;+ declare (declare) #IMPLIED+ classid %URI; #IMPLIED+ codebase %URI; #IMPLIED+ data %URI; #IMPLIED+ type %ContentType; #IMPLIED+ codetype %ContentType; #IMPLIED+ archive %UriList; #IMPLIED+ standby %Text; #IMPLIED+ height %Length; #IMPLIED+ width %Length; #IMPLIED+ usemap %URI; #IMPLIED+ name NMTOKEN #IMPLIED+ tabindex %Number; #IMPLIED+ >++> object' :: Flow c => Attrs -> XHtml ObjectContent -> XHtml c+> object' = tellNode flow "object" []+>+> object :: Flow c => XHtml ObjectContent -> XHtml c+> object = object' []++<!--+ param is used to supply a named property value.+ In XML it would seem natural to follow RDF and support an+ abbreviated syntax where the param elements are replaced+ by attribute value pairs on the object start tag.+-->+<!ELEMENT param EMPTY>+<!ATTLIST param+ id ID #IMPLIED+ name CDATA #IMPLIED+ value CDATA #IMPLIED+ valuetype (data|ref|object) "data"+ type %ContentType; #IMPLIED+ >++> param' :: Attrs -> XHtml ObjectContent+> param' = tellEmptyNode Object "param" []+>+> param :: XHtml ObjectContent+> param = param' []++<!--=================== Images ===========================================-->++<!--+ To avoid accessibility problems for people who aren't+ able to see the image, you should provide a text+ description using the alt and longdesc attributes.+ In addition, avoid the use of server-side image maps.+ Note that in this DTD there is no name attribute. That+ is only available in the transitional and frameset DTD.+-->++<!ELEMENT img EMPTY>+<!ATTLIST img+ %attrs;+ src %URI; #REQUIRED+ alt %Text; #REQUIRED+ longdesc %URI; #IMPLIED+ height %Length; #IMPLIED+ width %Length; #IMPLIED+ usemap %URI; #IMPLIED+ ismap (ismap) #IMPLIED+ >++> 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]++<!-- usemap points to a map element which may be in this document+ or an external document, although the latter is not widely supported -->++<!--================== Client-side image maps ============================-->++> 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++<!-- These can be placed in the same document or grouped in a+ separate document although this isn't yet widely supported -->++<!ELEMENT map ((%block; | form | %misc;)+ | area+)>+<!ATTLIST map+ %i18n;+ %events;+ id ID #REQUIRED+ class CDATA #IMPLIED+ style %StyleSheet; #IMPLIED+ title %Text; #IMPLIED+ name NMTOKEN #IMPLIED+ >++> 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' []++<!ELEMENT area EMPTY>+<!ATTLIST area+ %attrs;+ %focus;+ shape %Shape; "rect"+ coords %Coords; #IMPLIED+ href %URI; #IMPLIED+ nohref (nohref) #IMPLIED+ alt %Text; #REQUIRED+ >++> area' :: Text -- ^ Required alt attribute.+> -> Attrs -> XHtml MapContent+> area' alt = tellEmptyNode Map "area" [Attr "alt" alt]+>+> area :: Text -> XHtml MapContent+> area = flip area' []++<!--================ Forms ===============================================-->++<!ELEMENT form %form.content;> <!-- forms shouldn't be nested -->++<!ATTLIST form+ %attrs;+ action %URI; #REQUIRED+ method (get|post) "get"+ enctype %ContentType; "application/x-www-form-urlencoded"+ onsubmit %Script; #IMPLIED+ onreset %Script; #IMPLIED+ accept %ContentTypes; #IMPLIED+ accept-charset %Charsets; #IMPLIED+ >++> 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' []++<!--+ Each label must not contain more than ONE field+ Label elements shouldn't be nested.+-->+<!ELEMENT label %Inline;>+<!ATTLIST label+ %attrs;+ for IDREF #IMPLIED+ accesskey %Character; #IMPLIED+ onfocus %Script; #IMPLIED+ onblur %Script; #IMPLIED+ >++> label' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c+> label' = tellNode inline "label" []+>+> label :: Inline c => XHtml InlineContent -> XHtml c+> label = label' []++<!ENTITY % InputType+ "(text | password | checkbox |+ radio | submit | reset |+ file | hidden | image | button)"+ >++<!-- the name attribute is required for all but submit & reset -->++<!ELEMENT input EMPTY> <!-- form control -->+<!ATTLIST input+ %attrs;+ %focus;+ type %InputType; "text"+ name CDATA #IMPLIED+ value CDATA #IMPLIED+ checked (checked) #IMPLIED+ disabled (disabled) #IMPLIED+ readonly (readonly) #IMPLIED+ size CDATA #IMPLIED+ maxlength %Number; #IMPLIED+ src %URI; #IMPLIED+ alt CDATA #IMPLIED+ usemap %URI; #IMPLIED+ onselect %Script; #IMPLIED+ onchange %Script; #IMPLIED+ accept %ContentTypes; #IMPLIED+ >++> input' :: Inline c => Attrs -> XHtml c+> input' = tellEmptyNode inline "input" []+>+> input :: Inline c => XHtml c+> input = input' []++<!ELEMENT select (optgroup|option)+> <!-- option selector -->+<!ATTLIST select+ %attrs;+ name CDATA #IMPLIED+ size %Number; #IMPLIED+ multiple (multiple) #IMPLIED+ disabled (disabled) #IMPLIED+ tabindex %Number; #IMPLIED+ onfocus %Script; #IMPLIED+ onblur %Script; #IMPLIED+ onchange %Script; #IMPLIED+ >++> 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' []++<!ELEMENT optgroup (option)+> <!-- option group -->+<!ATTLIST optgroup+ %attrs;+ disabled (disabled) #IMPLIED+ label %Text; #REQUIRED+ >++> 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' []++<!ELEMENT option (#PCDATA)> <!-- selectable choice -->+<!ATTLIST option+ %attrs;+ selected (selected) #IMPLIED+ disabled (disabled) #IMPLIED+ label %Text; #IMPLIED+ value CDATA #IMPLIED+ >++> option' :: Attrs -> Text -> XHtml OptionContent+> option' = tellTextNode Option "option" []+>+> option :: Text -> XHtml OptionContent+> option = option' []++<!ELEMENT textarea (#PCDATA)> <!-- multi-line text field -->+<!ATTLIST textarea+ %attrs;+ %focus;+ name CDATA #IMPLIED+ rows %Number; #REQUIRED+ cols %Number; #REQUIRED+ disabled (disabled) #IMPLIED+ readonly (readonly) #IMPLIED+ onselect %Script; #IMPLIED+ onchange %Script; #IMPLIED+ >++> 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 []++<!--+ The fieldset element is used to group form fields.+ Only one legend element should occur in the content+ and if present should only be preceded by whitespace.+-->+<!ELEMENT fieldset (#PCDATA | legend | %block; | form | %inline; | %misc;)*>+<!ATTLIST fieldset+ %attrs;+ >++> 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' []++<!ELEMENT legend %Inline;> <!-- fieldset label -->+<!ATTLIST legend+ %attrs;+ accesskey %Character; #IMPLIED+ >++> legend' :: Attrs -> XHtml InlineContent -> XHtml FieldSetContent +> legend' = tellNode FieldSet "legend" []+>+> legend :: XHtml InlineContent -> XHtml FieldSetContent+> legend = legend' []++<!--+ Content is %Flow; excluding a, form and form controls+--> +<!ELEMENT button %button.content;> <!-- push button -->+<!ATTLIST button+ %attrs;+ %focus;+ name CDATA #IMPLIED+ value CDATA #IMPLIED+ type (button|submit|reset) "submit"+ disabled (disabled) #IMPLIED+ >++> button' :: Inline c => Attrs -> XHtml FlowContent -> XHtml c+> button' = tellNode inline "button" []+>+> button :: Inline c => XHtml FlowContent -> XHtml c+> button = button' []++<!--======================= Tables =======================================-->++<!-- Derived from IETF HTML table standard, see [RFC1942] -->++<!--+ The border attribute sets the thickness of the frame around the+ table. The default units are screen pixels.++ The frame attribute specifies which parts of the frame around+ the table should be rendered. The values are not the same as+ CALS to avoid a name clash with the valign attribute.+-->+<!ENTITY % TFrame "(void|above|below|hsides|lhs|rhs|vsides|box|border)">++<!--+ The rules attribute defines which rules to draw between cells:++ If rules is absent then assume:+ "none" if border is absent or border="0" otherwise "all"+-->++<!ENTITY % TRules "(none | groups | rows | cols | all)">+ +<!-- horizontal alignment attributes for cell contents++ char alignment char, e.g. char=':'+ charoff offset for alignment char+-->+<!ENTITY % cellhalign+ "align (left|center|right|justify|char) #IMPLIED+ char %Character; #IMPLIED+ charoff %Length; #IMPLIED"+ >++<!-- vertical alignment attributes for cell contents -->+<!ENTITY % cellvalign+ "valign (top|middle|bottom|baseline) #IMPLIED"+ >++> 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++<!ELEMENT table+ (caption?, (col*|colgroup*), thead?, tfoot?, (tbody+|tr+))>++> table' :: Block c => Attrs -> XHtml Table1Content -> XHtml c+> table' = tellNode block "table" []+> +> table :: Block c => XHtml Table1Content -> XHtml c+> table = table' []++<!ELEMENT caption %Inline;>++> caption' :: Attrs -> XHtml InlineContent -> XHtml Table1Content+> caption' = tellNode Table1 "caption" []+>+> caption :: XHtml InlineContent -> XHtml Table1Content+> caption = caption' []++<!ELEMENT thead (tr)+>++> thead' :: Attrs -> XHtml Table2Content -> XHtml Table1Content+> thead' = tellNode Table1 "thead" []+>+> thead :: XHtml Table2Content -> XHtml Table1Content+> thead = thead' []++<!ELEMENT tfoot (tr)+>++> tfoot' :: Attrs -> XHtml Table2Content -> XHtml Table1Content+> tfoot' = tellNode Table1 "tfoot" []+>+> tfoot :: XHtml Table2Content -> XHtml Table1Content+> tfoot = tfoot' []++<!ELEMENT tbody (tr)+>++> tbody' :: Attrs -> XHtml Table2Content -> XHtml Table1Content+> tbody' = tellNode Table1 "tbody" []+>+> tbody :: XHtml Table2Content -> XHtml Table1Content+> tbody = tbody' []++<!ELEMENT colgroup (col)*>++> colgroup' :: Attrs -> XHtml TableColContent -> XHtml Table1Content+> colgroup' = tellNode Table1 "colgroup" []+>+> colgroup :: XHtml TableColContent -> XHtml Table1Content+> colgroup = colgroup' []++<!ELEMENT col EMPTY>++> col' :: Attrs -> XHtml TableColContent+> col' = tellEmptyNode TableCol "col" []+>+> col :: XHtml TableColContent+> col = col' []++<!ELEMENT tr (th|td)+>++> tr' :: Attrs -> XHtml Table3Content -> XHtml Table2Content+> tr' = tellNode Table2 "tr" []+> +> tr :: XHtml Table3Content -> XHtml Table2Content+> tr = tr' []++<!ELEMENT th %Flow;>++> th' :: Attrs -> XHtml FlowContent -> XHtml Table3Content+> th' = tellNode Table3 "th" []+>+> th :: XHtml FlowContent -> XHtml Table3Content+> th = th' []++<!ELEMENT td %Flow;>++> td' :: Attrs -> XHtml FlowContent -> XHtml Table3Content+> td' = tellNode Table3 "td" []+>+> td :: XHtml FlowContent -> XHtml Table3Content+> td = td' []++<!ATTLIST table+ %attrs;+ summary %Text; #IMPLIED+ width %Length; #IMPLIED+ border %Pixels; #IMPLIED+ frame %TFrame; #IMPLIED+ rules %TRules; #IMPLIED+ cellspacing %Length; #IMPLIED+ cellpadding %Length; #IMPLIED+ >++<!ATTLIST caption+ %attrs;+ >++<!--+colgroup groups a set of col elements. It allows you to group+several semantically related columns together.+-->+<!ATTLIST colgroup+ %attrs;+ span %Number; "1"+ width %MultiLength; #IMPLIED+ %cellhalign;+ %cellvalign;+ >++<!--+ col elements define the alignment properties for cells in+ one or more columns.++ The width attribute specifies the width of the columns, e.g.++ width=64 width in screen pixels+ width=0.5* relative width of 0.5++ The span attribute causes the attributes of one+ col element to apply to more than one column.+-->+<!ATTLIST col+ %attrs;+ span %Number; "1"+ width %MultiLength; #IMPLIED+ %cellhalign;+ %cellvalign;+ >++<!--+ Use thead to duplicate headers when breaking table+ across page boundaries, or for static headers when+ tbody sections are rendered in scrolling panel.++ Use tfoot to duplicate footers when breaking table+ across page boundaries, or for static footers when+ tbody sections are rendered in scrolling panel.++ Use multiple tbody sections when rules are needed+ between groups of table rows.+-->+<!ATTLIST thead+ %attrs;+ %cellhalign;+ %cellvalign;+ >++<!ATTLIST tfoot+ %attrs;+ %cellhalign;+ %cellvalign;+ >++<!ATTLIST tbody+ %attrs;+ %cellhalign;+ %cellvalign;+ >++<!ATTLIST tr+ %attrs;+ %cellhalign;+ %cellvalign;+ >+++<!-- Scope is simpler than headers attribute for common tables -->+<!ENTITY % Scope "(row|col|rowgroup|colgroup)">++<!-- th is for headers, td for data and for cells acting as both -->++<!ATTLIST th+ %attrs;+ abbr %Text; #IMPLIED+ axis CDATA #IMPLIED+ headers IDREFS #IMPLIED+ scope %Scope; #IMPLIED+ rowspan %Number; "1"+ colspan %Number; "1"+ %cellhalign;+ %cellvalign;+ >++<!ATTLIST td+ %attrs;+ abbr %Text; #IMPLIED+ axis CDATA #IMPLIED+ headers IDREFS #IMPLIED+ scope %Scope; #IMPLIED+ rowspan %Number; "1"+ colspan %Number; "1"+ %cellhalign;+ %cellvalign;+ >
+ src/Text/XHtmlCombinators/Internal.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE PatternGuards, BangPatterns #-}+module Text.XHtmlCombinators.Internal where++import Control.Applicative+import Control.Monad.Writer+import Data.Sequence+import qualified Data.Sequence as Seq+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T++type Attrs = [Attr]++data Attr = Attr Text Text deriving (Show)++data Node = Node Text Attrs Attrs (Seq Node)+ | TextNode Text+ | WithAttrs Attrs+ deriving (Show)++first :: Seq a -> a+first seq | x :< _ <- viewl seq = x++textNode :: Text -> Attrs -> Attrs -> Text -> Node+textNode name rattrs attrs content = + Node name rattrs attrs (singleton (TextNode content))++emptyNode :: Text -> Attrs -> Attrs -> Node+emptyNode name rattrs attrs = Node name rattrs attrs Seq.empty+ +node :: Content e => Text -> Attrs -> Attrs -> XHtml e -> Node+node name rattrs attrs content = + Node name rattrs attrs (toContent <$> execXHtml content)++class Content e where+ toContent :: e -> Node++type XHtmlM x a = Writer (Seq x) a+type XHtml x = XHtmlM x ()++tellS :: x -> XHtml x+tellS = tell . singleton++execXHtml :: XHtml x -> Seq x+execXHtml = snd . runWriter++tellTextNode :: (Node -> e) -> Text -> Attrs -> Attrs -> Text -> XHtml e +tellTextNode c name rattrs attrs = tellS . c . textNode name rattrs attrs++tellEmptyNode :: (Node -> e) -> Text -> Attrs -> Attrs -> XHtml e +tellEmptyNode c name rattrs = tellS . c . emptyNode name rattrs++tellNode :: Content a => (Node -> b) -> Text -> Attrs -> Attrs -> XHtml a -> XHtml b +tellNode c name rattrs attrs = tellS . c . node name rattrs attrs++empty :: XHtml x+empty = return ()
+ src/Text/XHtmlCombinators/Render.hs view
@@ -0,0 +1,52 @@+module Text.XHtmlCombinators.Render + ( render, renderPretty+ ) where++import Control.Applicative hiding (empty)+import Data.Foldable+import qualified Data.Sequence as Seq+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as T+import qualified Text.XML.Light as XML++import Text.XHtmlCombinators.Internal++lt = T.singleton '<'+gt = T.singleton '>'+space = T.singleton ' '+lts = T.pack "</"+nl = T.singleton '\n'++renderAttrs :: Attrs -> Text+renderAttrs [] = T.empty+renderAttrs attrs = T.concat (space : fmap renderAttr attrs)+ where renderAttr (Attr name val) = + T.concat [name, T.pack "=\"", val, T.pack "\""]++renderNode (TextNode t) = t+renderNode (Node name rattrs attrs c)+ | Seq.null c = T.concat [lt, name, a, b, gt, lts, name, gt]+ | otherwise = T.concat + [lt, name, a, b, gt, fold (fmap renderNode c), lts, name, gt]+ where a = renderAttrs rattrs+ b = renderAttrs attrs++-- | Quickly render a xhtml page to text.+-- +-- This function will render the entire page on a single line, which+-- is somewhat unreadable. On the plus side, it's relatively fast.+render :: Content c => XHtml c -> Text+render page = fold $ renderNode . toContent <$> execXHtml page++-- | Renders a pretty xhtml page with readable indentation.+-- +-- What we do is turn the document from 'Text' into a 'String',+-- parse that string with 'Text.XML.Light', then use 'Text.XML.Light''s+-- pretty printing function to render it, before finally packing it again.+-- It probably goes without saying, but this function is /incredibly/ inefficient!+-- +-- Also, 'Text.XML.Light' will render the document as proper XML, which is +-- fine only if you're not trying to pass of your page as text/html.+renderPretty :: Content c => XHtml c -> Text+renderPretty = T.pack . unlines . fmap XML.ppContent . XML.parseXML . T.unpack . render
+ xhtml-combinators.cabal view
@@ -0,0 +1,28 @@+name: xhtml-combinators+version: 0.1+cabal-version: >= 1.2.3+synopsis: Fast and easy to use XHTML combinators.+description: + xhtml-combinators provides a set of (hopefully!) fast and + easy to use XHTML 1.0 Strict combinators built on top of the+ Data.Text library.+category: Web, Text+license: BSD3+homepage: http://www.dcs.shef.ac.uk/~aca08aa/xhtmlc.html+license-file: LICENSE+author: Alasdair Armstrong+maintainer: alasdair.armstrong@googlemail.com+build-type: Simple++library+ build-Depends: + base < 5, containers, mtl, xml >= 1.3.5, text >= 0.7+ hs-source-dirs: src+ exposed-modules: + Text.XHtmlCombinators+ Text.XHtmlCombinators.Internal+ Text.XHtmlCombinators.Combinators+ Text.XHtmlCombinators.Render+ Text.XHtmlCombinators.Attributes+ extensions: OverloadedStrings, PatternGuards+ ghc-options: -O2