[demo of HSX without overlapping/undecidable instances
Jeremy Shaw <jeremy@seereason.com>**20120417203704
 Ignore-this: 5f497021b641198a682b25b1a44d9b34
] adddir ./HSX
addfile ./HSX/HTML.hs
hunk ./HSX/HTML.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  HSX.HTML
+-- Copyright   :  (c) Niklas Broberg, Jeremy Shaw 2008
+-- License     :  BSD-style (see the file LICENSE.txt)
+--
+-- Maintainer  :  Niklas Broberg, nibro@cs.chalmers.se
+-- Stability   :  experimental
+-- Portability :  Haskell 98
+--
+-- Attempt to render XHTML as well-formed HTML 4.01:
+--
+--  1. no short tags are used, e.g., \<script\>\<\/script\> instead of \<script \/\>
+--
+--  2. the end tag is forbidden for some elements, for these we:
+--
+--    * render only the open tag, e.g., \<br\>
+--
+--    * throw an error if the tag contains children
+--
+--  3. optional end tags are always rendered
+--
+-- Currently no validation is performed.
+-----------------------------------------------------------------------------
+module HSX.HTML (
+                 -- * Functions
+                  renderAsHTML
+                , htmlEscapeChars
+                 -- * Predefined XMLMetaData
+                , html4Strict
+                , html4StrictFrag
+                ) where
+
+import Data.List
+import HSX.XML
+import HSX.XML.PCDATA(escaper)
+
+-- | Pretty-prints HTML values.
+--
+-- Error Handling:
+--
+-- Some tags (such as img) can not contain children in HTML. However,
+-- there is nothing to stop the caller from passing in XML which
+-- contains an img tag with children. There are three basic ways to
+-- handle this:
+--
+--  1. drop the bogus children silently
+--
+--  2. call 'error' \/ raise an exception
+--
+--  3. render the img tag with children -- even though it is invalid
+--
+-- Currently we are taking approach #3, since no other attempts to
+-- validate the data are made in this function. Instead, you can run
+-- the output through a full HTML validator to detect the errors.
+--
+-- #1 seems like a poor choice, since it makes is easy to overlook the
+-- fact that data went missing.
+--
+-- We could raising errors, but you have to be in the IO monad to
+-- catch them. Also, you have to use evaluate if you want to check for
+-- errors. This means you can not start sending the page until the
+-- whole page has been rendered. And you have to store the whole page
+-- in RAM at once. Similar problems occur if we return Either
+-- instead. We mostly care about catching errors and showing them in
+-- the browser during testing, so perhaps this can be configurable.
+--
+-- Another solution would be a compile time error if an empty-only
+-- tag contained children.
+--
+-- FIXME: also verify that the domain is correct
+--
+-- FIXME: what to do if a namespace is encountered
+renderAsHTML :: XML -> String
+renderAsHTML xml = renderAsHTML' 0 xml ""
+
+data TagType = Open | Close
+
+renderAsHTML' :: Int -> XML -> ShowS
+renderAsHTML' _ (CDATA needsEscape cd) = showString (if needsEscape then (escaper htmlEscapeChars cd) else cd)
+renderAsHTML' n elm@(Element name@(Nothing,nm) attrs children)
+    | nm == "area"	= renderTagEmpty children
+    | nm == "base"	= renderTagEmpty children
+    | nm == "br"        = renderTagEmpty children
+    | nm == "col"       = renderTagEmpty children
+    | nm == "hr"        = renderTagEmpty children
+    | nm == "img"       = renderTagEmpty children
+    | nm == "input"     = renderTagEmpty children
+    | nm == "link"      = renderTagEmpty children
+    | nm == "meta"      = renderTagEmpty children
+    | nm == "param"     = renderTagEmpty children
+    | nm == "script"    = renderElement n (Element name attrs (map asCDATA children))
+    | nm == "style"     = renderElement n (Element name attrs (map asCDATA children))
+    where
+      renderTagEmpty [] = renderTag Open n name attrs
+      renderTagEmpty _ = renderElement n elm -- this case should not happen in valid HTML
+      -- for and script\/style, render text in element as CDATA not PCDATA
+      asCDATA :: XML -> XML
+      asCDATA (CDATA _ cd) = (CDATA False cd)
+      asCDATA o = o -- this case should not happen in valid HTML
+renderAsHTML' n e = renderElement n e
+
+renderElement :: Int -> XML -> String -> String
+renderElement n (Element name attrs children) =
+        let open  = renderTag Open n name attrs
+            cs    = renderChildren n children
+            close = renderTag Close n name []
+         in open . cs . close
+  where renderChildren :: Int -> Children -> ShowS
+        renderChildren n' cs = foldl (.) id $ map (renderAsHTML' (n'+2)) cs
+renderElement _ _ = error "internal error: renderElement only suports the Element constructor."
+
+
+renderTag :: TagType -> Int -> Name -> Attributes -> ShowS
+renderTag typ n name attrs =
+        let (start,end) = case typ of
+                           Open   -> (showChar '<', showChar '>')
+                           Close  -> (showString "</", showChar '>')
+            nam = showName name
+            as  = renderAttrs attrs
+         in start . nam . as . end
+
+  where renderAttrs :: Attributes -> ShowS
+        renderAttrs [] = nl
+        renderAttrs attrs' = showChar ' ' . ats . nl
+          where ats = foldl (.) id $ intersperse (showChar ' ') $ fmap renderAttr attrs'
+
+
+        renderAttr :: Attribute -> ShowS
+        renderAttr (MkAttr (nam, (Value needsEscape val))) = showName nam . showChar '=' . renderAttrVal (if needsEscape then (escaper htmlEscapeChars val) else val)
+
+        renderAttrVal :: String -> ShowS
+        renderAttrVal s = showChar '\"' . showString s . showChar '\"'
+
+        showName (Nothing, s) = showString s
+        showName (Just d, s)  = showString d . showChar ':' . showString s
+
+        nl = showChar '\n' . showString (replicate n ' ')
+
+-- This list should be extended.
+htmlEscapeChars :: [(Char, String)]
+htmlEscapeChars = [
+	('&',	"amp"	),
+	('\"',	"quot"	),
+	('<',	"lt"	),
+	('>',	"gt"	)
+	]
+
+-- * Pre-defined XMLMetaData
+
+html4Strict :: Maybe XMLMetaData
+html4Strict = Just $
+    XMLMetaData { doctype = (True, "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n")
+                , contentType = "text/html;charset=utf-8"
+                , preferredRenderer = renderAsHTML
+                }
+
+html4StrictFrag :: Maybe XMLMetaData
+html4StrictFrag = Just $
+    XMLMetaData { doctype = (False, "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\n")
+                , contentType = "text/html;charset=utf-8"
+                , preferredRenderer = renderAsHTML
+                }
addfile ./HSX/Identity.hs
hunk ./HSX/Identity.hs 1
+{-# LANGUAGE CPP, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies, FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module HSX.Identity
+    ( Ident
+    , evalIdentity
+    ) where
+
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import HSX.XMLGenerator (EmbedAsChild(..), AppendChild(..), SetAttr(..), EmbedAsAttr(..), XMLGenT(..), Attr(..), IsName(..), unXMLGenT)
+import HSX.XML
+import Control.Monad.Identity (Identity(Identity, runIdentity))
+import qualified HSX.XMLGenerator as HSX
+
+instance HSX.XMLGenerator Identity
+
+instance HSX.XMLGen Identity where
+#if __GLASGOW_HASKELL__ < 702
+    type HSX.XML Identity = XML
+    newtype HSX.Child Identity = IChild { unIChild :: XML }
+    newtype HSX.Attribute Identity = IAttr { unIAttr :: Attribute }
+#else
+    type XML Identity = XML
+    newtype Child Identity = IChild { unIChild :: XML }
+    newtype Attribute Identity = IAttr { unIAttr :: Attribute }
+#endif
+    genElement n attrs children = HSX.XMLGenT $ Identity (Element
+                                                          (toName n)
+                                                          (map unIAttr $ concatMap runIdentity $ map HSX.unXMLGenT attrs)
+                                                          (map unIChild $ concatMap runIdentity $ map HSX.unXMLGenT children)
+                                                         )
+    xmlToChild = IChild
+    pcdataToChild = HSX.xmlToChild . pcdata
+{-
+instance IsAttrValue Identity T.Text where
+    toAttrValue = toAttrValue . T.unpack
+
+instance IsAttrValue Identity TL.Text where
+    toAttrValue = toAttrValue . TL.unpack
+-}
+instance EmbedAsAttr Identity Attribute where
+    asAttr = return . (:[]) . IAttr
+
+instance EmbedAsAttr Identity (Attr String Char) where
+    asAttr (n := c)  = asAttr (n := [c])
+
+instance EmbedAsAttr Identity (Attr String String) where
+    asAttr (n := str)  = asAttr $ MkAttr (toName n, pAttrVal str)
+
+instance EmbedAsAttr Identity (Attr String Bool) where
+    asAttr (n := True)  = asAttr $ MkAttr (toName n, pAttrVal "true")
+    asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false")
+
+instance EmbedAsAttr Identity (Attr String Int) where
+    asAttr (n := i)  = asAttr $ MkAttr (toName n, pAttrVal (show i))
+
+instance (IsName n) => (EmbedAsAttr Identity (Attr n TL.Text)) where
+    asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.unpack a)
+
+instance (IsName n) => (EmbedAsAttr Identity (Attr n T.Text)) where
+    asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ T.unpack a)
+
+instance EmbedAsChild Identity Char where
+    asChild = XMLGenT . Identity . (:[]) . IChild . pcdata . (:[])
+
+-- instance EmbedAsChild Identity String where
+--    asChild = XMLGenT . Identity . (:[]) . IChild . pcdata
+
+instance (EmbedAsChild Identity TL.Text) where
+    asChild = asChild . TL.unpack
+
+instance (EmbedAsChild Identity T.Text) where
+    asChild = asChild . T.unpack
+
+instance EmbedAsChild Identity XML where
+    asChild = XMLGenT . Identity . (:[]) . IChild
+
+-- instance (HSX.XML m ~ xml, m ~ Identity) => EmbedAsChild Identity (XMLGenT m xml) where
+--    asChild = XMLGenT . Identity . (:[]) . IChild . runIdentity . unXMLGenT
+
+instance (m ~ Identity, xml ~ HSX.XML m) => EmbedAsChild Identity (XMLGenT m xml) where
+    asChild = XMLGenT . Identity . (:[]) . IChild . runIdentity . unXMLGenT
+
+instance EmbedAsChild Identity c => EmbedAsChild Identity [c] where
+ asChild = fmap concat . mapM asChild
+
+instance EmbedAsChild Identity () where
+  asChild () = return []
+
+instance AppendChild Identity XML where
+ appAll xml children = do
+        chs <- children
+        case xml of
+         CDATA _ _       -> return xml
+         Element n as cs -> return $ Element n as (cs ++ (map stripChild chs))
+
+stripAttr :: HSX.Attribute Identity -> Attribute
+stripAttr  (IAttr a) = a
+
+stripChild :: HSX.Child Identity -> XML
+stripChild (IChild c) = c
+
+instance SetAttr Identity XML where
+ setAll xml hats = do
+        attrs <- hats
+        case xml of
+         CDATA _ _       -> return xml
+         Element n as cs -> return $ Element n (foldr insert as (map stripAttr attrs)) cs
+
+insert :: Attribute -> Attributes -> Attributes
+insert = (:)
+
+evalIdentity :: XMLGenT Identity XML -> XML
+evalIdentity = runIdentity . HSX.unXMLGenT
+
+type Ident = XMLGenT Identity
adddir ./HSX/XML
addfile ./HSX/XML.hs
hunk ./HSX/XML.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  HSX.XML
+-- Copyright   :  (c) Niklas Broberg 2008
+-- License     :  BSD-style (see the file LICENSE.txt)
+--
+-- Maintainer  :  Niklas Broberg, nibro@cs.chalmers.se
+-- Stability   :  experimental
+-- Portability :  Haskell 98
+--
+-- Datatypes and type classes comprising the basic model behind
+-- the scenes of Haskell Server Pages tags.
+-----------------------------------------------------------------------------
+module HSX.XML (
+        -- * The 'XML' datatype
+        XML(..),
+        XMLMetaData(..),
+        Domain,
+        Name,
+        Attributes,
+        Children,
+        pcdata,
+        cdata,
+        -- * The Attribute type
+        Attribute(..),
+        AttrValue(..),
+        attrVal, pAttrVal,
+        -- * Functions
+        renderXML,
+        isElement, isCDATA
+        ) where
+
+import Data.List (intersperse)
+
+import HSX.XML.PCDATA (escape)
+---------------------------------------------------------------
+-- Data types
+
+type Domain = Maybe String
+type Name = (Domain, String)
+type Attributes = [Attribute]
+type Children = [XML]
+
+-- | The XML datatype representation. Is either an Element or CDATA.
+data XML = Element Name Attributes Children
+         | CDATA Bool String
+  deriving Show
+
+-- |The XMLMetaData datatype
+--
+-- Specify the DOCTYPE, content-type, and preferred render for XML data.
+--
+-- See also: 'HSP.Monad.setMetaData' and 'HSP.Monad.withMetaData'
+data XMLMetaData = XMLMetaData
+  {  doctype :: (Bool, String) -- ^ (show doctype when rendering, DOCTYPE string)
+  ,  contentType :: String
+  ,  preferredRenderer :: XML -> String
+  }
+
+{- instance Show XML where
+ show = renderXML -}
+
+-- | Test whether an XML value is an Element or CDATA
+isElement, isCDATA :: XML -> Bool
+isElement (Element {}) = True
+isElement _ = False
+isCDATA = not . isElement
+
+-- | Embeds a string as a CDATA XML value.
+cdata , pcdata :: String -> XML
+cdata  = CDATA False
+pcdata = CDATA True
+
+---------------------------------------------------------------
+-- Attributes
+
+newtype Attribute = MkAttr (Name, AttrValue)
+  deriving Show
+
+-- | Represents an attribue value.
+data AttrValue = Value Bool String
+
+-- | Create an attribue value from a string.
+attrVal, pAttrVal :: String -> AttrValue
+attrVal  = Value False
+pAttrVal = Value True
+
+instance Show AttrValue where
+ show (Value _ str) = str
+
+------------------------------------------------------------------
+-- Rendering
+
+-- TODO: indents are incorrectly calculated
+
+-- | Pretty-prints XML values.
+renderXML :: XML -> String
+renderXML xml = renderXML' 0 xml ""
+
+data TagType = Open | Close | Single
+
+renderXML' :: Int -> XML -> ShowS
+renderXML' _ (CDATA needsEscape cd) = showString (if needsEscape then escape cd else cd)
+renderXML' n (Element name attrs []) = renderTag Single n name attrs
+renderXML' n (Element name attrs children) =
+        let open  = renderTag Open n name attrs
+            cs    = renderChildren n children
+            close = renderTag Close n name []
+         in open . cs . close
+
+  where renderChildren :: Int -> Children -> ShowS
+        renderChildren n' cs = foldl (.) id $ map (renderXML' (n'+2)) cs
+
+
+renderTag :: TagType -> Int -> Name -> Attributes -> ShowS
+renderTag typ n name attrs =
+        let (start,end) = case typ of
+                           Open   -> (showChar '<', showChar '>')
+                           Close  -> (showString "</", showChar '>')
+                           Single -> (showChar '<', showString "/>")
+            nam = showName name
+            as  = renderAttrs attrs
+         in start . nam . as . end
+
+  where renderAttrs :: Attributes -> ShowS
+        renderAttrs [] = nl
+        renderAttrs attrs' = showChar ' ' . ats . nl
+          where ats = foldl (.) id $ intersperse (showChar ' ') $ fmap renderAttr attrs'
+
+
+        renderAttr :: Attribute -> ShowS
+        renderAttr (MkAttr (nam, (Value needsEscape val))) = showName nam . showChar '=' . renderAttrVal  (if needsEscape then escape val else val)
+
+        renderAttrVal :: String -> ShowS
+        renderAttrVal s = showChar '\"' . showString s . showChar '\"'
+
+        showName (Nothing, s) = showString s
+        showName (Just d, s)  = showString d . showChar ':' . showString s
+
+        nl = showChar '\n' . showString (replicate n ' ')
+
addfile ./HSX/XML/PCDATA.hs
hunk ./HSX/XML/PCDATA.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  HSX.XML.PCDATA
+-- Copyright   :  (c) Niklas Broberg 2008
+-- License     :  BSD-style (see the file LICENSE.txt)
+--
+-- Maintainer  :  Niklas Broberg, nibro@cs.chalmers.se
+-- Stability   :  experimental
+-- Portability :  Haskell 98
+--
+-- Escaping between CDATA <=> PCDATA
+-----------------------------------------------------------------------------
+module HSX.XML.PCDATA (
+	  escape	-- :: String -> String
+	, unescape	-- :: String -> String
+        , escaper
+        , unescaper
+        , xmlEscapeChars
+	) where
+
+
+-- | Take a normal string and transform it to PCDATA by escaping special characters.
+-- calls 'escaper' with 'xmlEscapeChars'
+-- See also: 'escaper'
+escape :: String -> String
+escape = escaper xmlEscapeChars
+
+-- | Take a normal string and transform it to PCDATA by escaping special characters.
+-- See also: 'escape', 'xmlEscapeChars'
+escaper :: [(Char, String)] -- ^ table of escape characters
+        -> String -- ^ String to escape
+        -> String -- ^ Escaped String
+escaper _ [] = ""
+escaper escapeChars (c:cs) = pChar escapeChars c ++ escaper escapeChars cs
+
+pChar :: [(Char, String)] -- ^ table of escape characters
+      -> Char -- ^ character to escape
+      -> String -- ^ escaped character
+pChar escapeChars c =
+    case lookup c escapeChars of
+      Nothing -> [c]
+      Just s  -> '&' : s ++ ";"
+
+-- This list should be extended.
+xmlEscapeChars :: [(Char, String)]
+xmlEscapeChars = [
+	('&',	"amp"	),
+	('\"',	"quot"	),
+	('\'',	"apos"	),
+	('<',	"lt"	),
+	('>',	"gt"	)
+	]
+
+-- | Take a PCDATA string and translate all escaped characters in it to the normal
+-- characters they represent.
+-- Does no error checking of input string, will fail if input is not valid PCDATA.
+-- calls 'unescaper' with 'xmlEscapeChars'
+-- See also: 'unescaper'
+unescape :: String -> String
+unescape = unescaper xmlEscapeChars
+
+-- | Take a PCDATA string and translate all escaped characters in it to the normal
+-- characters they represent.
+-- Does no error checking of input string, will fail if input is not valid PCDATA.
+-- See also: 'unescape', 'xmlEscapeChars'
+unescaper :: [(Char, String)] -- ^ table of escape characters
+          -> String -- ^ String to unescape
+          -> String -- ^ unescaped String
+unescaper escapeChars = reverse . unE ""
+  where unE acc "" = acc
+  	unE acc (c:cs) =
+  	  case c of
+  	    '&' -> let (esc, ';':rest) = break (==';') cs
+  	               Just ec = revLookup esc escapeChars
+  	            in unE (ec:acc) rest
+  	    _ -> unE (c:acc) cs
+
+  	revLookup e = lookup e . map (\(a,b) -> (b,a))
addfile ./HSX/XMLGenerator.hs
hunk ./HSX/XMLGenerator.hs 1
+{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies,
+  FlexibleContexts, FlexibleInstances, TypeSynonymInstances, GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  HSX.XMLGenerator
+-- Copyright   :  (c) Niklas Broberg 2008
+-- License     :  BSD-style (see the file LICENSE.txt)
+--
+-- Maintainer  :  Niklas Broberg, niklas.broberg@chalmers.se
+-- Stability   :  experimental
+-- Portability :  requires newtype deriving and MPTCs with fundeps
+--
+-- The class and monad transformer that forms the basis of the literal XML
+-- syntax translation. Literal tags will be translated into functions of
+-- the GenerateXML class, and any instantiating monads with associated XML
+-- types can benefit from that syntax.
+-----------------------------------------------------------------------------
+module HSX.XMLGenerator where
+
+import Control.Applicative (Applicative, Alternative)
+import Control.Monad.Trans (MonadTrans(lift), MonadIO)
+import Control.Monad.Cont  (MonadCont)
+import Control.Monad.Error (MonadError)
+import Control.Monad.Reader(MonadReader)
+import Control.Monad.Writer(MonadWriter)
+import Control.Monad.State (MonadState)
+import Control.Monad.RWS   (MonadRWS)
+import Control.Monad       (MonadPlus(..),liftM)
+import qualified Data.Text      as Strict
+import qualified Data.Text.Lazy as Lazy
+
+----------------------------------------------
+-- General XML Generation
+
+-- | The monad transformer that allows a monad to generate XML values.
+newtype XMLGenT m a = XMLGenT (m a)
+  deriving (Applicative, Alternative, Monad, Functor, MonadIO, MonadPlus, MonadWriter w, MonadReader r,
+            MonadState s, MonadRWS r w s, MonadCont, MonadError e)
+
+-- | un-lift.
+unXMLGenT :: XMLGenT m a -> m a
+unXMLGenT   (XMLGenT ma) =  ma
+
+-- | map the inner monad
+mapXMLGenT :: (m a -> n b) -> XMLGenT m a -> XMLGenT n b
+mapXMLGenT f (XMLGenT m) = XMLGenT (f m)
+
+instance MonadTrans XMLGenT where
+ lift = XMLGenT
+
+type Name = (Maybe String, String)
+
+-- | Generate XML values in some XMLGenerator monad.
+class Monad m => XMLGen m where
+ type XML m
+ data Child m
+ data Attribute m
+ genElement  :: Name -> [XMLGenT m [Attribute m]] -> [XMLGenT m [Child m]] -> XMLGenT m (XML m)
+ genEElement :: Name -> [XMLGenT m [Attribute m]]                          -> XMLGenT m (XML m)
+ genEElement n ats = genElement n ats []
+ xmlToChild :: XML m -> Child m
+ pcdataToChild :: String -> Child m
+
+-- | Type synonyms to avoid writing out the XMLnGenT all the time
+type GenXML m           = XMLGenT m (XML m)
+type GenXMLList m       = XMLGenT m [XML m]
+type GenChild m         = XMLGenT m (Child m)
+type GenChildList m     = XMLGenT m [Child m]
+type GenAttribute m     = XMLGenT m (Attribute m)
+type GenAttributeList m = XMLGenT m [Attribute m]
+
+-- | Embed values as child nodes of an XML element. The parent type will be clear
+-- from the context so it is not mentioned.
+class XMLGen m => EmbedAsChild m c where
+ asChild :: c -> GenChildList m
+
+-- | Similarly embed values as attributes of an XML element.
+class XMLGen m => EmbedAsAttr m a where
+ asAttr :: a -> GenAttributeList m
+
+class (XMLGen m,
+       SetAttr m (XML m),
+       AppendChild m (XML m),
+       EmbedAsChild m (XML m),
+       EmbedAsChild m [XML m],
+       EmbedAsChild m String,
+       EmbedAsChild m Char, -- for overlap purposes
+       EmbedAsChild m (),   -- for overlap purposes
+       EmbedAsChild m Strict.Text,
+       EmbedAsChild m Lazy.Text,
+       EmbedAsAttr m (Attr String String),
+       EmbedAsAttr m (Attr String Int),
+       EmbedAsAttr m (Attr String Bool)
+       ) => XMLGenerator m
+
+data Attr n a = n := a
+  deriving Show
+
+-------------------------------------
+-- Setting attributes
+
+-- | Set attributes on XML elements
+class XMLGen m => SetAttr m elem where
+ setAttr :: elem -> GenAttribute m     -> GenXML m
+ setAll  :: elem -> GenAttributeList m -> GenXML m
+ setAttr e a = setAll e $ liftM return a
+
+(<@), set :: (SetAttr m elem, EmbedAsAttr m attr) => elem -> attr -> GenXML m
+set xml attr = setAll xml (asAttr attr)
+(<@) = set
+
+(<<@) :: (SetAttr m elem, EmbedAsAttr m a) => elem -> [a] -> GenXML m
+xml <<@ ats = setAll xml (liftM concat $ mapM asAttr ats)
+
+-------------------------------------
+-- Appending children
+
+class XMLGen m => AppendChild m elem where
+ appChild :: elem -> GenChild m     -> GenXML m
+ appAll   :: elem -> GenChildList m -> GenXML m
+ appChild e c = appAll e $ liftM return c
+
+(<:), app :: (AppendChild m elem, EmbedAsChild m c) => elem -> c -> GenXML m
+app xml c = appAll xml $ asChild c
+(<:) = app
+
+(<<:) :: (AppendChild m elem, EmbedAsChild m c) => elem -> [c] -> GenXML m
+xml <<: chs = appAll xml (liftM concat $ mapM asChild chs)
+
+-------------------------------------
+-- Names
+
+-- | Names can be simple or qualified with a domain. We want to conveniently
+-- use both simple strings or pairs wherever a Name is expected.
+class Show n => IsName n where
+ toName :: n -> Name
+
+-- | Names can represent names, of course.
+instance IsName Name where
+ toName = id
+
+-- | Strings can represent names, meaning a simple name with no domain.
+instance IsName String where
+ toName s = (Nothing, s)
+
+-- | Pairs of strings can represent names, meaning a name qualified with a domain.
+instance IsName (String, String) where
+ toName (ns, s) = (Just ns, s)
addfile ./LICENSE
hunk ./LICENSE 1
+Copyright (c)2012, Jeremy Shaw
+
+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.
+
+    * Neither the name of Jeremy Shaw nor the names of other
+      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
+OWNER OR CONTRIBUTORS 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.
addfile ./Setup.hs
hunk ./Setup.hs 1
+import Distribution.Simple
+main = defaultMain
addfile ./demo.hs
hunk ./demo.hs 1
+{-# OPTIONS_GHC -F -pgmFtrhsx #-}
+module Main where
hunk ./demo.hs 4
+import HSX.XMLGenerator hiding (XML)
+import HSX.HTML
+import HSX.XML
+import HSX.Identity
+import Control.Monad.Identity
+
+main :: IO ()
+main = putStrLn $ renderAsHTML $ evalIdentity html
+
+html :: XMLGenT Identity XML
+html =
+    <div>
+     <div>
+      <p>foo</p>
+     </div>
+    </div>
addfile ./xmlgen.cabal
hunk ./xmlgen.cabal 1
+Name:                xmlgen
+Version:             0.1
+License:             BSD3
+License-file:        LICENSE
+Author:              Jeremy Shaw
+Maintainer:          jeremy@n-heptane.com
+-- Copyright:
+Category:            Text
+Build-type:          Simple
+Cabal-version:       >=1.2
+
+Library
+  Exposed-modules:     HSX.HTML, HSX.Identity, HSX.XMLGenerator, HSX.XML, HSX.XML.PCDATA
+  Build-depends:     base < 5,
+                     mtl  == 2.0.*,
+                     text == 0.11.*