diff --git a/src/Text/XHtmlCombinators.hs b/src/Text/XHtmlCombinators.hs --- a/src/Text/XHtmlCombinators.hs +++ b/src/Text/XHtmlCombinators.hs @@ -1,10 +1,18 @@ +-- | +-- Module : Text.XHtmlCombinators +-- Copyright : (c) Alasdair Armstrong 2010 +-- License : BSD-style +-- Maintainer : alasdair.armstrong@googlemail.com +-- Stability : experimental +-- Portability : GHC + module Text.XHtmlCombinators ( -- * Types -- ** XHtml - XHtmlM, XHtml + XHtmlMT, XHtmlT, XHtml , Page - , Content - , Attrs, Attr (Attr) + , Content, CData + , Attrs, Attr -- ** Element Types , TopLevelContent , HeadContent @@ -18,6 +26,7 @@ , ListContent, DefinitionListContent -- *** Field Element Types , FieldSetContent + , OptionContent -- *** Table Element Types , Table1Content, Table2Content, Table3Content , TableColContent @@ -112,7 +121,7 @@ , th', th , td', td -- * Rendering - , render + , render, renderT ) where import Text.XHtmlCombinators.Combinators diff --git a/src/Text/XHtmlCombinators/Attributes.hs b/src/Text/XHtmlCombinators/Attributes.hs --- a/src/Text/XHtmlCombinators/Attributes.hs +++ b/src/Text/XHtmlCombinators/Attributes.hs @@ -1,22 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Text.XHtmlCombinators.Attributes +-- Copyright : (c) Andy Gill, and the Oregon Graduate Institute of Science and Technology 1999-2001 +-- (c) Bjorn Bringert 2004-2006 +-- (c) Alasdair Armstrong 2010 +-- License : BSD-style +-- Maintainer : alasdair.armstrong@googlemail.com +-- Stability : experimental +-- Portability : GHC + module Text.XHtmlCombinators.Attributes where -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as T +import Data.Text (Text) +import qualified Data.Text as T -import Text.XHtmlCombinators.Internal +import Text.XHtmlCombinators.Internal (Attr (Attr)) +import Text.XHtmlCombinators.Attributes.Internal +attr :: Text -> Text -> Attr +attr = Attr + -- 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 +-- TODO: Not all attributes are currently available. action :: Text -> Attr align :: Text -> Attr @@ -67,51 +75,51 @@ 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" +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" diff --git a/src/Text/XHtmlCombinators/Attributes/Internal.hs b/src/Text/XHtmlCombinators/Attributes/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/XHtmlCombinators/Attributes/Internal.hs @@ -0,0 +1,27 @@ +-- | +-- Module : Text.XHtmlCombinators.Attributes +-- Copyright : (c) Alasdair Armstrong 2010 +-- License : BSD-style +-- Maintainer : alasdair.armstrong@googlemail.com +-- Stability : experimental +-- Portability : GHC + +module Text.XHtmlCombinators.Attributes.Internal + ( emptyAttr + , intAttr + , textAttr + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import Text.XHtmlCombinators.Internal + +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 diff --git a/src/Text/XHtmlCombinators/Attributes/Internal/Safe.hs b/src/Text/XHtmlCombinators/Attributes/Internal/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Text/XHtmlCombinators/Attributes/Internal/Safe.hs @@ -0,0 +1,28 @@ +-- | +-- Module : Text.XHtmlCombinators.Attributes +-- Copyright : (c) Alasdair Armstrong 2010 +-- License : BSD-style +-- Maintainer : alasdair.armstrong@googlemail.com +-- Stability : experimental +-- Portability : GHC + +module Text.XHtmlCombinators.Attributes.Internal.Safe + ( emptyAttr + , intAttr + , textAttr + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import Text.XHtmlCombinators.Internal +import Text.XHtmlCombinators.Escape + +emptyAttr :: Text -> Attr +emptyAttr name = Attr name (escapeAttr name) + +intAttr :: Text -> Int -> Attr +intAttr name = Attr name . T.pack . show + +textAttr :: Text -> Text -> Attr +textAttr name = Attr name . escapeAttr diff --git a/src/Text/XHtmlCombinators/Attributes/Safe.hs b/src/Text/XHtmlCombinators/Attributes/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Text/XHtmlCombinators/Attributes/Safe.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Text.XHtmlCombinators.Attributes +-- Copyright : (c) Andy Gill, and the Oregon Graduate Institute of Science and Technology 1999-2001 +-- (c) Bjorn Bringert 2004-2006 +-- (c) Alasdair Armstrong 2010 +-- License : BSD-style +-- Maintainer : alasdair.armstrong@googlemail.com +-- Stability : experimental +-- Portability : GHC + +module Text.XHtmlCombinators.Attributes.Safe where + +import Data.Char (isAsciiLower) + +import Data.Text (Text) +import qualified Data.Text as T + +import Text.XHtmlCombinators.Internal (Attr (Attr)) +import Text.XHtmlCombinators.Escape +import Text.XHtmlCombinators.Attributes.Internal.Safe + +attr :: Text -> Text -> Attr +attr name = Attr (T.filter isAsciiLower name) . escapeAttr + +-- the following was copied almost verbatim from Bjorn Bringert's xhtml library. +-- See: http://hackage.haskell.org/package/xhtml + +-- TODO: Not all attributes are currently available. + +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" + +-- | +-- Currently data input into the style tag is not +-- escaped. +style = Attr "style" diff --git a/src/Text/XHtmlCombinators/Combinators.lhs b/src/Text/XHtmlCombinators/Combinators.lhs --- a/src/Text/XHtmlCombinators/Combinators.lhs +++ b/src/Text/XHtmlCombinators/Combinators.lhs @@ -1,11 +1,22 @@ -> {-# LANGUAGE OverloadedStrings #-} +> {-# LANGUAGE OverloadedStrings, FlexibleInstances #-} + +> -- | +> -- Module : Text.XHtmlCombinators.Combinators +> -- Copyright : (c) Alasdair Armstrong 2010 +> -- License : BSD-style +> -- Maintainer : alasdair.armstrong@googlemail.com +> -- Stability : experimental +> -- Portability : GHC +> > module Text.XHtmlCombinators.Combinators where > > import Control.Applicative hiding (empty) -> import Data.Text.Lazy (Text) +> import Data.Sequence (Seq) > import qualified Data.Sequence as Seq -> import qualified Data.Text.Lazy as T > +> import Data.Text (Text) +> import qualified Data.Text as T +> > import Text.XHtmlCombinators.Internal - +> -- ================ Character mnemonic entities =========================--> %HTMLspecial; - +> -- ================== Imported Names ====================================--> @@ -111,7 +122,7 @@ - +> -- =================== Generic Attributes ===============================--> +> -- =================== Text Elements ====================================--> @@ -205,7 +216,7 @@ > class CData c where > cdata :: Text -> c > -> text :: CData c => Text -> XHtml c +> text :: (Functor t, Monad t, CData c) => Text -> XHtmlT t c > text = tellS . cdata > > newtype InlineContent = Inline { inlineToNode :: Node } @@ -222,7 +233,7 @@ > instance Inline InlineContent where inline = Inline > instance Inline FlowContent where inline = Flow - +> -- ================== Block level elements ==============================--> @@ -262,7 +273,7 @@ > instance Flow InlineContent where flow = Inline > instance Flow FlowContent where flow = Flow - +> -- ================== Content models for exclusions =====================--> @@ -285,7 +296,7 @@ "(#PCDATA | p | %heading; | div | %lists; | %blocktext; | table | %special; | %fontstyle; | %phrase; | %misc;)*"> - +> -- ================ Document Structure ==================================--> @@ -309,21 +320,24 @@ > xhtml10strict = " \ \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" > +> doctype :: (Functor t, Monad t) => XHtmlT t Page > doctype = tellS . Page . TextNode $ xhtml10strict > +> xmlDec :: (Functor t, Monad t) => XHtmlT t Page > xmlDec = tellS . Page . TextNode $ "" > -> html' :: Bool -- ^ True for XML declaration, false to omit. -> -> Attrs -> XHtml TopLevelContent -> XHtml Page +> html' :: (Functor t, Monad t) +> => Bool -- ^ True for XML declaration, false to omit. +> -> Attrs -> XHtmlT t TopLevelContent -> XHtmlT t 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 :: (Functor t, Monad t) => Bool -> XHtmlT t TopLevelContent -> XHtmlT t Page > html useXmlDec = html' useXmlDec [] - +> -- ================ Document Head =======================================--> @@ -345,10 +359,10 @@ profile %URI; #IMPLIED > -> head' :: Attrs -> XHtml HeadContent -> XHtml TopLevelContent +> head' :: (Functor t, Monad t) => Attrs -> XHtmlT t HeadContent -> XHtmlT t TopLevelContent > head' = tellNode TopLevel "head" [] > -> head_ :: XHtml HeadContent -> XHtml TopLevelContent +> head_ :: (Functor t, Monad t) => XHtmlT t HeadContent -> XHtmlT t TopLevelContent > head_ = head' [] @@ -375,10 +389,10 @@ id ID #IMPLIED > -> base' :: Text -> Attrs -> XHtml HeadContent +> base' :: (Functor t, Monad t) => Text -> Attrs -> XHtmlT t HeadContent > base' href = tellEmptyNode Head "base" [Attr "href" href] > -> base :: Text -> XHtml HeadContent +> base :: (Functor t, Monad t) => Text -> XHtmlT t HeadContent > base = flip base' [] @@ -392,11 +406,11 @@ scheme CDATA #IMPLIED > -> meta' :: Text -- ^ Required content attribute. -> -> Attrs -> XHtml HeadContent +> meta' :: (Functor t, Monad t) => Text -- ^ Required content attribute. +> -> Attrs -> XHtmlT t HeadContent > meta' content = tellEmptyNode Head "meta" [Attr "content" content] > -> meta :: Text -> XHtml HeadContent +> meta :: (Functor t, Monad t) => Text -> XHtmlT t HeadContent > meta = flip meta' [] @@ -444,11 +459,11 @@ xml:space (preserve) #FIXED 'preserve' > -> style' :: Text -- ^ Required type attribute. -> -> Attrs -> Text -> XHtml HeadContent -> style' sType = tellTextNode Head "style" [Attr "type" sType] +> style' :: (Functor t, Monad t) => Text -- ^ Required type attribute. +> -> Attrs -> Text -> XHtmlT t HeadContent +> style' type_ = tellTextNode Head "style" [Attr "type" type_] > -> style :: Text -> Text -> XHtml HeadContent +> style :: (Functor t, Monad t) => Text -> Text -> XHtmlT t HeadContent > style = flip style' [] @@ -462,11 +477,12 @@ xml:space (preserve) #FIXED 'preserve' > -> script' :: Text -- ^ Required type attribute. -> -> Attrs -> Text -> XHtml HeadContent -> script' sType = tellTextNode Head "script" [Attr "type" sType] +> script' :: (Functor t, Monad t) +> => Text -- ^ Required type attribute. +> -> Attrs -> Text -> XHtmlT t HeadContent +> script' type_ = tellTextNode Head "script" [Attr "type" type_] > -> script :: Text -> Text -> XHtml HeadContent +> script :: (Functor t, Monad t) => Text -> Text -> XHtmlT t HeadContent > script = flip script' [] @@ -476,13 +492,13 @@ %attrs; > -> noscript' :: Block c => Attrs -> XHtml BlockContent -> XHtml c +> noscript' :: (Functor t, Monad t, Block c) => Attrs -> XHtmlT t BlockContent -> XHtmlT t c > noscript' = tellNode block "noscript" [] > -> noscript :: Block c => XHtml BlockContent -> XHtml c +> noscript :: (Functor t, Monad t, Block c) => XHtmlT t BlockContent -> XHtmlT t c > noscript = noscript' [] - +> -- =================== Document Body ====================================--> -> body' :: Attrs -> XHtml BlockContent -> XHtml TopLevelContent +> body' :: (Functor t, Monad t) => Attrs -> XHtmlT t BlockContent -> XHtmlT t TopLevelContent > body' = tellNode TopLevel "body" [] > -> body :: XHtml BlockContent -> XHtml TopLevelContent +> body :: (Functor t, Monad t) => XHtmlT t BlockContent -> XHtmlT t TopLevelContent > body = body' [] @@ -502,26 +518,26 @@ %attrs; > -> div' :: Block c => Attrs -> XHtml FlowContent -> XHtml c +> div' :: (Functor t, Monad t, Block c) => Attrs -> XHtmlT t FlowContent -> XHtmlT t c > div' = tellNode block "div" [] > -> div_ :: Block c => XHtml FlowContent -> XHtml c +> div_ :: (Functor t, Monad t, Block c) => XHtmlT t FlowContent -> XHtmlT t c > div_ = div' [] - +> -- =================== Paragraphs =======================================--> -> p' :: Block c => Attrs -> XHtml InlineContent -> XHtml c +> p' :: (Functor t, Monad t, Block c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > p' = tellNode block "p" [] > -> p :: Block c => XHtml InlineContent -> XHtml c +> p :: (Functor t, Monad t, Block c) => XHtmlT t InlineContent -> XHtmlT t c > p = p' [] - +> -- =================== Headings =========================================--> +> -- =================== Lists ============================================--> @@ -608,10 +624,10 @@ %attrs; > -> ul' :: Block c => Attrs -> XHtml ListContent -> XHtml c +> ul' :: (Functor t, Monad t, Block c) => Attrs -> XHtmlT t ListContent -> XHtmlT t c > ul' = tellNode block "ul" [] > -> ul :: Block c => XHtml ListContent -> XHtml c +> ul :: (Functor t, Monad t, Block c) => XHtmlT t ListContent -> XHtmlT t c > ul = ul' [] @@ -621,10 +637,10 @@ %attrs; > -> ol' :: Block c => Attrs -> XHtml ListContent -> XHtml c +> ol' :: (Functor t, Monad t, Block c) => Attrs -> XHtmlT t ListContent -> XHtmlT t c > ol' = tellNode block "ol" [] > -> ol :: Block c => XHtml ListContent -> XHtml c +> ol :: (Functor t, Monad t, Block c) => XHtmlT t ListContent -> XHtmlT t c > ol = ol' [] @@ -634,10 +650,10 @@ %attrs; > -> li' :: Attrs -> XHtml FlowContent -> XHtml ListContent +> li' :: (Functor t, Monad t) => Attrs -> XHtmlT t FlowContent -> XHtmlT t ListContent > li' = tellNode List "li" [] > -> li :: XHtml FlowContent -> XHtml ListContent +> li :: (Functor t, Monad t) => XHtmlT t FlowContent -> XHtmlT t ListContent > li = li' [] @@ -653,10 +669,10 @@ %attrs; > -> dl' :: Block c => Attrs -> XHtml DefinitionListContent -> XHtml c +> dl' :: (Functor t, Monad t, Block c) => Attrs -> XHtmlT t DefinitionListContent -> XHtmlT t c > dl' = tellNode block "dl" [] > -> dl :: Block c => XHtml DefinitionListContent -> XHtml c +> dl :: (Functor t, Monad t, Block c) => XHtmlT t DefinitionListContent -> XHtmlT t c > dl = dl' [] @@ -664,10 +680,10 @@ %attrs; > -> dt' :: Attrs -> XHtml InlineContent -> XHtml DefinitionListContent +> dt' :: (Functor t, Monad t) => Attrs -> XHtmlT t InlineContent -> XHtmlT t DefinitionListContent > dt' = tellNode DefinitionList "dt" [] > -> dt :: XHtml InlineContent -> XHtml DefinitionListContent +> dt :: (Functor t, Monad t) => XHtmlT t InlineContent -> XHtmlT t DefinitionListContent > dt = dt' [] @@ -675,13 +691,13 @@ %attrs; > -> dd' :: Attrs -> XHtml InlineContent -> XHtml DefinitionListContent +> dd' :: (Functor t, Monad t) => Attrs -> XHtmlT t InlineContent -> XHtmlT t DefinitionListContent > dd' = tellNode DefinitionList "dd" [] > -> dd :: XHtml InlineContent -> XHtml DefinitionListContent +> dd :: (Functor t, Monad t) => XHtmlT t InlineContent -> XHtmlT t DefinitionListContent > dd = dd' [] - +> -- =================== Address ==========================================--> @@ -690,26 +706,26 @@ %attrs; > -> address' :: Block c => Attrs -> XHtml InlineContent -> XHtml c +> address' :: (Functor t, Monad t, Block c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > address' = tellNode block "address" [] > -> address :: Block c => XHtml InlineContent -> XHtml c +> address :: (Functor t, Monad t, Block c) => XHtmlT t InlineContent -> XHtmlT t c > address = address' [] - +> -- =================== Horizontal Rule ==================================--> -> hr' :: Block c => Attrs -> XHtml c +> hr' :: (Functor t, Monad t, Block c) => Attrs -> XHtmlT t c > hr' = tellEmptyNode block "hr" [] > -> hr :: Block c => XHtml c +> hr :: (Functor t, Monad t, Block c) => XHtmlT t c > hr = hr' [] - +> -- =================== Preformatted Text ================================--> @@ -719,13 +735,13 @@ xml:space (preserve) #FIXED 'preserve' > -> pre' :: Block c => Attrs -> XHtml InlineContent -> XHtml c +> pre' :: (Functor t, Monad t, Block c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > pre' = tellNode block "pre" [] > -> pre :: Block c => XHtml InlineContent -> XHtml c +> pre :: (Functor t, Monad t, Block c) => XHtmlT t InlineContent -> XHtmlT t c > pre = pre' [] - +> -- =================== Block-like Quotes ================================--> -> blockquote' :: Block c => Attrs -> XHtml BlockContent -> XHtml c +> blockquote' :: (Functor t, Monad t, Block c) => Attrs -> XHtmlT t BlockContent -> XHtmlT t c > blockquote' = tellNode block "blockquote" [] > -> blockquote :: Block c => XHtml BlockContent -> XHtml c +> blockquote :: (Functor t, Monad t, Block c) => XHtmlT t BlockContent -> XHtmlT t c > blockquote = blockquote' [] - +> -- =================== Inserted/Deleted Text ============================--> +> -- ================== The Anchor Element ================================--> @@ -791,23 +807,23 @@ coords %Coords; #IMPLIED > -> a' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> a' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > a' = tellNode inline "a" [] > -> a :: Inline c => XHtml InlineContent -> XHtml c +> a :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > a = a' [] - +> -- ===================== Inline Elements ================================--> -> span' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> span' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > span' = tellNode inline "span" [] > -> span_ :: Inline c => XHtml InlineContent -> XHtml c +> span_ :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > span_ = span' [] @@ -819,12 +835,12 @@ dir (ltr|rtl) #REQUIRED > -> bdo' :: Inline c +> bdo' :: (Functor t, Monad t, Inline c) > => Text -- ^ Required language direction code. -> -> Attrs -> XHtml InlineContent -> XHtml c +> -> Attrs -> XHtmlT t InlineContent -> XHtmlT t c > bdo' dir = tellNode inline "bdo" [Attr "dir" dir] > -> bdo :: Inline c => Text -> XHtml InlineContent -> XHtml c +> bdo :: (Functor t, Monad t, Inline c) => Text -> XHtmlT t InlineContent -> XHtmlT t c > bdo = flip bdo' [] @@ -832,100 +848,100 @@ %coreattrs; > -> br' :: Inline c => Attrs -> XHtml c +> br' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t c > br' = tellEmptyNode inline "br" [] > -> br :: Inline c => XHtml c +> br :: (Functor t, Monad t, Inline c) => XHtmlT t c > br = br' [] -> em' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> em' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > em' = tellNode inline "em" [] > -> em :: Inline c => XHtml InlineContent -> XHtml c +> em :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > em = em' [] -> strong' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> strong' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > strong' = tellNode inline "strong" [] > -> strong :: Inline c => XHtml InlineContent -> XHtml c +> strong :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > strong = strong' [] -> dfn' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> dfn' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > dfn' = tellNode inline "dfn" [] > -> dfn :: Inline c => XHtml InlineContent -> XHtml c +> dfn :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > dfn = dfn' [] -> code' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> code' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > code' = tellNode inline "code" [] > -> code :: Inline c => XHtml InlineContent -> XHtml c +> code :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > code = code' [] -> samp' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> samp' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > samp' = tellNode inline "samp" [] > -> samp :: Inline c => XHtml InlineContent -> XHtml c +> samp :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > samp = samp' [] -> kbd' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> kbd' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > kbd' = tellNode inline "kbd" [] > -> kbd :: Inline c => XHtml InlineContent -> XHtml c +> kbd :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > kbd = kbd' [] -> var' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> var' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > var' = tellNode inline "var" [] > -> var :: Inline c => XHtml InlineContent -> XHtml c +> var :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > var = var' [] -> cite' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> cite' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > cite' = tellNode inline "cite" [] > -> cite :: Inline c => XHtml InlineContent -> XHtml c +> cite :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > cite = cite' [] -> abbr' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> abbr' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > abbr' = tellNode inline "abbr" [] > -> abbr :: Inline c => XHtml InlineContent -> XHtml c +> abbr :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > abbr = abbr' [] -> acronym' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> acronym' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > acronym' = tellNode inline "acronym" [] > -> acronym :: Inline c => XHtml InlineContent -> XHtml c +> acronym :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > acronym = acronym' [] @@ -934,76 +950,76 @@ cite %URI; #IMPLIED > -> q' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> q' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > q' = tellNode inline "q" [] > -> q :: Inline c => XHtml InlineContent -> XHtml c +> q :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > q = q' [] -> sub' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> sub' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > sub' = tellNode inline "sub" [] > -> sub :: Inline c => XHtml InlineContent -> XHtml c +> sub :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > sub = sub' [] -> sup' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> sup' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > sup' = tellNode inline "sup" [] > -> sup :: Inline c => XHtml InlineContent -> XHtml c +> sup :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > sup = sup' [] -> tt' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> tt' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > tt' = tellNode inline "tt" [] > -> tt :: Inline c => XHtml InlineContent -> XHtml c +> tt :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > tt = tt' [] -> i' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> i' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > i' = tellNode inline "i" [] > -> i :: Inline c => XHtml InlineContent -> XHtml c +> i :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > i = i' [] -> b' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> b' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > b' = tellNode inline "b" [] > -> b :: Inline c => XHtml InlineContent -> XHtml c +> b :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > b = b' [] -> big' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> big' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > big' = tellNode inline "big" [] > -> big :: Inline c => XHtml InlineContent -> XHtml c +> big :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > big = big' [] -> small' :: Inline c => Attrs -> XHtml InlineContent -> XHtml c +> small' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t InlineContent -> XHtmlT t c > small' = tellNode inline "small" [] > -> small :: Inline c => XHtml InlineContent -> XHtml c +> small :: (Functor t, Monad t, Inline c) => XHtmlT t InlineContent -> XHtmlT t c > small = small' [] - +> -- ==================== Object ======================================--> > newtype ObjectContent = Object { objectToNode :: Node } > @@ -1039,10 +1055,10 @@ tabindex %Number; #IMPLIED > -> object' :: Flow c => Attrs -> XHtml ObjectContent -> XHtml c +> object' :: (Functor t, Monad t, Flow c) => Attrs -> XHtmlT t ObjectContent -> XHtmlT t c > object' = tellNode flow "object" [] > -> object :: Flow c => XHtml ObjectContent -> XHtml c +> object :: (Functor t, Monad t, Flow c) => XHtmlT t ObjectContent -> XHtmlT t c > object = object' [] +> -- =================== Images ===========================================--> - +> -- ================== Client-side image maps ============================--> > newtype MapContent = Map { mapToNode :: Node } > @@ -1126,12 +1142,12 @@ name NMTOKEN #IMPLIED > -> map' :: Flow c +> map' :: (Functor t, Monad t, Flow c) > => Text -- ^ Required id attribute. -> -> Attrs -> XHtml MapContent -> XHtml c +> -> Attrs -> XHtmlT t MapContent -> XHtmlT t c > map' id = tellNode flow "map" [Attr "id" id] > -> map_ :: Flow c => Text -> XHtml MapContent -> XHtml c +> map_ :: (Functor t, Monad t, Flow c) => Text -> XHtmlT t MapContent -> XHtmlT t c > map_ = flip map' [] @@ -1145,14 +1161,14 @@ alt %Text; #REQUIRED > -> area' :: Text -- ^ Required alt attribute. -> -> Attrs -> XHtml MapContent +> area' :: (Functor t, Monad t) => Text -- ^ Required alt attribute. +> -> Attrs -> XHtmlT t MapContent > area' alt = tellEmptyNode Map "area" [Attr "alt" alt] > -> area :: Text -> XHtml MapContent +> area :: (Functor t, Monad t) => Text -> XHtmlT t MapContent > area = flip area' [] - +> -- ================ Forms ===============================================--> @@ -1167,12 +1183,12 @@ accept-charset %Charsets; #IMPLIED > -> form' :: Block c +> form' :: (Functor t, Monad t, Block c) > => Text -- ^ Required action attribute. -> -> Attrs -> XHtml FlowContent -> XHtml c +> -> Attrs -> XHtmlT t FlowContent -> XHtmlT t c > form' action = tellNode block "form" [Attr "action" action] > -> form :: Block c => Text -> XHtml FlowContent -> XHtml c +> form :: (Functor t, Monad t, Block c) => Text -> XHtmlT t FlowContent -> XHtmlT t c > form = flip form' [] @@ -1246,10 +1262,10 @@ > instance Content OptionContent where > toContent = optionToNode > -> select' :: Inline c => Attrs -> XHtml OptionContent -> XHtml c +> select' :: (Functor t, Monad t, Inline c) => Attrs -> XHtmlT t OptionContent -> XHtmlT t c > select' = tellNode inline "select" [] > -> select :: Inline c => XHtml OptionContent -> XHtml c +> select :: (Functor t, Monad t, Inline c) => XHtmlT t OptionContent -> XHtmlT t c > select = select' [] @@ -1259,11 +1275,11 @@ label %Text; #REQUIRED > -> optgroup' :: Text -- ^ Required label attribute. -> -> Attrs -> XHtml OptionContent -> XHtml OptionContent +> optgroup' :: (Functor t, Monad t) => Text -- ^ Required label attribute. +> -> Attrs -> XHtmlT t OptionContent -> XHtmlT t OptionContent > optgroup' label = tellNode Option "optgroup" [Attr "label" label] > -> optgroup :: Text -> XHtml OptionContent -> XHtml OptionContent +> optgroup :: (Functor t, Monad t) => Text -> XHtmlT t OptionContent -> XHtmlT t OptionContent > optgroup = flip optgroup' [] @@ -1275,10 +1291,10 @@ value CDATA #IMPLIED > -> option' :: Attrs -> Text -> XHtml OptionContent +> option' :: (Functor t, Monad t) => Attrs -> Text -> XHtmlT t OptionContent > option' = tellTextNode Option "option" [] > -> option :: Text -> XHtml OptionContent +> option :: (Functor t, Monad t) => Text -> XHtmlT t OptionContent > option = option' [] @@ -1294,16 +1310,16 @@ onchange %Script; #IMPLIED > -> textarea' :: Inline c +> textarea' :: (Functor t, Monad t, Inline c) > => Int -- ^ Required rows attribute. > -> Int -- ^ Required cols attribute. -> -> Attrs -> Text -> XHtml c +> -> Attrs -> Text -> XHtmlT t 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 :: (Functor t, Monad t, Inline c) => Int -> Int -> Text -> XHtmlT t c > textarea rows cols = textarea' rows cols [] @@ -1337,10 +1353,10 @@ accesskey %Character; #IMPLIED > -> legend' :: Attrs -> XHtml InlineContent -> XHtml FieldSetContent +> legend' :: (Functor t, Monad t) => Attrs -> XHtmlT t InlineContent -> XHtmlT t FieldSetContent > legend' = tellNode FieldSet "legend" [] > -> legend :: XHtml InlineContent -> XHtml FieldSetContent +> legend :: (Functor t, Monad t) => XHtmlT t InlineContent -> XHtmlT t FieldSetContent > legend = legend' [] +> -- ======================= Tables =======================================--> @@ -1424,82 +1440,82 @@ -> table' :: Block c => Attrs -> XHtml Table1Content -> XHtml c +> table' :: (Functor t, Monad t, Block c) => Attrs -> XHtmlT t Table1Content -> XHtmlT t c > table' = tellNode block "table" [] > -> table :: Block c => XHtml Table1Content -> XHtml c +> table :: (Functor t, Monad t, Block c) => XHtmlT t Table1Content -> XHtmlT t c > table = table' [] -> caption' :: Attrs -> XHtml InlineContent -> XHtml Table1Content +> caption' :: (Functor t, Monad t) => Attrs -> XHtmlT t InlineContent -> XHtmlT t Table1Content > caption' = tellNode Table1 "caption" [] > -> caption :: XHtml InlineContent -> XHtml Table1Content +> caption :: (Functor t, Monad t) => XHtmlT t InlineContent -> XHtmlT t Table1Content > caption = caption' [] -> thead' :: Attrs -> XHtml Table2Content -> XHtml Table1Content +> thead' :: (Functor t, Monad t) => Attrs -> XHtmlT t Table2Content -> XHtmlT t Table1Content > thead' = tellNode Table1 "thead" [] > -> thead :: XHtml Table2Content -> XHtml Table1Content +> thead :: (Functor t, Monad t) => XHtmlT t Table2Content -> XHtmlT t Table1Content > thead = thead' [] -> tfoot' :: Attrs -> XHtml Table2Content -> XHtml Table1Content +> tfoot' :: (Functor t, Monad t) => Attrs -> XHtmlT t Table2Content -> XHtmlT t Table1Content > tfoot' = tellNode Table1 "tfoot" [] > -> tfoot :: XHtml Table2Content -> XHtml Table1Content +> tfoot :: (Functor t, Monad t) => XHtmlT t Table2Content -> XHtmlT t Table1Content > tfoot = tfoot' [] -> tbody' :: Attrs -> XHtml Table2Content -> XHtml Table1Content +> tbody' :: (Functor t, Monad t) => Attrs -> XHtmlT t Table2Content -> XHtmlT t Table1Content > tbody' = tellNode Table1 "tbody" [] > -> tbody :: XHtml Table2Content -> XHtml Table1Content +> tbody :: (Functor t, Monad t) => XHtmlT t Table2Content -> XHtmlT t Table1Content > tbody = tbody' [] -> colgroup' :: Attrs -> XHtml TableColContent -> XHtml Table1Content +> colgroup' :: (Functor t, Monad t) => Attrs -> XHtmlT t TableColContent -> XHtmlT t Table1Content > colgroup' = tellNode Table1 "colgroup" [] > -> colgroup :: XHtml TableColContent -> XHtml Table1Content +> colgroup :: (Functor t, Monad t) => XHtmlT t TableColContent -> XHtmlT t Table1Content > colgroup = colgroup' [] -> col' :: Attrs -> XHtml TableColContent +> col' :: (Functor t, Monad t) => Attrs -> XHtmlT t TableColContent > col' = tellEmptyNode TableCol "col" [] > -> col :: XHtml TableColContent +> col :: (Functor t, Monad t) => XHtmlT t TableColContent > col = col' [] -> tr' :: Attrs -> XHtml Table3Content -> XHtml Table2Content +> tr' :: (Functor t, Monad t) => Attrs -> XHtmlT t Table3Content -> XHtmlT t Table2Content > tr' = tellNode Table2 "tr" [] > -> tr :: XHtml Table3Content -> XHtml Table2Content +> tr :: (Functor t, Monad t) => XHtmlT t Table3Content -> XHtmlT t Table2Content > tr = tr' [] -> th' :: Attrs -> XHtml FlowContent -> XHtml Table3Content +> th' :: (Functor t, Monad t) => Attrs -> XHtmlT t FlowContent -> XHtmlT t Table3Content > th' = tellNode Table3 "th" [] > -> th :: XHtml FlowContent -> XHtml Table3Content +> th :: (Functor t, Monad t) => XHtmlT t FlowContent -> XHtmlT t Table3Content > th = th' [] -> td' :: Attrs -> XHtml FlowContent -> XHtml Table3Content +> td' :: (Functor t, Monad t) => Attrs -> XHtmlT t FlowContent -> XHtmlT t Table3Content > td' = tellNode Table3 "td" [] > -> td :: XHtml FlowContent -> XHtml Table3Content +> td :: (Functor t, Monad t) => XHtmlT t FlowContent -> XHtmlT t Table3Content > td = td' [] Text +escape = escapeEntity htmlImmune + where htmlImmune = ",.-_ " + +-- | Escaping text in attribute values +escapeAttr :: Text -> Text +escapeAttr = escapeEntity attributeImmune + where attributeImmune = ",.-_" + +-- | escaping basic text the be used inside normal HTML-elements +-- based on 'http://code.google.com/p/owasp-esapi-java/source/browse/trunk/src/main/java/org/owasp/esapi/codecs/HTMLEntityCodec.java' +-- +-- Should be improved by using an array-based lookup for chars <=0xff +escapeEntity :: String -> Text -> Text +escapeEntity immune = T.concatMap $ escapeChar immune encode + where + encode c + | Just ent <- I.lookup (fromEnum c) entityMap + = T.concat ["&", ent, ";"] + | otherwise = T.pack $ concat ["&#", hex c , ";"] + +-- | Escaping text intended for places where scripts can be used +escapeJavaScript :: Text -> Text +escapeJavaScript = T.concatMap $ escapeChar javaScriptImmune encode + where + encode c + | c <= toEnum 0xff = T.pack $ concat ["\\x", pad 2 $ hex c] + | c <= toEnum 0xffff = T.pack $ concat ["\\u", pad 4 $ hex c] + | c <= toEnum 0xffffff = T.pack $ concat ["\\u", pad 6 $ hex c] + | otherwise = T.pack $ concat ["\\u", pad 8 $ hex c] + + javaScriptImmune = ",._" + + pad n hex = reverse . take n $ reverse hex ++ repeat '0' + +-- | Escape text for CSS (style) data +escapeCSS :: Text -> Text +escapeCSS = T.concatMap $ escapeChar "" encode + where + encode c = T.pack $ concat ["\\", hex c, " "] + +-- | Escape a single character +escapeChar :: + [Char] -- ^ Lists of chars to be used verbatim + -> (Char -> Text) -- ^ function handling non standard cases + -> Char -- ^ char to encode + -> Text +escapeChar immune enc c + | c `elem` immune = T.singleton c + | c >= toEnum 0x30 && c <= toEnum 0x39 = T.singleton c + | c >= toEnum 0x41 && c <= toEnum 0x5A = T.singleton c + | c >= toEnum 0x61 && c <= toEnum 0x7A = T.singleton c + | c `elem` "\t\n\r" = T.singleton c + | c <= toEnum 0x1f = " " + | c >= toEnum 0x7f && c <= toEnum 0x9f = " " + | otherwise = enc c + +hex :: Char -> String +hex c = map toUpper $ showHex (fromEnum c) [] + +entityMap :: I.IntMap Text +entityMap = I.fromList [ + (34, "quot") {- quotation mark -}, + (38, "amp") {- ampersand -}, + (60, "lt") {- less-than sign -}, + (62, "gt") {- greater-than sign -}, + (160, "nbsp") {- no-break space -}, + (161, "iexcl") {- inverted exclamation mark -}, + (162, "cent") {- cent sign -}, + (163, "pound") {- pound sign -}, + (164, "curren") {- currency sign -}, + (165, "yen") {- yen sign -}, + (166, "brvbar") {- broken bar -}, + (167, "sect") {- section sign -}, + (168, "uml") {- diaeresis -}, + (169, "copy") {- copyright sign -}, + (170, "ordf") {- feminine ordinal indicator -}, + (171, "laquo") {- left-pointing double angle quotation mark -}, + (172, "not") {- not sign -}, + (173, "shy") {- soft hyphen -}, + (174, "reg") {- registered sign -}, + (175, "macr") {- macron -}, + (176, "deg") {- degree sign -}, + (177, "plusmn") {- plus-minus sign -}, + (178, "sup2") {- superscript two -}, + (179, "sup3") {- superscript three -}, + (180, "acute") {- acute accent -}, + (181, "micro") {- micro sign -}, + (182, "para") {- pilcrow sign -}, + (183, "middot") {- middle dot -}, + (184, "cedil") {- cedilla -}, + (185, "sup1") {- superscript one -}, + (186, "ordm") {- masculine ordinal indicator -}, + (187, "raquo") {- right-pointing double angle quotation mark -}, + (188, "frac14") {- vulgar fraction one quarter -}, + (189, "frac12") {- vulgar fraction one half -}, + (190, "frac34") {- vulgar fraction three quarters -}, + (191, "iquest") {- inverted question mark -}, + (192, "Agrave") {- Latin capital letter a with grave -}, + (193, "Aacute") {- Latin capital letter a with acute -}, + (194, "Acirc") {- Latin capital letter a with circumflex -}, + (195, "Atilde") {- Latin capital letter a with tilde -}, + (196, "Auml") {- Latin capital letter a with diaeresis -}, + (197, "Aring") {- Latin capital letter a with ring above -}, + (198, "AElig") {- Latin capital letter ae -}, + (199, "Ccedil") {- Latin capital letter c with cedilla -}, + (200, "Egrave") {- Latin capital letter e with grave -}, + (201, "Eacute") {- Latin capital letter e with acute -}, + (202, "Ecirc") {- Latin capital letter e with circumflex -}, + (203, "Euml") {- Latin capital letter e with diaeresis -}, + (204, "Igrave") {- Latin capital letter i with grave -}, + (205, "Iacute") {- Latin capital letter i with acute -}, + (206, "Icirc") {- Latin capital letter i with circumflex -}, + (207, "Iuml") {- Latin capital letter i with diaeresis -}, + (208, "ETH") {- Latin capital letter eth -}, + (209, "Ntilde") {- Latin capital letter n with tilde -}, + (210, "Ograve") {- Latin capital letter o with grave -}, + (211, "Oacute") {- Latin capital letter o with acute -}, + (212, "Ocirc") {- Latin capital letter o with circumflex -}, + (213, "Otilde") {- Latin capital letter o with tilde -}, + (214, "Ouml") {- Latin capital letter o with diaeresis -}, + (215, "times") {- multiplication sign -}, + (216, "Oslash") {- Latin capital letter o with stroke -}, + (217, "Ugrave") {- Latin capital letter u with grave -}, + (218, "Uacute") {- Latin capital letter u with acute -}, + (219, "Ucirc") {- Latin capital letter u with circumflex -}, + (220, "Uuml") {- Latin capital letter u with diaeresis -}, + (221, "Yacute") {- Latin capital letter y with acute -}, + (222, "THORN") {- Latin capital letter thorn -}, + (223, "szlig") {- Latin small letter sharp s, German Eszett -}, + (224, "agrave") {- Latin small letter a with grave -}, + (225, "aacute") {- Latin small letter a with acute -}, + (226, "acirc") {- Latin small letter a with circumflex -}, + (227, "atilde") {- Latin small letter a with tilde -}, + (228, "auml") {- Latin small letter a with diaeresis -}, + (229, "aring") {- Latin small letter a with ring above -}, + (230, "aelig") {- Latin lowercase ligature ae -}, + (231, "ccedil") {- Latin small letter c with cedilla -}, + (232, "egrave") {- Latin small letter e with grave -}, + (233, "eacute") {- Latin small letter e with acute -}, + (234, "ecirc") {- Latin small letter e with circumflex -}, + (235, "euml") {- Latin small letter e with diaeresis -}, + (236, "igrave") {- Latin small letter i with grave -}, + (237, "iacute") {- Latin small letter i with acute -}, + (238, "icirc") {- Latin small letter i with circumflex -}, + (239, "iuml") {- Latin small letter i with diaeresis -}, + (240, "eth") {- Latin small letter eth -}, + (241, "ntilde") {- Latin small letter n with tilde -}, + (242, "ograve") {- Latin small letter o with grave -}, + (243, "oacute") {- Latin small letter o with acute -}, + (244, "ocirc") {- Latin small letter o with circumflex -}, + (245, "otilde") {- Latin small letter o with tilde -}, + (246, "ouml") {- Latin small letter o with diaeresis -}, + (247, "divide") {- division sign -}, + (248, "oslash") {- Latin small letter o with stroke -}, + (249, "ugrave") {- Latin small letter u with grave -}, + (250, "uacute") {- Latin small letter u with acute -}, + (251, "ucirc") {- Latin small letter u with circumflex -}, + (252, "uuml") {- Latin small letter u with diaeresis -}, + (253, "yacute") {- Latin small letter y with acute -}, + (254, "thorn") {- Latin small letter thorn -}, + (255, "yuml") {- Latin small letter y with diaeresis -}, + (338, "OElig") {- Latin capital ligature oe -}, + (339, "oelig") {- Latin small ligature oe -}, + (352, "Scaron") {- Latin capital letter s with caron -}, + (353, "scaron") {- Latin small letter s with caron -}, + (376, "Yuml") {- Latin capital letter y with diaeresis -}, + (402, "fnof") {- Latin small letter f with hook -}, + (710, "circ") {- modifier letter circumflex accent -}, + (732, "tilde") {- small tilde -}, + (913, "Alpha") {- Greek capital letter alpha -}, + (914, "Beta") {- Greek capital letter beta -}, + (915, "Gamma") {- Greek capital letter gamma -}, + (916, "Delta") {- Greek capital letter delta -}, + (917, "Epsilon") {- Greek capital letter epsilon -}, + (918, "Zeta") {- Greek capital letter zeta -}, + (919, "Eta") {- Greek capital letter eta -}, + (920, "Theta") {- Greek capital letter theta -}, + (921, "Iota") {- Greek capital letter iota -}, + (922, "Kappa") {- Greek capital letter kappa -}, + (923, "Lambda") {- Greek capital letter lambda -}, + (924, "Mu") {- Greek capital letter mu -}, + (925, "Nu") {- Greek capital letter nu -}, + (926, "Xi") {- Greek capital letter xi -}, + (927, "Omicron") {- Greek capital letter omicron -}, + (928, "Pi") {- Greek capital letter pi -}, + (929, "Rho") {- Greek capital letter rho -}, + (931, "Sigma") {- Greek capital letter sigma -}, + (932, "Tau") {- Greek capital letter tau -}, + (933, "Upsilon") {- Greek capital letter upsilon -}, + (934, "Phi") {- Greek capital letter phi -}, + (935, "Chi") {- Greek capital letter chi -}, + (936, "Psi") {- Greek capital letter psi -}, + (937, "Omega") {- Greek capital letter omega -}, + (945, "alpha") {- Greek small letter alpha -}, + (946, "beta") {- Greek small letter beta -}, + (947, "gamma") {- Greek small letter gamma -}, + (948, "delta") {- Greek small letter delta -}, + (949, "epsilon") {- Greek small letter epsilon -}, + (950, "zeta") {- Greek small letter zeta -}, + (951, "eta") {- Greek small letter eta -}, + (952, "theta") {- Greek small letter theta -}, + (953, "iota") {- Greek small letter iota -}, + (954, "kappa") {- Greek small letter kappa -}, + (955, "lambda") {- Greek small letter lambda -}, + (956, "mu") {- Greek small letter mu -}, + (957, "nu") {- Greek small letter nu -}, + (958, "xi") {- Greek small letter xi -}, + (959, "omicron") {- Greek small letter omicron -}, + (960, "pi") {- Greek small letter pi -}, + (961, "rho") {- Greek small letter rho -}, + (962, "sigmaf") {- Greek small letter final sigma -}, + (963, "sigma") {- Greek small letter sigma -}, + (964, "tau") {- Greek small letter tau -}, + (965, "upsilon") {- Greek small letter upsilon -}, + (966, "phi") {- Greek small letter phi -}, + (967, "chi") {- Greek small letter chi -}, + (968, "psi") {- Greek small letter psi -}, + (969, "omega") {- Greek small letter omega -}, + (977, "thetasym") {- Greek theta symbol -}, + (978, "upsih") {- Greek upsilon with hook symbol -}, + (982, "piv") {- Greek pi symbol -}, + (8194, "ensp") {- en space -}, + (8195, "emsp") {- em space -}, + (8201, "thinsp") {- thin space -}, + (8204, "zwnj") {- zero width non-joiner -}, + (8205, "zwj") {- zero width joiner -}, + (8206, "lrm") {- left-to-right mark -}, + (8207, "rlm") {- right-to-left mark -}, + (8211, "ndash") {- en dash -}, + (8212, "mdash") {- em dash -}, + (8216, "lsquo") {- left single quotation mark -}, + (8217, "rsquo") {- right single quotation mark -}, + (8218, "sbquo") {- single low-9 quotation mark -}, + (8220, "ldquo") {- left double quotation mark -}, + (8221, "rdquo") {- right double quotation mark -}, + (8222, "bdquo") {- double low-9 quotation mark -}, + (8224, "dagger") {- dagger -}, + (8225, "Dagger") {- double dagger -}, + (8226, "bull") {- bullet -}, + (8230, "hellip") {- horizontal ellipsis -}, + (8240, "permil") {- per mille sign -}, + (8242, "prime") {- prime -}, + (8243, "Prime") {- double prime -}, + (8249, "lsaquo") {- single left-pointing angle quotation mark -}, + (8250, "rsaquo") {- single right-pointing angle quotation mark -}, + (8254, "oline") {- overline -}, + (8260, "frasl") {- fraction slash -}, + (8364, "euro") {- euro sign -}, + (8465, "image") {- black-letter capital i -}, + (8472, "weierp") {- script capital p, Weierstrass p -}, + (8476, "real") {- black-letter capital r -}, + (8482, "trade") {- trademark sign -}, + (8501, "alefsym") {- alef symbol -}, + (8592, "larr") {- leftwards arrow -}, + (8593, "uarr") {- upwards arrow -}, + (8594, "rarr") {- rightwards arrow -}, + (8595, "darr") {- downwards arrow -}, + (8596, "harr") {- left right arrow -}, + (8629, "crarr") {- downwards arrow with corner leftwards -}, + (8656, "lArr") {- leftwards double arrow -}, + (8657, "uArr") {- upwards double arrow -}, + (8658, "rArr") {- rightwards double arrow -}, + (8659, "dArr") {- downwards double arrow -}, + (8660, "hArr") {- left right double arrow -}, + (8704, "forall") {- for all -}, + (8706, "part") {- partial differential -}, + (8707, "exist") {- there exists -}, + (8709, "empty") {- empty set -}, + (8711, "nabla") {- nabla -}, + (8712, "isin") {- element of -}, + (8713, "notin") {- not an element of -}, + (8715, "ni") {- contains as member -}, + (8719, "prod") {- n-ary product -}, + (8721, "sum") {- n-ary summation -}, + (8722, "minus") {- minus sign -}, + (8727, "lowast") {- asterisk operator -}, + (8730, "radic") {- square root -}, + (8733, "prop") {- proportional to -}, + (8734, "infin") {- infinity -}, + (8736, "ang") {- angle -}, + (8743, "and") {- logical and -}, + (8744, "or") {- logical or -}, + (8745, "cap") {- intersection -}, + (8746, "cup") {- union -}, + (8747, "int") {- integral -}, + (8756, "there4") {- therefore -}, + (8764, "sim") {- tilde operator -}, + (8773, "cong") {- congruent to -}, + (8776, "asymp") {- almost equal to -}, + (8800, "ne") {- not equal to -}, + (8801, "equiv") {- identical to, equivalent to -}, + (8804, "le") {- less-than or equal to -}, + (8805, "ge") {- greater-than or equal to -}, + (8834, "sub") {- subset of -}, + (8835, "sup") {- superset of -}, + (8836, "nsub") {- not a subset of -}, + (8838, "sube") {- subset of or equal to -}, + (8839, "supe") {- superset of or equal to -}, + (8853, "oplus") {- circled plus -}, + (8855, "otimes") {- circled times -}, + (8869, "perp") {- up tack -}, + (8901, "sdot") {- dot operator -}, + (8968, "lceil") {- left ceiling -}, + (8969, "rceil") {- right ceiling -}, + (8970, "lfloor") {- left floor -}, + (8971, "rfloor") {- right floor -}, + (9001, "lang") {- left-pointing angle bracket -}, + (9002, "rang") {- right-pointing angle bracket -}, + (9674, "loz") {- lozenge -}, + (9824, "spades") {- black spade suit -}, + (9827, "clubs") {- black club suit -}, + (9829, "hearts") {- black heart suit -}, + (9830, "diams") {- black diamond suit -}] + diff --git a/src/Text/XHtmlCombinators/Extras/Lorem.hs b/src/Text/XHtmlCombinators/Extras/Lorem.hs new file mode 100644 --- /dev/null +++ b/src/Text/XHtmlCombinators/Extras/Lorem.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Text.XHtmlCombinators.Extras.Lorem +-- Copyright : (c) Alasdair Armstrong 2010 +-- License : BSD-style +-- Maintainer : alasdair.armstrong@googlemail.com +-- Stability : experimental +-- Portability : GHC + +module Text.XHtmlCombinators.Extras.Lorem + ( lorem', lorem + , loremIO', loremIO + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.State +import Control.Monad.Trans.Writer +import Data.Monoid +import System.Random + +import Data.Text (Text) +import qualified Data.Text as T + +import Text.XHtmlCombinators.Internal +import Text.XHtmlCombinators.Combinators + + +lorem' :: Block c => Attrs -> XHtmlT (State StdGen) c +lorem' attrs = p' attrs (text =<< randomPara) + +lorem :: Block c => XHtmlT (State StdGen) c +lorem = lorem' [] + +loremIO' :: Block c => Attrs -> XHtmlT IO c +loremIO' attrs = p' attrs (text =<< randomParaIO) + +loremIO :: Block c => XHtmlT IO c +loremIO = loremIO' [] + +randomPara :: Monoid a => WriterT a (State StdGen) Text +randomPara = lift . fmap para $ state (randomR (1, 5)) + +randomParaIO :: Monoid a => WriterT a IO Text +randomParaIO = do + gen <- lift newStdGen + return . para . fst $ randomR (1, 5) gen + +para :: Int -> Text + +para 1 = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Maecenas in nunc\ +\ sed nunc scelerisque molestie. Curabitur in mattis sem. Curabitur quis fringilla\ +\ tortor. Sed rutrum vehicula diam eu ullamcorper. Vivamus ligula justo, faucibus \ +\eget pretium nec, rutrum mollis quam. Nulla hendrerit, orci eu fringilla tempor, \ +\risus ligula posuere metus, vitae posuere arcu est non odio. Sed sem ipsum, porta\ +\ nec venenatis eget, interdum a quam. Donec et felis vitae urna dignissim digniss\ +\im in at orci. Sed varius consequat dapibus. Integer tellus eros, ullamcorper et \ +\ullamcorper non, consequat in ante. In ut sem ipsum. Vivamus ante orci, cursus vi\ +\tae blandit dapibus, gravida vel enim. Integer volutpat ligula in lorem auctor eg\ +\et ornare massa gravida. Nullam in metus diam, eget pellentesque sem. Vestibulum \ +\adipiscing accumsan nibh sit amet lobortis. Vivamus a quam turpis. Proin eu sapie\ +\n sapien, ut elementum ante. Sed magna eros, consectetur eget consequat nec, pell\ +\entesque vitae velit. Etiam mi tortor, cursus vel tristique non, dapibus vel mi. \ +\Aenean a lorem non massa porta vulputate ut nec turpis." + +para 2 = "Morbi a magna nec orci cursus semper in in lacus. Ut semper tempus lacus,\ +\ ut hendrerit mauris volutpat congue. In lacus turpis, tristique eu mattis ut, ti\ +\ncidunt eget sem. Ut lacinia lorem at lorem mollis tristique. In nec orci aliquam\ +\ enim sagittis sagittis non vitae ante. Morbi faucibus dolor ac mi lacinia tristi\ +\que. Aliquam et tortor urna, vel eleifend felis. Curabitur tellus augue, interdum\ +\ ac hendrerit at, volutpat tincidunt velit. In est lorem, imperdiet eget consequa\ +\t sagittis, sagittis nec quam. Duis non volutpat augue." + +para 3 = "Integer semper, elit eget viverra dignissim, lorem ipsum gravida tortor, \ +\ut cursus orci ante a diam. Morbi non metus et sem pellentesque dapibus sed vel m\ +\assa. Fusce commodo condimentum vulputate. Nullam porta, orci nec aliquam blandit\ +\, orci urna sollicitudin libero, non pharetra ligula urna id nibh. In metus nulla\ +\, facilisis ut tempor nec, elementum nec nunc. Aenean sapien sem, fringilla a bla\ +\ndit vitae, imperdiet nec orci. Integer sit amet nunc ut dui porttitor malesuada \ +\eu non mauris. Suspendisse eget diam sed dui auctor tempus eu et erat. In non lib\ +\ero id purus facilisis tempus. Nulla nec tellus eget justo dignissim sagittis sit\ +\ amet vitae lorem. Donec lobortis velit id massa pretium vitae tincidunt neque ul\ +\trices. Duis id erat enim, ac aliquet magna. Maecenas tempus leo eget risus trist\ +\ique congue eu ut turpis." + +para 4 = "Ut ultrices ante nec neque suscipit ornare. Sed adipiscing diam eu enim s\ +\celerisque quis rhoncus mauris pulvinar. Nulla dignissim eros a nisl posuere elei\ +\fend. Nullam leo sapien, porttitor quis commodo vel, congue quis nisl. In molesti\ +\e rutrum quam at malesuada. Etiam ac pretium lorem. Pellentesque nisl erat, viver\ +\ra in tempus eget, pulvinar vel nisi. Curabitur odio nisl, viverra ac faucibus se\ +\d, rhoncus et neque. Sed placerat dolor ante, pulvinar ultrices arcu. Nulla id le\ +\o odio, ut dignissim nisi. Phasellus id tortor libero, eget aliquet sapien. Nulla\ +\ facilisi. Duis ornare ultricies dolor, sed dapibus lorem sollicitudin non. Nulla\ +\m augue lorem, consequat ut faucibus ac, tempus id ipsum. Fusce sit amet libero s\ +\agittis dolor convallis volutpat. Aenean at elit libero. Phasellus eget odio eget\ +\ mauris vehicula luctus id a est." + +para 5 = "Sed purus orci, tincidunt non tincidunt a, mattis at justo. Vivamus quis \ +\nisl id justo volutpat tristique. Donec mattis, neque posuere aliquam molestie, m\ +\assa ipsum fringilla erat, et vehicula lorem libero quis nisi. In tellus nunc, el\ +\ementum eget blandit a, pellentesque at risus. Quisque in nulla id nibh eleifend \ +\ultricies viverra non felis. Aliquam tempus, libero at ullamcorper venenatis, ero\ +\s mauris consectetur urna, sit amet facilisis diam eros at tellus. Vestibulum con\ +\dimentum quam non est dapibus non faucibus mi luctus. Aenean quis massa nec diam \ +\varius hendrerit. Morbi tempus ornare lectus et dapibus. Sed tortor tellus, lobor\ +\tis a ullamcorper id, ornare nec sapien. Quisque varius feugiat ante, eu dictum e\ +\nim tempus et." diff --git a/src/Text/XHtmlCombinators/Internal.hs b/src/Text/XHtmlCombinators/Internal.hs --- a/src/Text/XHtmlCombinators/Internal.hs +++ b/src/Text/XHtmlCombinators/Internal.hs @@ -1,13 +1,27 @@ -{-# LANGUAGE PatternGuards, BangPatterns #-} +{-# LANGUAGE PatternGuards #-} + +-- | +-- Module : Text.XHtmlCombinators.Internal +-- Copyright : (c) Alasdair Armstrong 2010 +-- License : BSD-style +-- Maintainer : alasdair.armstrong@googlemail.com +-- Stability : experimental +-- Portability : GHC + module Text.XHtmlCombinators.Internal where import Control.Applicative -import Control.Monad.Writer +import Control.Monad +import Control.Monad.Identity +import Control.Monad.Trans +import Control.Monad.Trans.Writer import Data.Sequence import qualified Data.Sequence as Seq -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as T +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Exts (IsString (..)) + type Attrs = [Attr] data Attr = Attr Text Text deriving (Show) @@ -17,6 +31,14 @@ | WithAttrs Attrs deriving (Show) +class Content e where + toContent :: e -> Node + +type XHtmlMT t x a = WriterT (Seq x) t a +type XHtmlT t x = XHtmlMT t x () + +type XHtml x = XHtmlT Identity x + first :: Seq a -> a first seq | x :< _ <- viewl seq = x @@ -27,30 +49,25 @@ 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 :: (Functor t, Monad t, Content e) => Text -> Attrs -> Attrs -> XHtmlT t e -> t 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 () + Node name rattrs attrs . fmap toContent <$> execXHtml content -tellS :: x -> XHtml x +tellS :: Monad t => x -> XHtmlT t x tellS = tell . singleton -execXHtml :: XHtml x -> Seq x -execXHtml = snd . runWriter +execXHtml :: Monad t => XHtmlT t x -> t (Seq x) +execXHtml = execWriterT -tellTextNode :: (Node -> e) -> Text -> Attrs -> Attrs -> Text -> XHtml e +tellTextNode :: Monad t => (Node -> e) -> Text -> Attrs -> Attrs -> Text -> XHtmlT t e tellTextNode c name rattrs attrs = tellS . c . textNode name rattrs attrs -tellEmptyNode :: (Node -> e) -> Text -> Attrs -> Attrs -> XHtml e +tellEmptyNode :: Monad t => (Node -> e) -> Text -> Attrs -> Attrs -> XHtmlT t 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 +tellNode :: (Functor t, Monad t, Content a) + => (Node -> b) -> Text -> Attrs -> Attrs -> XHtmlT t a -> XHtmlT t b +tellNode c name rattrs attrs = tellS . c <=< lift . node name rattrs attrs -empty :: XHtml x +empty :: Monad t => XHtmlT t x empty = return () diff --git a/src/Text/XHtmlCombinators/Render.hs b/src/Text/XHtmlCombinators/Render.hs --- a/src/Text/XHtmlCombinators/Render.hs +++ b/src/Text/XHtmlCombinators/Render.hs @@ -1,13 +1,24 @@ +-- | +-- Module : Text.XHtmlCombinators.Render +-- Copyright : (c) Alasdair Armstrong 2010 +-- License : BSD-style +-- Maintainer : alasdair.armstrong@googlemail.com +-- Stability : experimental +-- Portability : GHC + module Text.XHtmlCombinators.Render ( render, renderPretty + , renderT, renderPrettyT ) where import Control.Applicative hiding (empty) +import Control.Monad.Identity 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 Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T import qualified Text.XML.Light as XML import Text.XHtmlCombinators.Internal @@ -36,8 +47,10 @@ -- -- 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 +renderT :: (Functor t, Monad t, Content c) => XHtmlT t c -> t Text +renderT page = do + content <- execXHtml page + return (fold $ renderNode . toContent <$> content) -- | Renders a pretty xhtml page with readable indentation. -- @@ -48,5 +61,13 @@ -- -- 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. +renderPrettyT :: (Functor t, Monad t, Content c) => XHtmlT t c -> t Text +renderPrettyT page = do + content <- renderT page + return (T.pack . unlines . fmap XML.ppContent . XML.parseXML . T.unpack $ content) + +render :: Content c => XHtml c -> Text +render = runIdentity . renderT + renderPretty :: Content c => XHtml c -> Text -renderPretty = T.pack . unlines . fmap XML.ppContent . XML.parseXML . T.unpack . render +renderPretty = runIdentity . renderPrettyT diff --git a/src/Text/XHtmlCombinators/Safe.hs b/src/Text/XHtmlCombinators/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Text/XHtmlCombinators/Safe.hs @@ -0,0 +1,123 @@ +-- | +-- Module : Text.XHtmlCombinators.Safe +-- Copyright : (c) Alasdair Armstrong 2010 +-- License : BSD-style +-- Maintainer : alasdair.armstrong@googlemail.com +-- Stability : experimental +-- Portability : GHC + +module Text.XHtmlCombinators.Safe + ( module Text.XHtmlCombinators + , text + , title', title + , base', base + , meta', meta + , style', style + , script', script + , bdo', bdo + , map', map_ + , area', area + , form', form + , optgroup', optgroup + , option', option + , textarea', textarea + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import Text.XHtmlCombinators.Escape +import qualified Text.XHtmlCombinators as X +import Text.XHtmlCombinators hiding + ( text + , title', title + , base', base + , meta', meta + , style', style + , script', script + , bdo', bdo + , img', img + , map', map_ + , area', area + , form', form + , optgroup', optgroup + , option', option + , textarea', textarea + ) + +-- TODO: Comment these explaining how escaping is applied. + +text :: (Functor t, Monad t, CData c) => Text -> XHtmlT t c +text = X.text . escape + +title' :: (Functor t, Monad t) => Attrs -> Text -> XHtmlT t HeadContent +title' attrs = X.title' attrs . escape + +title :: (Functor t, Monad t) => Text -> XHtmlT t HeadContent +title = title' [] + +base' :: (Functor t, Monad t) => Text -> Attrs -> XHtmlT t HeadContent +base' = X.base' . escapeAttr + +base :: (Functor t, Monad t) => Text -> XHtmlT t HeadContent +base = flip base' [] + +meta' :: (Functor t, Monad t) => Text -> Attrs -> XHtmlT t HeadContent +meta' = X.meta' . escapeAttr + +meta :: (Functor t, Monad t) => Text -> XHtmlT t HeadContent +meta = flip meta' [] + +style' :: (Functor t, Monad t) => Text -> Attrs -> Text -> XHtmlT t HeadContent +style' type_ attrs css = X.style' (escapeAttr type_) attrs (escapeCSS css) + +style :: (Functor t, Monad t) => Text -> Text -> XHtmlT t HeadContent +style = flip style' [] + +script' :: (Functor t, Monad t) => Text -> Attrs -> Text -> XHtmlT t HeadContent +script' type_ attrs js = X.script' (escapeAttr type_) attrs (escapeJavaScript js) + +script :: (Functor t, Monad t) => Text -> Text -> XHtmlT t HeadContent +script = flip script' [] + +bdo' :: (Functor t, Monad t, Inline c) => Text -> Attrs -> XHtmlT t InlineContent -> XHtmlT t c +bdo' dir = X.bdo' (escapeAttr dir) + +bdo :: (Functor t, Monad t, Inline c) => Text -> XHtmlT t InlineContent -> XHtmlT t c +bdo = flip bdo' [] + +map' :: (Functor t, Monad t, Flow c) => Text -> Attrs -> XHtmlT t MapContent -> XHtmlT t c +map' id = X.map' (escapeAttr id) + +map_ :: (Functor t, Monad t, Flow c) => Text -> XHtmlT t MapContent -> XHtmlT t c +map_ = flip map' [] + +area' :: (Functor t, Monad t) => Text -> Attrs -> XHtmlT t MapContent +area' alt = X.area' (escapeAttr alt) + +area :: (Functor t, Monad t) => Text -> XHtmlT t MapContent +area = flip area' [] + +form' :: (Functor t, Monad t, Block c) => Text -> Attrs -> XHtmlT t FlowContent -> XHtmlT t c +form' action = X.form' (escapeAttr action) + +form :: (Functor t, Monad t, Block c) => Text -> XHtmlT t FlowContent -> XHtmlT t c +form = flip form' [] + +optgroup' :: (Functor t, Monad t) => Text -> Attrs -> XHtmlT t OptionContent -> XHtmlT t OptionContent +optgroup' label = X.optgroup' (escapeAttr label) + +optgroup :: (Functor t, Monad t) => Text -> XHtmlT t OptionContent -> XHtmlT t OptionContent +optgroup = flip optgroup' [] + +option' :: (Functor t, Monad t) => Attrs -> Text -> XHtmlT t OptionContent +option' attrs = option' attrs . escape + +option :: (Functor t, Monad t) => Text -> XHtmlT t OptionContent +option = option' [] + +textarea' :: (Functor t, Monad t, Inline c) => Int -> Int -> Attrs -> Text -> XHtmlT t c +textarea' rows cols attrs = X.textarea' rows cols attrs . escape + +textarea :: (Functor t, Monad t, Inline c) => Int -> Int -> Text -> XHtmlT t c +textarea rows cols = textarea' rows cols [] diff --git a/xhtml-combinators.cabal b/xhtml-combinators.cabal --- a/xhtml-combinators.cabal +++ b/xhtml-combinators.cabal @@ -1,5 +1,5 @@ name: xhtml-combinators -version: 0.1 +version: 0.2 cabal-version: >= 1.2.3 synopsis: Fast and easy to use XHTML combinators. description: @@ -16,13 +16,20 @@ library build-Depends: - base < 5, containers, mtl, xml >= 1.3.5, text >= 0.7 + base < 5, containers, random, transformers, xml >= 1.3.5, text >= 0.7 hs-source-dirs: src exposed-modules: Text.XHtmlCombinators + Text.XHtmlCombinators.Safe + Text.XHtmlCombinators.Attributes + Text.XHtmlCombinators.Attributes.Safe + Text.XHtmlCombinators.Escape + Text.XHtmlCombinators.Render + Text.XHtmlCombinators.Extras.Lorem + other-modules: Text.XHtmlCombinators.Internal Text.XHtmlCombinators.Combinators - Text.XHtmlCombinators.Render - Text.XHtmlCombinators.Attributes + Text.XHtmlCombinators.Attributes.Internal + Text.XHtmlCombinators.Attributes.Internal.Safe extensions: OverloadedStrings, PatternGuards ghc-options: -O2