Permalink
Browse files

added ignore file

  • Loading branch information...
1 parent 685bc49 commit 8861fd6404155d106c013932ab077061397c612c @skogsbaer committed Jan 16, 2011
Showing with 219 additions and 49 deletions.
  1. +1 −0 .gitignore
  2. +96 −43 src/Text/XML/Generator.hs
  3. +94 −5 src/Text/XML/GeneratorTest.hs
  4. +28 −1 xmlgen.cabal
View
@@ -0,0 +1 @@
+(^|/)dist
View
@@ -1,14 +1,14 @@
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TypeFamilies, MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies, MultiParamTypeClasses #-}
module Text.XML.Generator (
Xml, Doc, DocInfo, Elem, Attr, Namespace, Prefix, Uri
, XmlOutput, Renderable
, ns, doc, defaultDocInfo
- , xattr, xattrQ, xattrs
+ , xattr, xattrRaw, xattrQ, xattrQRaw, xattrs
, xelem, xelemEmpty, xelems, xelemQ
- , xtext, xentityRef, xprocessingInstruction, xcomment, xempty
+ , xtext, xtextRaw, xentityRef, xprocessingInstruction, xcomment, xempty
, xrender
, (<>), (<#>)
@@ -21,17 +21,16 @@ module Text.XML.Generator (
{-
TODO:
-- raw content
-- Data.Text.Text, Data.Text.Lazy.Text as type for content
-- tests
+- benchmarks
+- documentation
-}
import Prelude hiding (elem)
import Control.Monad.Reader (Reader(..), ask, asks, runReader)
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as BSL
-import Data.Monoid
+import Data.Monoid hiding (mconcat)
import Blaze.ByteString.Builder hiding (empty, append)
import qualified Blaze.ByteString.Builder as Blaze
@@ -41,7 +40,10 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Char (isPrint, ord)
+import qualified Data.String as S
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
--
-- Basic definitions
--
@@ -113,47 +115,94 @@ doc di rootElem = Xml $ \(Doc buffer) ->
postMisc = docInfo_postMisc di
--
+-- Text content
+--
+
+class RawTextContent t where
+ rawTextBuilder :: t -> Builder
+
+class RawTextContent t => TextContent t where
+ escape :: t -> t
+ textBuilder :: TextContent t => t -> Builder
+ textBuilder = rawTextBuilder . escape
+
+instance RawTextContent String where
+ rawTextBuilder = fromString
+
+instance TextContent String where
+ escape = genericEscape foldr showString showChar
+
+instance RawTextContent T.Text where
+ rawTextBuilder = fromText
+
+instance TextContent T.Text where
+ escape = genericEscape T.foldr T.append T.cons
+
+instance RawTextContent TL.Text where
+ rawTextBuilder = fromLazyText
+
+instance TextContent TL.Text where
+ escape = genericEscape TL.foldr TL.append TL.cons
+
+instance RawTextContent BS.ByteString where
+ rawTextBuilder = fromByteString
+
+instance RawTextContent BSL.ByteString where
+ rawTextBuilder = fromLazyByteString
+
+--
-- Attributes
--
-class MkAttr n where
- type MkAttrRes n
- xattr :: n -> MkAttrRes n
+-- Note: attributes are quoted with "
+
+class MkAttr n t where
+ type MkAttrRes n t
+ xattr :: TextContent t => n -> MkAttrRes n t
+ xattrRaw :: RawTextContent t => n -> MkAttrRes n t
-instance MkAttr String where
- type MkAttrRes String = String -> Xml Attr
+instance MkAttr String t where
+ type MkAttrRes String t = t -> Xml Attr
xattr = xattrQ DefaultNamespace
+ xattrRaw = xattrQRaw DefaultNamespace
-instance MkAttr Namespace where
- type MkAttrRes Namespace = String -> String -> Xml Attr
+instance MkAttr Namespace t where
+ type MkAttrRes Namespace t = String -> t -> Xml Attr
xattr = xattrQ
+ xattrRaw = xattrQRaw
-- value is escaped
-xattrQ :: Namespace -> String -> String -> Xml Attr
-xattrQ ns' key value = Xml $ \(Attr buffer) ->
+xattrQ :: TextContent t => Namespace -> String -> t -> Xml Attr
+xattrQ ns key value = xattrQRaw' ns key (textBuilder value)
+
+-- value is NOT escaped
+xattrQRaw :: RawTextContent t => Namespace -> String -> t -> Xml Attr
+xattrQRaw ns key value = xattrQRaw' ns key (rawTextBuilder value)
+
+xattrQRaw' :: Namespace -> String -> Builder -> Xml Attr
+xattrQRaw' ns' key valueBuilder = Xml $ \(Attr buffer) ->
do uriMap' <- ask
let (ns, uriMap, newNs) = genValidNsForDesiredPrefix uriMap' ns'
builder = case ns of
- DefaultNamespace -> mconcat [spaceBuilder, keyBuilder, startBuilder
- ,valueBuilder, endBuilder]
+ DefaultNamespace -> spaceBuilder `mappend` keyBuilder `mappend` startBuilder
+ `mappend` valueBuilder `mappend` endBuilder
QualifiedNamespace p u ->
let uriBuilder = fromString u
prefixBuilder = fromString p
in if newNs
- then mconcat [spaceBuilder, nsDeclStartBuilder, colonBuilder
- ,prefixBuilder, startBuilder, uriBuilder
- ,endBuilder, spaceBuilder, prefixBuilder
- ,colonBuilder, keyBuilder, startBuilder
- ,valueBuilder, endBuilder]
- else mconcat [spaceBuilder, prefixBuilder, colonBuilder
- ,keyBuilder, startBuilder
- ,valueBuilder, endBuilder]
- return $ (Attr (mconcat [buffer, builder]), uriMap)
+ then spaceBuilder `mappend` nsDeclStartBuilder `mappend` colonBuilder
+ `mappend` prefixBuilder `mappend` startBuilder `mappend` uriBuilder
+ `mappend` endBuilder `mappend` spaceBuilder `mappend` prefixBuilder
+ `mappend` colonBuilder `mappend` keyBuilder `mappend` startBuilder
+ `mappend` valueBuilder `mappend` endBuilder
+ else spaceBuilder `mappend` prefixBuilder `mappend` colonBuilder
+ `mappend` keyBuilder `mappend` startBuilder
+ `mappend` valueBuilder `mappend` endBuilder
+ return $ (Attr (buffer `mappend` builder), uriMap)
where
spaceBuilder = fromString " "
keyBuilder = fromString key
startBuilder = fromString "=\""
- valueBuilder = fromString (escape value)
endBuilder = fromString "\""
nsDeclStartBuilder = fromString "xmlns"
colonBuilder = fromString ":"
@@ -208,7 +257,7 @@ instance AddChildren c => MkElem Namespace c where
class MkEmptyElem n where
type MkEmptyElemRes n
- xelemEmpty ::n -> MkEmptyElemRes n
+ xelemEmpty :: n -> MkEmptyElemRes n
instance MkEmptyElem String where
type MkEmptyElemRes String = Xml Elem
@@ -225,17 +274,17 @@ xelemQ ns' name children = Xml $ \(Elem buffer) ->
let elemNameBuilder =
case ns of
DefaultNamespace -> fromString name
- (QualifiedNamespace p u) -> mconcat [fromString p, fromString ":", fromString name]
+ (QualifiedNamespace p u) -> fromString p `mappend` fromString ":" `mappend` fromString name
let nsDeclBuilder = case ns of
DefaultNamespace -> mempty
(QualifiedNamespace p u) ->
- let nsDeclaration' = mconcat [fromString " xmlns:", fromString p, fromString "=\""
- ,fromString u, fromString "\""]
+ let nsDeclaration' = fromString " xmlns:" `mappend` fromString p `mappend` fromString "=\""
+ `mappend` fromString u `mappend` fromString "\""
in if newNs then nsDeclaration' else mempty
let b1 = mappend buffer $ fromString "<"
- let b2 = mconcat [b1, elemNameBuilder, nsDeclBuilder]
+ let b2 = b1 `mappend` elemNameBuilder `mappend` nsDeclBuilder
let b3 = addChildren children b2 uriMap
- let builderOut = Elem (mconcat [b3, fromString "</", elemNameBuilder, fromString "\n>"])
+ let builderOut = Elem (b3 `mappend` fromString "</" `mappend` elemNameBuilder `mappend` fromString "\n>")
return (builderOut, oldUriMap)
xelems :: [Xml Elem] -> Xml Elem
@@ -244,6 +293,9 @@ xelems = foldl mappend noElems
noElems :: Xml Elem
noElems = xempty
+-- xelemWithText :: MkElem n (Xml Elem) => n -> String -> Xml Elem
+xelemWithText n t = xelem n (xtext t)
+
instance Monoid (Xml Elem) where
mempty = noElems
mappend x1 x2 = Xml $ \t ->
@@ -257,8 +309,12 @@ instance Monoid (Xml Elem) where
--
-- content is escaped
-xtext :: String -> Xml Elem
-xtext content = append $ fromString (escape content)
+xtext :: TextContent t => t -> Xml Elem
+xtext content = append $ textBuilder content
+
+-- content is NOT escaped
+xtextRaw :: RawTextContent t => t -> Xml Elem
+xtextRaw content = append $ rawTextBuilder content
-- no escaping performed
xentityRef :: String -> Xml Elem
@@ -356,13 +412,9 @@ append builder' = Xml $ \t ->
do nsEnv <- ask
return $ (mkRenderable (builder t <> builder'), nsEnv)
-escape :: String -> String
-escape s = escStr s ""
+genericEscape foldr showString' showChar x = foldr escChar (S.fromString "") x
where
- -- stolen from xml-light
- escStr :: String -> ShowS
- escStr cs rs = foldr escChar rs cs
- escChar :: Char -> ShowS
+ -- copied from xml-light
escChar c = case c of
'<' -> showString "&lt;"
'>' -> showString "&gt;"
@@ -375,8 +427,9 @@ escape s = escStr s ""
-- XXX: Is this really wortherd?
-- We could deal with these issues when we convert characters to bytes.
_ | (oc <= 0x7f && isPrint c) || c == '\n' || c == '\r' -> showChar c
- | otherwise -> showString "&#" . shows oc . showChar ';'
+ | otherwise -> showString "&#" . showString (show oc) . showChar ';'
where oc = ord c
+ showString = showString' . S.fromString
--
-- XHTML
@@ -1,10 +1,31 @@
-module Text.XML.Generator.Test where
+{-# OPTIONS_GHC -F -pgmF htfpp #-}
+module Text.XML.GeneratorTest where
+
+import System.Process
+import System.Posix.Temp
+import System.FilePath
+import System.IO
+import System.IO.Unsafe
+
+import Data.Char (ord, chr)
import qualified Data.ByteString.Lazy as BSL
+import qualified Data.ByteString.Lazy.Char8 as BSLC
+
+import Text.XML.HXT.Core hiding (xshow)
+import Text.XML.HXT.DOM.ShowXml (xshow)
+import Data.Tree.NTree.TypeDefs
+
+import Data.String.Utils
+import Data.String
+import qualified Data.Text as T
+
+import Test.Framework
+
import Text.XML.Generator
-test :: Renderable r => Xml r -> IO ()
-test = BSL.putStr . xrender
+test :: Renderable r => FilePath -> Xml r -> IO ()
+test f x = BSL.writeFile f (xrender x)
_NS_PR1_NS1_ = ns "foo" "urn:foo"
_NS_PR4_NS1_ = ns "___foo" "urn:foo"
@@ -15,15 +36,20 @@ _NS_PR1_NS3_ = ns "foo" "urn:bar"
testNS :: Namespace
testNS = ns "foo" "http://www.example.com"
-xsample :: Xml Elem
-xsample =
+xsample1 :: Xml Elem
+xsample1 =
xelem _NS_PR3_NS3_ "foo"
(xattr _NS_PR2_NS2_ "key" "value" <>
xattr _NS_PR2_NS2_ "key2" "value",
xelem _NS_PR1_NS1_ "bar" (xattr _NS_PR2_NS2_ "key" "value" <#> xtext "BAR") <>
xelem _NS_PR1_NS1_ "bar"
(xelem _NS_PR1_NS3_ "spam" (xelemEmpty "egg" <> xtext "this is spam!")))
+test_1 =
+ do out <- runXmllint xsample1
+ exp <- readExpected "1.xml"
+ assertEqual exp out
+
xsample2 :: Xml Elem
xsample2 = xelem "foo" $
xattr "key" "value" <>
@@ -35,6 +61,69 @@ xsample2 = xelem "foo" $
xelem testNS "spam" (xattr testNS "key" "value") <>
xelem testNS "egg" (xelemEmpty "ham")
+test_2 =
+ do out <- runXmllint xsample2
+ exp <- readExpected "2.xml"
+ assertEqual exp out
+
xsample3 :: Xml Doc
xsample3 =
doc defaultDocInfo $ xelem "foo" $ xattr "key" "val\"'&<>ue" <#> xtext "<&;'"
+
+test_3 =
+ do out <- runXmllint xsample2
+ exp <- readExpected "2.xml"
+ assertEqual exp out
+
+readExpected name = readFile ("test" </> name)
+
+runXmllint :: Renderable r => Xml r -> IO String
+runXmllint x =
+ do (name, handle) <- mkstemp "/tmp/xmlgen-test-XXXXXX"
+ BSL.hPut handle (xrender x)
+ hClose handle
+ readProcess "xmllint" ["--format", name] ""
+
+prop_textOk (ValidXmlString s) =
+ let docStr = xelem "root" (xattr "attr" s, xtext s)
+ docText = xelem "root" (xattr "attr" t, xtext t)
+ treeListStr = unsafePerformIO $ runX (readString [withWarnings no, withErrors no] (BSLC.unpack $ xrender docStr))
+ treeListText = unsafePerformIO $ runX (readString [withWarnings no, withErrors no] (BSLC.unpack $ xrender docText))
+ in treeListStr == treeListText
+ where
+ t = fromString s :: T.Text
+
+prop_quotingOk (ValidXmlString s) =
+ let doc = xelem "root" (xattr "attr" s, xtext s)
+ treeList = unsafePerformIO $ runX (readString [withWarnings no, withErrors no] (BSLC.unpack $ xrender doc))
+ root = head treeList
+ in case childrenOfNTree root of
+ [NTree root children] ->
+ let attrValue = case root of
+ XTag _ [NTree _ attrs] -> xshow attrs
+ XTag _ [NTree _ [NTree (XText attrValue) _]] -> attrValue
+ XTag _ [NTree _ []] -> ""
+ textValue = case children of
+ elems -> xshow elems
+ [NTree (XText textValue) _] -> textValue
+ [] -> ""
+ in normWsAttr s == attrValue && normWsElem s == textValue
+ l -> error (show root ++ "\n" ++ show l)
+ where
+ normWsAttr = replace "\r" " " . replace "\n" " " . replace "\n\r" " "
+ normWsElem = replace "\r" "\n" . replace "\n\r" "\b"
+ childrenOfNTree (NTree _ l) = l
+
+newtype ValidXmlString = ValidXmlString String
+ deriving (Eq, Show)
+
+instance Arbitrary ValidXmlString where
+ arbitrary = sized $ \n ->
+ do k <- choose (0, n)
+ s <- sequence [validXmlChar | _ <- [1..k] ]
+ return $ ValidXmlString s
+ where
+ validXmlChar =
+ let l = map chr ([0x9, 0xA, 0xD] ++ [0x20..0xD7FF] ++
+ [0xE000..0xFFFD] ++ [0x10000..0x10FFFF])
+ in elements l
Oops, something went wrong.

0 comments on commit 8861fd6

Please sign in to comment.