hexpat-pickle 0.2 → 0.3
raw patch · 8 files changed
+1250/−296 lines, 8 filesdep +containersdep +extensible-exceptionsdep ~hexpat
Dependencies added: containers, extensible-exceptions
Dependency ranges changed: hexpat
Files
- Text/XML/Expat/Pickle.hs +496/−259
- hexpat-pickle.cabal +20/−8
- test/example.hs +4/−8
- test/lazyUnpickle.hs +32/−0
- test/lazyUnpickleThrow.hs +33/−0
- test/test.hs +21/−21
- test/test.xml +2/−0
- test/tests.hs +642/−0
Text/XML/Expat/Pickle.hs view
@@ -1,111 +1,111 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances,- UndecidableInstances, FunctionalDependencies #-}+ UndecidableInstances, FunctionalDependencies, DeriveDataTypeable #-} --- | @hexpat-pickle@ provides XML picklers that plug into the parse tree of the--- @hexpat@ package, providing XML serialization with excellent performance.--- They are source code similar to those of the HXT package. The concept and--- design was lifted entirely from HXT.+-- | /hexpat-pickle/ provides XML picklers that plug into the parse tree of the+-- /hexpat/ package, giving XML serialization with excellent performance.+-- Picklers are source code similar to those of the /HXT/ package. The concept and+-- design was lifted entirely from /HXT/. ----- The API differences between @HXT@ and @hexpat-pickle@ are:+-- The API differences between /HXT/ and /hexpat-pickle/ are: -- -- * 'PU' and 'XmlPickler' take one extra argument, indicating the part of the -- XML tree we are working with. ----- * 'xpElem' takes three arguments to HXT's two, because we treat attributes--- and child nodes separately, while HXT groups them together.+-- * 'xpElem' takes three arguments to /HXT/'s two, because we treat attributes+-- and child nodes separately, while /HXT/ groups them together. ----- * HXT's list of pickler primitives is a little more complete.+-- * Two type adapters (absent in /HXT/), 'xpRoot' and 'xpContent' are needed in certain+-- places. See below. --+-- * These /HXT/ picklers are missing: @xpCondSeq@, @xpSeq@, @xpChoice@, @xpList1@+-- ('xpListMinLen' may be substituted), @xpElemWithAttrValue@+-- -- The data type @'PU' t a@ represents both a pickler (converting Haskell data -- to XML) and an unpickler (XML to Haskell data), so your code only needs to be -- written once for both serialization and deserialization. The 'PU' primitives, such -- as 'xpElem' for XML elements, may be composed into complex arrangements using -- 'xpPair' and other combinators. ----- The @t@ argument (absent in HXT) represents the part of the XML tree--- that this 'PU' works on. @t@ has /four/ possible values (assuming we are--- using the String type for our strings):+-- The @t@ argument (absent in /HXT/) represents the part of the XML tree+-- that this 'PU' works on. @t@ has /three/ possible values. These are the+-- most general types, and your picklers should not use any other types for @t@.+-- Here they are, assuming we are using the /String/ type for our strings: ----- * @'Element' t String String => 'PU' t a@ /(for working with an XML element)/+-- * @'PU' ('Nodes' String String) a@ /(for working with an XML element)/ ----- * @'PU' ['Node' String String] a@ /(for working with lists of elements)/+-- * @'PU' String a@ /(for working with text content)/ ----- * @'TextContent' t String => 'PU' t a@ /(for working with text content)/+-- * @'PU' ('Attributes' String String) a@ /(for working with attributes)/ ----- * @'PU' [(String, String)] a@ /(for working with attributes)/+-- The reason why you need 'Nodes' in the plural when working with a single+-- element is because the unpickler of 'xpElem' needs to see the whole list of nodes+-- so that it can 1. skip whitespace, and 2. search to match the specified tag name. ----- In the /list of elements/ and /attributes/ cases we use concrete types.--- However, 'Element' is implemented as a /type class/, because it behaves slightly--- differently in two situations: 1. The root node of a document, and 2. A child--- node (because in this situation it can search the list of nodes for a match).--- 'TextContent' is also a /type class/, because it behaves differently in--- 1. attribute values, and 2. text content of elements.+-- The top level of the document does not follow this rule, because it is a single+-- 'Node' type. 'xpRoot' is needed to adapt this to type 'Nodes' for your+-- pickler to use. You would typically define a pickler for a whole document with+-- 'xpElem', then pickle it to a single 'Node' with @'pickleTree' (xpRoot myDocPickler) value@. ----- @hexpat-pickle@ can work with the following string types:+-- The type for /text content/ works for attribute values directly, but if you want+-- to use it as the text content of an element, you need to adapt it by wrapping with+-- 'xpContent'. --+-- /hexpat-pickle/ can work with the following string types:+-- -- * String -- -- * Data.ByteString -- -- * Data.Text ----- and it is extensible to any other string type by 1. writing a @hexpat@ \"flavor\"--- for it, and making it an instance of 'GenericXMLString'. We select the type for--- XML /tag/ and /text/ separately in our four \"tree part\" types as follows:------ * @'Element' t /tag/ /text/ => 'PU' t a@+-- and it is extensible to any other string type by making it an instance of+-- 'GenericXMLString'. We select the type for XML /tag/ and /text/ separately+-- in our four \"tree part\" types as follows: ----- * @'PU' ['Node' /tag/ /text/] a@+-- * @'PU' (Nodes tag text) a@ /(for working with an XML element)/ ----- * @'TextContent' t /text/ => 'PU' t a@+-- * @'PU' text a@ /(for working with text content)/ ----- * @'PU' [(/tag/, /text/)]@+-- * @'PU' (Attributes tag text) a@ /(for working with attributes)/ -- -- /tag/ may be a string type, or it may be a QName type defined in -- the 'Text.XML.Expat.Qualified' module. (Or you can extend it any way you like.) ----- The type class 'XmlPickler' is used to extend a polymorphic 'xpickle' function--- to provide a pickler for a new type, in a similar way to 'Read' and 'Show'.+-- The /Text.XML.Expat.Tree/ and /Text.XML.Expat.Qualified/ provide the follow+-- useful shortcuts for common cases of 'Node', 'Nodes' and 'Attributes': ----- @hexpat-pickle@ abuses type classes to the extent that it requires a long--- list of GHC extensions. You will need most or all of these in your code:+-- * 'UNode', 'UNodes', 'UAttributes', 'QNode', 'QNodes', 'QAttributes'. ----- @--- {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,--- TypeSynonymInstances, UndecidableInstances #-}--- @+-- The type class 'XmlPickler' is used to extend a polymorphic 'xpickle' function+-- to provide a pickler for a new type, in a similar way to 'Read' and 'Show'. -- -- Here is a simple and complete example to get you started: ----- > {-# LANGUAGE FlexibleContexts #-}--- > --- > import Text.XML.Expat.Tree--- > import Text.XML.Expat.Pickle--- > import Text.XML.Expat.Format--- > import qualified Data.ByteString.Lazy as L--- > --- > -- Person name, age and description--- > data Person = Person String Int String--- > --- > xpPerson :: Element t String String => PU t Person--- > xpPerson =--- > -- How to wrap and unwrap a Person--- > xpWrap (\((name, age), descr) -> Person name age descr,--- > \(Person name age descr) -> ((name, age), descr)) $--- > xpElem "person"--- > (xpPair--- > (xpAttr "name" xpText0)--- > (xpAttr "age" xpickle))--- > xpText0--- > --- > people = [--- > Person "Dave" 27 "A fat thin man with long short hair",--- > Person "Jane" 21 "Lives in a white house with green windows"]--- > --- > main = do--- > L.putStrLn $--- > formatTree stringFlavor $--- > pickleTree (xpElemNodes "people" $ xpList xpPerson) people+-- > import Text.XML.Expat.Pickle+-- > import Text.XML.Expat.Tree+-- > import qualified Data.ByteString.Lazy as L+-- > +-- > -- Person name, age and description+-- > data Person = Person String Int String+-- > +-- > xpPerson :: PU (UNodes String) Person+-- > xpPerson =+-- > -- How to wrap and unwrap a Person+-- > xpWrap (\((name, age), descr) -> Person name age descr,+-- > \(Person name age descr) -> ((name, age), descr)) $+-- > xpElem "person"+-- > (xpPair+-- > (xpAttr "name" xpText0)+-- > (xpAttr "age" xpickle))+-- > (xpContent xpText0)+-- > +-- > people = [+-- > Person "Dave" 27 "A fat thin man with long short hair",+-- > Person "Jane" 21 "Lives in a white house with green windows"]+-- > +-- > main = do+-- > L.putStrLn $+-- > pickleXML (xpRoot $ xpElemNodes "people" $ xpList xpPerson) people -- -- Program output: --@@ -115,170 +115,205 @@ module Text.XML.Expat.Pickle ( -- * Primary interface- PU(PU),+ PU(..), Node(..), XmlPickler(..),- unpickleTree,- pickleTree,- -- * Classes for abstracting parts of the tree- Element(..),- TextContent(..),+ UnpickleException(..),+ unpickleXML,+ unpickleXML',+ pickleXML,+ pickleXML',+ -- * Re-exported types+ UNode,+ QNode,+ Nodes,+ UNodes,+ QNodes,+ Attributes,+ UAttributes,+ QAttributes,+ -- * Pickler adapters+ xpRoot,+ xpContent, -- * Pickler primitives xpUnit,+ xpZero,+ xpLift, xpElem, xpElemAttrs, xpElemNodes, xpAttr,+ xpAttrImplied,+ xpAttrFixed,+ xpAddFixedAttr, xpText0, xpText,- xpReadShow,+ xpPrim, -- * Pickler combinators xpPair, xpTriple, xp4Tuple, xp5Tuple, xp6Tuple,+ xpList0, xpList, xpListMinLen,+ xpMap, -- * Pickler type conversion xpWrap, xpWrapMaybe,+ xpWrapMaybe_, xpWrapEither, -- * Pickler conditionals xpOption,+ xpDefault,+ xpWithDefault, xpAlt, xpTryCatch, xpThrow,- xpWithDefault, -- * Pickler other- xpConst, xpAttrs, xpTree, xpTrees,- -- * Abstraction of string types- GenericXMLString(..)+ GenericXMLString(..) --re-exported ) where import Text.XML.Expat.IO (Encoding) import Text.XML.Expat.Tree import Text.XML.Expat.Format import Text.XML.Expat.Qualified+import Text.XML.Expat.Namespaced+import Control.Exception.Extensible import Data.Maybe import Data.Either import Data.List import Data.Char import Data.Monoid+import Data.Typeable import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.ByteString.Internal (c2w, w2c) import qualified Data.Text as T import qualified Codec.Binary.UTF8.String as U8+import qualified Data.Map as M -- | A two-way pickler/unpickler that pickles an arbitrary -- data type ''a'' to a part of an XML tree ''t''. -- A 'PU' can be composed using the pickler primitives defined in this module.+--+-- /unpickleTree/, /unpickleTree'/ and /pickleTree/ should be used directly by+-- the caller. data PU t a = PU {- -- | Convert a @t@ XML tree part into a Haskell value of type @a@, or give an+ -- | Lazily convert a @t@ XML tree part into a Haskell value of type @a@.+ -- In the event of an error, it throws 'UnpickleException'.+ unpickleTree :: t -> a,+ -- | strictly convert a @t@ XML tree part into a Haskell value of type @a@, or give an -- unpickling error message as @Left error@.- unpickleTree :: t -> Either String a,+ unpickleTree' :: t -> Either String a, -- | Convert a Haskell value of type @a@ to a @t@ XML tree part.- pickleTree :: a -> t+ pickleTree :: a -> t } -toByteString :: String -> B.ByteString-toByteString = B.pack . map (fromIntegral . ord)+-- | An exception indicating an error during unpickling, using by the lazy variants.+data UnpickleException = UnpickleException String+ deriving (Eq, Show, Typeable) --- | We build the attributes and tags lists backwards, then reverse them afterwards--- for speed.-reverseElement :: Node tag text -> Node tag text-reverseElement (Element eName eAttrs eChildren) = Element eName (reverse eAttrs) (reverse eChildren)-reverseElement other = other+instance Exception UnpickleException where --- | An abstraction for any string type you want to use as xml text (that is,--- attribute values or element text content). If you want to use a--- new string type with @hexpat-pickle@, you must make it an instance of--- 'GenericXMLString'.-class GenericXMLString s where- gxNullString :: s -> Bool- gxToString :: s -> String- gxFromString :: String -> s+-- | A helper that combines 'pickleTree' with 'formatXML' to pickle to an+-- XML document. Lazy variant returning lazy ByteString.+pickleXML :: (GenericXMLString tag, GenericXMLString text) =>+ PU (Node tag text) a+ -> a+ -> BL.ByteString +pickleXML pu value = formatTree $ pickleTree pu value -instance GenericXMLString String where- gxNullString = null- gxToString = id- gxFromString = id+-- | A helper that combines 'pickleTree' with 'formatXML' to pickle to an+-- XML document. Strict variant returning strict ByteString.+pickleXML' :: (GenericXMLString tag, GenericXMLString text) =>+ PU (Node tag text) a+ -> a+ -> B.ByteString +pickleXML' pu value = formatTree' $ pickleTree pu value -instance GenericXMLString B.ByteString where- gxNullString = B.null- gxToString = U8.decodeString . map w2c . B.unpack- gxFromString = B.pack . map c2w . U8.encodeString+-- | A helper that combines 'parseXML' with 'unpickleTree' to unpickle from an+-- XML document - lazy version. In the event of an error, it throws either+-- 'Text.XML.Expat.Tree.XMLParseException' or 'UnpickleException'.+unpickleXML :: (GenericXMLString tag, GenericXMLString text) =>+ Maybe Encoding+ -> PU (Node tag text) a+ -> BL.ByteString+ -> a+unpickleXML mEnc pu =+ unpickleTree pu . parseTreeThrowing mEnc -instance GenericXMLString T.Text where- gxNullString = T.null- gxToString = T.unpack- gxFromString = T.pack+-- | A helper that combines 'parseXML' with 'unpickleTree' to unpickle from an+-- XML document - strict version.+unpickleXML' :: (GenericXMLString tag, GenericXMLString text) =>+ Maybe Encoding+ -> PU (Node tag text) a+ -> B.ByteString+ -> Either String a+unpickleXML' mEnc pu xml =+ case parseTree' mEnc xml of+ Right tree -> unpickleTree' pu tree+ Left err -> Left $ show err --- | Define a generic pickler for converting a Haskell data of type @a@ to/from a+toByteString :: String -> B.ByteString+toByteString = B.pack . map (fromIntegral . ord)++-- | Define a generalized pickler for converting a Haskell data of type @a@ to/from a -- @t@ tree part, analogous to 'Read' / 'Show'. class XmlPickler t a where xpickle :: PU t a --- | Represents the two possible parts of an XML tree that can encode text--- content: 1. attribute values, and 2. text content of elements.-class (Monoid text, GenericXMLString text) => TextContent t text | t -> text where- getString :: t -> text- putString :: text -> t--instance TextContent String String where- getString = id- putString = id--instance TextContent B.ByteString B.ByteString where- getString = id- putString = id--instance TextContent T.Text T.Text where- getString = id- putString = id--instance (GenericXMLString text, Monoid text) => TextContent [Node tag text] text where- getString = mconcat . map extract- where- extract (Element _ _ children) = getString children- extract (Text txt) = txt- putString txt | gxNullString txt = []- putString txt = [Text txt]---- | Represents an XML element in a general way.-class Show t => Element t tag text | t -> tag, t -> text where- getElements :: t -> [Node tag text]- putElement :: Node tag text -> t--instance (Show tag, Show text) => Element [Node tag text] tag text where- getElements = id- putElement t = [t]+-- | Adapts a list of nodes to a single node. Generally used at the top level of+-- an XML document.+xpRoot ::PU (Nodes tag text) a -> PU (Node tag text) a+xpRoot pa = PU {+ unpickleTree = \t -> unpickleTree pa [t],+ unpickleTree' = \t -> unpickleTree' pa [t],+ pickleTree = \t -> case pickleTree pa t of+ [t1] -> t1+ _ -> error "pickler called by xpRoot must output only one element"+ } -instance (Show tag, Show text) => Element (Node tag text) tag text where- getElements elt@(Element _ _ _) = [elt]- getElements _ = error "No nodes to be found inside tag text"- putElement = id+-- | If you have a pickler that works with /text/, and you want to use it as+-- text content of an XML element, you need to wrap it with /xpContent/. See the+-- example at the top.+xpContent :: GenericXMLString text => PU text a -> PU (Nodes tag text) a+xpContent tp = PU {+ unpickleTree = \t -> unpickleTree tp $ mconcat $ map extract t,+ unpickleTree' = \t -> unpickleTree' tp $ mconcat $ map extract t,+ pickleTree = \t ->+ let txt = pickleTree tp t+ in if gxNullString txt then [] else [Text txt]+ }+ where+ extract (Element _ _ children) = mconcat $ map extract children+ extract (Text txt) = txt -- | Convert XML text content \<-\> String. Handles empty strings.-xpText0 :: TextContent t text => PU t text+xpText0 :: PU text text xpText0 = PU {- unpickleTree = Right . getString,- pickleTree = putString+ unpickleTree = id,+ unpickleTree' = Right,+ pickleTree = id } -- | Convert XML text content \<-\> String. Empty strings result in unpickle failure (Be warned!).-xpText :: TextContent t text => PU t text+xpText :: GenericXMLString text => PU text text xpText = PU { unpickleTree = \t ->- case getString t of- txt | gxNullString txt -> Left "empty text"- txt -> Right txt,- pickleTree = putString+ if gxNullString t+ then throw $ UnpickleException "empty text"+ else t,+ unpickleTree' = \t ->+ if gxNullString t+ then Left "empty text"+ else Right t,+ pickleTree = id } maybeRead :: Read a => String -> Maybe a@@ -286,92 +321,143 @@ [(x, "")] -> Just x _ -> Nothing -instance TextContent s text => XmlPickler s Int where- xpickle = xpReadShow+instance GenericXMLString text => XmlPickler text Int where+ xpickle = xpPrim -instance TextContent s text => XmlPickler s Integer where- xpickle = xpReadShow+instance GenericXMLString text => XmlPickler text Integer where+ xpickle = xpPrim -- | Convert XML text content \<-\> any type that implements 'Read' and 'Show'.-xpReadShow :: (TextContent s text, Read n, Show n) => PU s n-xpReadShow = PU {- unpickleTree = \t ->- let txt = gxToString $ getString t- in case maybeRead txt of- Just val -> Right val- Nothing -> Left $ "failed to read text: "++txt,- pickleTree = \n -> putString (gxFromString $ show n)- }+-- Fails on unpickle if 'read' fails.+xpPrim :: (Read n, Show n, GenericXMLString text) => PU text n+xpPrim = PU {+ unpickleTree = throwify doUnpickle,+ unpickleTree' = doUnpickle,+ pickleTree = \n -> gxFromString $ show n+ }+ where+ doUnpickle t =+ let txt = gxToString t+ in case maybeRead txt of+ Just val -> Right val+ Nothing -> Left $ "failed to read text: "++txt -instance (XmlPickler (Node tag text) a, Show tag, Show text) =>- XmlPickler [Node tag text] [a] where- xpickle = xpList xpickle+throwify :: (t -> Either String a) -> t -> a+{-# INLINE throwify #-}+throwify f t = case f t of+ Right val -> val+ Left err -> throw $ UnpickleException err +-- This is a roundabout way of converting a tag name into a String.+showUnquoted :: Show tag => tag -> String+showUnquoted tag = case (maybeRead tag') of+ Just str -> str+ Nothing -> tag'+ where+ tag' = show tag+ -- | Pickle @(a,b)@ to/from an XML element of the specified name, where @a@ -- is passed to a specified pickler for attributes and @b@ to a pickler for child nodes. -- Unpickle fails if an element of this name can't be found at this point in the tree. ----- This implementation differs from HXT in that it unpickles elements of different--- names in any order, while HXT's xpElem will fail if the XML order doesn't match+-- This implementation differs from /HXT/ in that it unpickles elements of different+-- names in any order, while /HXT/'s xpElem will fail if the XML order doesn't match -- the Haskell code. ----- It also differs from HXT in that it takes two pickler arguments, one for attributes--- and one for child nodes. When migrating from HXT, often you can substitute just--- 'xpElemAttrs' or 'xpElemNodes' for HXT's 'xpElem', but where your element has both+-- It also differs from /HXT/ in that it takes two pickler arguments, one for attributes+-- and one for child nodes. When migrating from /HXT/, often you can substitute just+-- 'xpElemAttrs' or 'xpElemNodes' for /HXT/'s 'xpElem', but where your element has both -- attributes and child nodes, you must split your data into a 2-tuple with 'xpWrap', -- and separate the child picklers accordingly.-xpElem :: (Eq tag, Show tag, Element t tag text) =>- tag -- ^ Element name- -> PU [(tag, text)] a -- ^ Pickler for attributes- -> PU [Node tag text] b -- ^ Pickler for child nodes: accepts @Element t tag text => 'PU' t a@- -> PU t (a,b)+xpElem :: (Eq tag, Show tag) =>+ tag -- ^ Element name+ -> PU [(tag, text)] a -- ^ Pickler for attributes+ -> PU (Nodes tag text) b -- ^ Pickler for child nodes+ -> PU (Nodes tag text) (a,b) xpElem name puAttrs puChildren = PU { unpickleTree = \t -> let doElem elt@(Element eName attrs children) | eName == name = Just $ (unpickleTree puAttrs attrs, unpickleTree puChildren children) doElem _ = Nothing- mChildren = map doElem (getElements t)+ mChildren = map doElem t in case catMaybes mChildren of- [] -> Left $ "can't find element <"++show name++">"+ [] -> throw $ UnpickleException $ "can't find <"++showUnquoted name++">"+ (result:_) -> result,+ unpickleTree' = \t ->+ let doElem elt@(Element eName attrs children) | eName == name =+ Just $ (unpickleTree' puAttrs attrs, unpickleTree' puChildren children)+ doElem _ = Nothing+ mChildren = map doElem t+ in case catMaybes mChildren of+ [] -> Left $ "can't find <"++showUnquoted name++">" (result:_) -> case result of (Right attrs, Right children) -> Right (attrs, children)- (Left err, _) -> Left $ "in attributes of <"++show name++">, "++err- (_, Left err) -> Left $ "in <"++show name++">, "++err,+ (Left err, _) -> Left $ "in <"++showUnquoted name++">, "++err+ (_, Left err) -> Left $ "in <"++showUnquoted name++">, "++err, pickleTree = \(a,b) ->- putElement $ Element name (pickleTree puAttrs a) (pickleTree puChildren b)+ [Element name (pickleTree puAttrs a) (pickleTree puChildren b)] } -- | A helper variant of xpElem for elements that contain attributes but no child tags.-xpElemAttrs :: (Eq tag, Show tag, Element t tag text) =>+xpElemAttrs :: (Eq tag, Show tag) => tag -- ^ Element name- -> PU [(tag, text)] a -- ^ Pickler for attributes- -> PU t a+ -> PU (Attributes tag text) a -- ^ Pickler for attributes+ -> PU (Nodes tag text) a xpElemAttrs name puAttrs = xpWrap (fst,\a -> (a,())) $ xpElem name puAttrs xpUnit -- | A helper variant of xpElem for elements that contain child nodes but no attributes.-xpElemNodes :: (Eq tag, Show tag, Element t tag text) =>- tag -- ^ Element name- -> PU [Node tag text] a -- ^ Pickler for child nodes: accepts @Element t tag text => 'PU' t a@- -> PU t a+xpElemNodes :: (Eq tag, Show tag) =>+ tag -- ^ Element name+ -> PU (Nodes tag text) a -- ^ Pickler for child nodes+ -> PU (Nodes tag text) a xpElemNodes name puChildren = xpWrap (snd,\a -> ((),a)) $ xpElem name xpUnit puChildren -- | Create/parse an XML attribute of the specified name. Fails if the attribute -- can't be found at this point in the tree.-xpAttr :: (Eq tag, Show tag) => tag -> PU text a -> PU [(tag,text)] a+xpAttr :: (Eq tag, Show tag) => tag -> PU text a -> PU (Attributes tag text) a xpAttr name pu = PU {- unpickleTree = \attrs ->- let doAttr attr@(aName, value) | aName == name =- case unpickleTree pu value of- Right val -> Just val- Left _ -> Nothing- doAttr _ = Nothing- mAttrs = map doAttr attrs- in case catMaybes mAttrs of- val:_ -> Right val- [] -> Left $ "can't find attribute '"++show name++"'",+ unpickleTree = throwify doUnpickle, -- We don't care if attribute value+ -- is handled strictly+ unpickleTree' = doUnpickle, pickleTree = \value -> [(name, pickleTree pu value)] }+ where+ doUnpickle attrs =+ let doAttr attr@(aName, value) | aName == name = Just $ unpickleTree' pu value+ doAttr _ = Nothing+ mAttrs = map doAttr attrs+ in case catMaybes mAttrs of+ eVal:_ -> case eVal of+ Right _ -> eVal+ Left err -> Left $ "in attribute "++showUnquoted name++", "++err+ [] -> Left $ "can't find attribute "++showUnquoted name +-- | Optionally add an attribute, unwrapping a Maybe value.+xpAttrImplied :: (Eq tag, Show tag) => tag -> PU text a -> PU (Attributes tag text) (Maybe a)+xpAttrImplied name pa = xpOption $ xpAttr name pa++-- | Pickle an attribute with the specified name and value, fail if the same attribute is+-- not present on unpickle.+xpAttrFixed :: (Eq tag, Show tag, GenericXMLString text) => tag -> text -> PU (Attributes tag text) ()+xpAttrFixed name val =+ xpWrapMaybe_ ("expected fixed attribute "++showUnquoted name++"="++show (gxToString val))+ (\v -> if v == val then Just () else Nothing, const val) $+ xpAttr name xpText++-- | Add an attribute with a fixed value.+--+-- Useful e.g. to declare namespaces. Is implemented by 'xpAttrFixed'+xpAddFixedAttr :: (Eq tag, Show tag, GenericXMLString text) =>+ tag+ -> text+ -> PU (Attributes tag text) a+ -> PU (Attributes tag text) a+xpAddFixedAttr name val pa+ = xpWrap ( snd+ , (,) ()+ ) $+ xpPair (xpAttrFixed name val) pa+ -- | Convert XML text \<-\> a Maybe type. During unpickling, Nothing is returned -- if there's a failure during the unpickling of the first argument. A typical -- example is:@@ -380,23 +466,50 @@ -- -- in which @Just 5@ would be encoded as @\<score value=\"5\"\/\>@ and @Nothing@ would be -- encoded as @\<score\/\>@.+--+-- Note on lazy unpickle: The argument is evaluated strictly. xpOption :: PU [t] a -> PU [t] (Maybe a) xpOption pu = PU {- unpickleTree = \t ->- case unpickleTree pu t of- Right val -> Right (Just val)- Left _ -> Right Nothing,+ unpickleTree = doUnpickle,+ unpickleTree' = Right . doUnpickle, pickleTree = \mValue -> case mValue of Just value -> pickleTree pu value Nothing -> [] }+ where+ doUnpickle t =+ case unpickleTree' pu t of+ Right val -> (Just val)+ Left _ -> Nothing +-- | Optional conversion with default value+--+-- Unlike 'xpWithDefault' the default value is not encoded in the XML document,+-- during unpickling the default value is inserted if the pickler fails+--+-- Note on lazy unpickle: The child is evaluated strictly.+xpDefault :: (Eq a) => a -> PU [t] a -> PU [t] a+xpDefault df+ = xpWrap ( fromMaybe df+ , \ x -> if x == df then Nothing else Just x+ ) .+ xpOption++-- | Attempt to use a pickler. On failure, return a default value.+--+-- Unlike 'xpDefault', the default value /is/ encoded in the XML document.+--+-- Note on lazy unpickle: The child is evaluated strictly.+xpWithDefault :: a -> PU [t] a -> PU [t] a+xpWithDefault a pa = xpTryCatch pa (xpLift a)+ -- | Convert XML text \<-\> a 2-tuple using the two arguments. xpPair :: PU [t] a -> PU [t] b -> PU [t] (a,b) xpPair pua pub = PU {- unpickleTree = \t ->- case (unpickleTree pua t, unpickleTree pub t) of+ unpickleTree = \t -> (unpickleTree pua t, unpickleTree pub t),+ unpickleTree' = \t ->+ case (unpickleTree' pua t, unpickleTree' pub t) of (Right a, Right b) -> Right (a,b) (Left err, _) -> Left $ "in 1st of pair, "++err (_, Left err) -> Left $ "in 2nd of pair, "++err,@@ -408,8 +521,9 @@ -- | Convert XML text \<-\> a 3-tuple using the three arguments. xpTriple :: PU [t] a -> PU [t] b -> PU [t] c -> PU [t] (a,b,c) xpTriple pua pub puc = PU {- unpickleTree = \t ->- case (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t) of+ unpickleTree = \t -> (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t),+ unpickleTree' = \t ->+ case (unpickleTree' pua t, unpickleTree' pub t, unpickleTree' puc t) of (Right a, Right b, Right c) -> Right (a,b,c) (Left err, _, _) -> Left $ "in 1st of triple, "++err (_, Left err, _) -> Left $ "in 2nd of triple, "++err@@ -423,9 +537,11 @@ -- | Convert XML text \<-\> a 4-tuple using the four arguments. xp4Tuple :: PU [t] a -> PU [t] b -> PU [t] c -> PU [t] d -> PU [t] (a,b,c,d) xp4Tuple pua pub puc pud = PU {- unpickleTree = \t ->- case (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t,- unpickleTree pud t) of+ unpickleTree = \t -> (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t,+ unpickleTree pud t),+ unpickleTree' = \t ->+ case (unpickleTree' pua t, unpickleTree' pub t, unpickleTree' puc t,+ unpickleTree' pud t) of (Right a, Right b, Right c, Right d) -> Right (a,b,c,d) (Left err, _, _, _) -> Left $ "in 1st of 4-tuple, "++err (_, Left err, _, _) -> Left $ "in 2nd of 4-tuple, "++err@@ -441,9 +557,11 @@ -- | Convert XML text \<-\> a 5-tuple using the five arguments. xp5Tuple :: PU [t] a -> PU [t] b -> PU [t] c -> PU [t] d -> PU [t] e -> PU [t] (a,b,c,d,e) xp5Tuple pua pub puc pud pue = PU {- unpickleTree = \t ->- case (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t,- unpickleTree pud t, unpickleTree pue t) of+ unpickleTree = \t -> (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t,+ unpickleTree pud t, unpickleTree pue t),+ unpickleTree' = \t ->+ case (unpickleTree' pua t, unpickleTree' pub t, unpickleTree' puc t,+ unpickleTree' pud t, unpickleTree' pue t) of (Right a, Right b, Right c, Right d, Right e) -> Right (a,b,c,d,e) (Left err, _, _, _, _) -> Left $ "in 1st of 5-tuple, "++err (_, Left err, _, _, _) -> Left $ "in 2nd of 5-tuple, "++err@@ -461,9 +579,11 @@ -- | Convert XML text \<-\> a 6-tuple using the six arguments. xp6Tuple :: PU [t] a -> PU [t] b -> PU [t] c -> PU [t] d -> PU [t] e -> PU [t] f -> PU [t] (a,b,c,d,e,f) xp6Tuple pua pub puc pud pue puf = PU {- unpickleTree = \t ->- case (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t,- unpickleTree pud t, unpickleTree pue t, unpickleTree puf t) of+ unpickleTree = \t -> (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t,+ unpickleTree pud t, unpickleTree pue t, unpickleTree puf t),+ unpickleTree' = \t ->+ case (unpickleTree' pua t, unpickleTree' pub t, unpickleTree' puc t,+ unpickleTree' pud t, unpickleTree' pue t, unpickleTree' puf t) of (Right a, Right b, Right c, Right d, Right e, Right f) -> Right (a,b,c,d,e,f) (Left err, _, _, _, _, _) -> Left $ "in 1st of 6-tuple, "++err (_, Left err, _, _, _, _) -> Left $ "in 2nd of 6-tuple, "++err@@ -480,28 +600,87 @@ pickleTree puf f } +instance (XmlPickler [Node tag text] a, Show tag) =>+ XmlPickler [Node tag text] [a] where+ xpickle = xpList xpickle+ -- | Convert XML text \<-\> a list of elements. During unpickling, failure of the -- argument unpickler is the end-of-list condition (and it isn't a failure).-xpList :: (Show tag, Show text) => PU (Node tag text) a -> PU [Node tag text] [a]+--+-- Note on lazy unpickle: Because we're using a failure to pickle a child as+-- the end condition it means we're only lazy at the top-level xpList. Children+-- of xpList are evaluated strictly. Use 'xpList0' to fix this.+xpList :: Show tag => PU (Nodes tag text) a -> PU (Nodes tag text) [a] xpList pu = PU {+ unpickleTree = doUnpickle,+ unpickleTree' = Right . doUnpickle, + pickleTree = \t -> mconcat $ map (pickleTree pu) t+ }+ where+ doUnpickle [] = []+ doUnpickle (elt@(Element _ _ _):rem) =+ case unpickleTree' pu [elt] of+ Right val -> val:doUnpickle rem+ Left _ -> []+ doUnpickle (_:rem) = doUnpickle rem -- ignore text nodes++-- | Convert XML text \<-\> a list of elements. Unlike 'xpList', this function+-- uses /no more elements/ as the end of list condition, which means it can+-- evaluate its children lazily.+--+-- Any error in a child will cause an error to be reported.+xpList0 :: Show tag => PU (Nodes tag text) a -> PU (Nodes tag text) [a]+xpList0 pu = PU { unpickleTree = \nodes -> let munge [] = [] munge (elt@(Element _ _ _):rem) =- case unpickleTree pu elt of- Right val -> val:munge rem- Left _ -> []+ unpickleTree pu [elt]:munge rem munge (_:rem) = munge rem -- ignore text nodes- in Right $ munge nodes,- pickleTree = map (pickleTree pu)+ in munge nodes,+ unpickleTree' = \nodes ->+ let munge [] = []+ munge (elt@(Element _ _ _):rem) =+ case unpickleTree' pu [elt] of+ Right val -> Right val:munge rem+ Left err -> [Left $ "in list, "++err]+ munge (_:rem) = munge rem -- ignore text nodes+ m = munge nodes+ in case m of+ [] -> Right []+ otherwise ->+ case last m of+ Left err -> Left err+ Right _ -> Right $ rights m,+ pickleTree = \t -> mconcat $ map (pickleTree pu) t } --- | Like xpList, but only succeed during deserialization it at least a minimum number of elements are unpickled.-xpListMinLen :: (Show tag, Show text) => Int -> PU (Node tag text) a -> PU [Node tag text] [a]+-- | Like xpList, but only succeed during deserialization if at least a minimum number of elements are unpickled.+xpListMinLen :: Show tag => Int -> PU (Nodes tag text) a -> PU (Nodes tag text) [a] xpListMinLen ml = xpWrapEither (testLength, id) . xpList where testLength as | length as < ml = Left $ "Expecting at least " ++ show ml ++ " elements" testLength as = Right as +-- | Standard pickler for maps+--+-- This pickler converts a map into a list of pairs of the form+--+-- > <elt attr="key">value</elt>+xpMap :: (Eq tag, Show tag, Ord k) =>+ tag -- ^ Element name (elt) + -> tag -- ^ Attribute name (attr)+ -> PU text k -- ^ Pickler for keys (key)+ -> PU (Nodes tag text) v -- ^ Pickler for values (value)+ -> PU (Nodes tag text) (M.Map k v)+xpMap en an xpk xpv+ = xpWrap ( M.fromList+ , M.toList+ ) $+ xpList $+ xpElem en+ (xpAttr an xpk)+ xpv+ -- | Apply a lens to convert the type of your data structure to/from types that -- the pickler primitives can handle, with the /unpickle/ case first. -- Mostly this means the tuples used by 'xpPair' and friends. A typical example is:@@ -510,7 +689,8 @@ -- > \(Person name address) -> (name, address)) $ ... xpWrap :: (a -> b, b -> a) -> PU t a -> PU t b xpWrap (a2b, b2a) pua = PU {- unpickleTree = \t -> case unpickleTree pua t of+ unpickleTree = \t -> a2b $ unpickleTree pua t,+ unpickleTree' = \t -> case unpickleTree' pua t of Right val -> Right (a2b val) Left err -> Left err, pickleTree = \value -> pickleTree pua (b2a value)@@ -518,12 +698,21 @@ -- | Like xpWrap, but strips Just (and treats Nothing as a failure) during unpickling. xpWrapMaybe :: (a -> Maybe b, b -> a) -> PU t a -> PU t b-xpWrapMaybe (a2b, b2a) pua = PU {- unpickleTree = \t -> case unpickleTree pua t of+xpWrapMaybe = xpWrapMaybe_ "xpWrapMaybe can't encode Nothing value"++-- | Like xpWrap, but strips Just (and treats Nothing as a failure) during unpickling,+-- with specified error message for Nothing value.+xpWrapMaybe_ :: String -> (a -> Maybe b, b -> a) -> PU t a -> PU t b+xpWrapMaybe_ errorMsg (a2b, b2a) pua = PU {+ unpickleTree = \t ->+ case a2b $ unpickleTree pua t of+ Just val' -> val'+ Nothing -> throw $ UnpickleException errorMsg,+ unpickleTree' = \t -> case unpickleTree' pua t of Right val -> case a2b val of Just val' -> Right val'- Nothing -> Left "xpWrapMaybe can't encode Nothing value"+ Nothing -> Left errorMsg Left err -> Left err, pickleTree = \value -> pickleTree pua (b2a value) }@@ -531,7 +720,10 @@ -- | Like xpWrap, except it strips Right (and treats Left as a failure) during unpickling. xpWrapEither :: (a -> Either String b, b -> a) -> PU t a -> PU t b xpWrapEither (a2b, b2a) pua = PU {- unpickleTree = \t -> case unpickleTree pua t of+ unpickleTree = \t -> case a2b $ unpickleTree pua t of+ Right val -> val+ Left err -> throw $ UnpickleException $ "xpWrapEither failed: "++err,+ unpickleTree' = \t -> case unpickleTree' pua t of Right val -> a2b val Left err -> Left $ "xpWrapEither failed: "++err, pickleTree = \value -> pickleTree pua (b2a value)@@ -544,75 +736,120 @@ -- -- This is typically used to handle each constructor of a data type. However, it -- can be used wherever multiple serialization strategies apply to a single type.+--+-- Note on lazy unpickle: Because we're using a failure to pickle a child as+-- the end condition it means children of xpAlt are evaluated strictly. xpAlt :: (a -> Int) -- ^ selector function -> [PU t a] -- ^ list of picklers -> PU t a xpAlt selector picklers = PU {- unpickleTree = \t ->- let tryAll [] = Left "all xpAlt unpickles failed"- tryAll (x:xs) =- case unpickleTree x t of- Right val -> Right val- Left err -> tryAll xs- in tryAll picklers,+ unpickleTree = throwify doUnpickle,+ unpickleTree' = doUnpickle, pickleTree = \value -> pickleTree (picklers !! (selector value)) value }+ where+ doUnpickle t =+ let tryAll [] = Left "all xpAlt unpickles failed"+ tryAll (x:xs) =+ case unpickleTree' x t of+ Right val -> Right val+ Left err -> tryAll xs+ in tryAll picklers -- | Convert nothing \<-\> (). Does not output or consume any XML text. xpUnit :: PU [t] ()-xpUnit = xpConst ()+xpUnit = xpLift () -- | Convert nothing \<-\> constant value. Does not output or consume any XML text.-xpConst :: a -> PU [t] a-xpConst a = PU- { unpickleTree = const $ Right a+xpLift :: a -> PU [t] a+xpLift a = PU+ { unpickleTree = const a+ , unpickleTree' = const $ Right a , pickleTree = const [] } +-- | Lift a Maybe value to a pickler.+--+-- @Nothing@ is mapped to the zero pickler, @Just x@ is pickled with @xpLift x@.+xpLiftMaybe :: Maybe a -> PU [t] a+xpLiftMaybe Nothing = xpZero+xpLiftMaybe (Just x) = xpLift x+ -- | Pickler that during pickling always uses the first pickler, and during -- unpickling tries the first, and on failure then tries the second.+--+-- Note on lazy unpickle: The first argument is evaluated strictly. xpTryCatch :: PU t a -> PU t a -> PU t a xpTryCatch pu1 pu2 = PU- { unpickleTree = \t -> case unpickleTree pu1 t of+ { unpickleTree = \t -> case unpickleTree' pu1 t of+ Right val1 -> val1+ Left err1 -> unpickleTree pu2 t+ , unpickleTree' = \t -> case unpickleTree' pu1 t of Right val1 -> Right val1- Left err1 -> case unpickleTree pu2 t of+ Left err1 -> case unpickleTree' pu2 t of Right val2 -> Right val2 Left err2 -> Left $ "Both xpTryCatch picklers failed: <" ++ err1 ++ "> <" ++ err2 ++ ">" , pickleTree = pickleTree pu1 } +-- | The zero pickler+--+-- Encodes nothing, fails always during unpickling. (Same as @'xpThrow' \"got xpZero\"@).+xpZero :: PU [t] a+xpZero = xpThrow "got xpZero"+ -- | No output when pickling, always generates an error with the specified message on unpickling. xpThrow :: String -- ^ Error message -> PU [t] a xpThrow msg = PU- { unpickleTree = \t -> Left msg+ { unpickleTree = \t -> throw $ UnpickleException $ msg+ , unpickleTree' = \t -> Left msg , pickleTree = const [] } --- | Attempt to use a pickler. On failure, return a default value.-xpWithDefault :: a -> PU [t] a -> PU [t] a-xpWithDefault a pa = xpTryCatch pa (xpConst a)- -- | Insert/extract an attribute list literally in the xml stream. xpAttrs :: PU [(tag, text)] [(tag, text)] xpAttrs = PU {- unpickleTree = Right,+ unpickleTree = id,+ unpickleTree' = Right, pickleTree = id } -- | Insert/extract a tree node literally in the xml stream.-xpTree :: Element t tag text => PU t (Node tag text)+xpTree :: PU (Nodes tag text) (Node tag text) xpTree = PU {- unpickleTree = \t -> case getElements t of+ unpickleTree = \t -> case t of+ [elt] -> elt+ otherwise -> throw $ UnpickleException $ "xpTree expects a single node",+ unpickleTree' = \t -> case t of [elt] -> Right elt- otherwise -> Left "xpLiteral expects a single node",- pickleTree = putElement+ otherwise -> Left "xpTree expects a single node",+ pickleTree = \x -> [x] } -- | Insert/extract a list of tree nodes literally in the xml stream. xpTrees :: PU [Node tag text] [Node tag text] xpTrees = PU {- unpickleTree = Right,+ unpickleTree = id,+ unpickleTree' = Right, pickleTree = id }++{-+-- | Insert a namespace binding, along with other attributes.+xpNamespaceBinding :: (GenericXMLString text)+ => [(text, text)] -> PU (NAttributes text) a -> PU (NAttributes text) a+xpNamespaceBinding ups pa =+ xpWrap (\(nsb, a) -> a, \a -> (nsb, a)) $ xpPair xpAttrs pa+ where+ nsb = map (\(uri, prefix) -> (mkNName xmlnsUri prefix, uri)) ups++-- | Insert a default namespace binding, along with other attributes.+xpDefaultNamespace :: (GenericXMLString text)+ => text -> PU (NAttributes text) a -> PU (NAttributes text) a+xpDefaultNamespace uri pa =+ xpWrap (\(nsb, a) -> a, \a -> (nsb, a)) $ xpPair xpAttrs pa+ where+ nsb = [(mkAnNName xmlns, uri)]+-}
hexpat-pickle.cabal view
@@ -1,16 +1,16 @@ Cabal-Version: >= 1.2 Name: hexpat-pickle-Version: 0.2+Version: 0.3 Synopsis: XML picklers based on hexpat, source-code-similar to those of the HXT package Description: A library of combinators that allows Haskell data structures to be pickled (serialized) to/from XML via the Tree datatype defined in the hexpat package. It is source-code-similar to the pickling functionality of the HXT package, to ease the transition between the two libraries. This implementation is- faster but less complete than HXT. This package does not depend on HXT.+ faster but less complete than HXT. Unlike some other picklers, it also supports+ /lazy unpickling/. .- Note that hexpat-pickle is still under development, so it is fairly likely- that there will be some API changes coming.+ This package does not depend on HXT. . DARCS repository: <http://code.haskell.org/hexpat-pickle/>@@ -23,12 +23,24 @@ (c) 2009 Stephen Blackheath <http://blacksapphire.com/antispam/>, (c) 2009 Matthew Pocock <matthew.pocock@ncl.ac.uk> Homepage: http://code.haskell.org/hexpat-pickle/-Extra-Source-Files: test/test.hs, test/example.hs+Extra-Source-Files:+ test/tests.hs,+ test/test.hs,+ test/test.xml,+ test/example.hs,+ test/lazyUnpickle.hs,+ test/lazyUnpickleThrow.hs Build-Type: Simple-Stability: alpha+Stability: beta Library- Build-Depends: base, hexpat >= 0.4, utf8-string >= 0.3.3, bytestring >= 0.9,- text >= 0.1+ Build-Depends:+ base,+ hexpat >= 0.5,+ utf8-string >= 0.3.3,+ bytestring >= 0.9,+ text >= 0.1,+ containers,+ extensible-exceptions >= 0.1 && < 0.2 Exposed-Modules: Text.XML.Expat.Pickle
test/example.hs view
@@ -1,14 +1,11 @@-{-# LANGUAGE FlexibleContexts #-}--import Text.XML.Expat.Tree import Text.XML.Expat.Pickle-import Text.XML.Expat.Format+import Text.XML.Expat.Tree import qualified Data.ByteString.Lazy as L -- Person name, age and description data Person = Person String Int String -xpPerson :: Element t String String => PU t Person+xpPerson :: PU (UNodes String) Person xpPerson = -- How to wrap and unwrap a Person xpWrap (\((name, age), descr) -> Person name age descr,@@ -17,7 +14,7 @@ (xpPair (xpAttr "name" xpText0) (xpAttr "age" xpickle))- xpText0+ (xpContent xpText0) people = [ Person "Dave" 27 "A fat thin man with long short hair",@@ -25,6 +22,5 @@ main = do L.putStrLn $- formatTree stringFlavor $- pickleTree (xpElemNodes "people" $ xpList xpPerson) people+ pickleXML (xpRoot $ xpElemNodes "people" $ xpList xpPerson) people
+ test/lazyUnpickle.hs view
@@ -0,0 +1,32 @@+module Main where++import Text.XML.Expat.Tree+import Text.XML.Expat.Pickle+import qualified Data.ByteString as B+import Data.ByteString.Internal (c2w, w2c)+import qualified Data.ByteString.Lazy as L+import Control.Monad++infiniteDoc = "<?xml version=\"1.0\"?><infinite>"++body 1+ where+ body i = "\n <item idx=\"" ++ show i ++ "\"/>"++body (i+1)++toBL :: String -> L.ByteString+toBL = L.fromChunks . chunkify+ where+ chunkify [] = []+ chunkify str =+ let (start, rem) = splitAt 1024 str+ in (B.pack $ map c2w start):chunkify rem++infiniteBL = toBL infiniteDoc++xpItems :: PU (UNodes String) [Int]+xpItems =+ xpElemNodes "infinite" $ xpList0 $ xpElemAttrs "item" $ xpAttr "idx" xpickle++-- This test passes if it doesn't leak memory.++main = do+ print $ unpickleXML Nothing (xpRoot xpItems) infiniteBL+
+ test/lazyUnpickleThrow.hs view
@@ -0,0 +1,33 @@+module Main where++import Text.XML.Expat.Tree+import Text.XML.Expat.Pickle+import qualified Data.ByteString as B+import Data.ByteString.Internal (c2w, w2c)+import qualified Data.ByteString.Lazy as L+import Control.Monad++infiniteDoc = "<?xml version=\"1.0\"?><infinite>"++body 1+ where+ body i = "\n <item idx=\"" ++ show i ++ "\"/>"++body (i+1)++toBL :: String -> L.ByteString+toBL = L.fromChunks . chunkify+ where+ chunkify [] = []+ chunkify str =+ let (start, rem) = splitAt 1024 str+ in (B.pack $ map c2w start):chunkify rem++infiniteBL = toBL infiniteDoc++xpItems :: PU (UNodes String) [Int]+xpItems =+ xpElemNodes "infinite" $ xpList0 $ xpElemAttrs "item" $+ xpAttr "idx" $+ xpWrapEither (\i -> if i == 5000 then Left "5000 is evil" else Right i, id) $+ xpickle++main = do+ print $ unpickleXML Nothing (xpRoot xpItems) infiniteBL+
test/test.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} import Text.XML.Expat.Tree import Text.XML.Expat.Pickle@@ -38,7 +38,7 @@ } deriving (Eq, Show) -instance LanguageKey k => XmlPickler (Node String String) (MultiText k) where+instance LanguageKey k => XmlPickler (UNodes String) (MultiText k) where xpickle = xpMultiText "text" data SiteLanguageKey = SiteLanguageKey String@@ -56,7 +56,7 @@ [(x, "")] -> Just x _ -> Nothing -xpMultiText :: LanguageKey k => String -> PU (Node String String) (MultiText k)+xpMultiText :: LanguageKey k => String -> PU (UNodes String) (MultiText k) xpMultiText tagName = xpWrap ( (\((lan, tex1, tim), tex2) -> MultiText@@ -70,7 +70,7 @@ (xpAttr "lang" xpText0) (xpOption $ xpAttr "text" xpText0) (xpOption $ xpAttr "time" xpText0))- xpText0+ (xpContent xpText0) data LanguageKey k => MultiLanguage k = MultiLanguage { texts :: [MultiText k]@@ -80,10 +80,10 @@ nullMultiLanguage :: LanguageKey k => MultiLanguage k nullMultiLanguage = MultiLanguage [] -instance XmlPickler [Node String String] (MultiLanguage SiteLanguageKey) where+instance XmlPickler (UNodes String) (MultiLanguage SiteLanguageKey) where xpickle = xpMultiLanguage "text" -xpMultiLanguage :: LanguageKey k => String -> PU [Node String String] (MultiLanguage k)+xpMultiLanguage :: LanguageKey k => String -> PU (UNodes String) (MultiLanguage k) xpMultiLanguage childTagName = xpWrap ( (\ts -> MultiLanguage ts),@@ -100,10 +100,10 @@ } deriving (Show) -instance XmlPickler (Node String String) Mnemonic where+instance XmlPickler (UNodes String) Mnemonic where xpickle = xpMnemonic -xpMnemonic :: PU (Node String String) Mnemonic+xpMnemonic :: PU (UNodes String) Mnemonic xpMnemonic = xpWrap ( (\((mne, cat, com, lin), tex) ->@@ -123,15 +123,14 @@ main_tree doc = do start <- getCurrentTime- let mTree = parseTree' stringFlavor Nothing doc- case mTree of- Right tree -> do- let pickler = xpElemNodes "mnemonics" $ xpList xpMnemonic- let eMnems = unpickleTree pickler tree- case eMnems of- Right mnems -> do- let pickled = pickleTree pickler mnems- xml = mconcat . L.toChunks $ formatTree stringFlavor pickled `mappend` L.pack (map c2w "\n")+ let pickler = xpRoot $ xpElemNodes "mnemonics" $ xpList xpMnemonic+ case unpickleXML' Nothing pickler doc of+ Right mnems -> do+ let xml = mconcat . L.toChunks $ pickleXML pickler mnems `mappend` L.pack (map c2w "\n")+ if xml == doc+ then do+ let mnems = unpickleXML Nothing pickler $ L.fromChunks [doc]+ xml = mconcat . L.toChunks $ pickleXML pickler mnems `mappend` L.pack (map c2w "\n") if xml == doc then do end <- getCurrentTime@@ -139,12 +138,13 @@ hPutStrLn stderr $ "passed" hPutStrLn stderr $ "took "++showFFloat (Just 3) (realToFrac took) ""++" sec" else do- hPutStrLn stderr $ "Failed - mismatch:"+ hPutStrLn stderr $ "Failed test 2 - mismatch:" B.putStr xml- Left error -> do- hPutStrLn stderr $ "FAILED: "++error+ else do+ hPutStrLn stderr $ "Failed test 1 - mismatch:"+ B.putStr xml Left error -> do- hPutStrLn stderr $ "FAILED: "++show error+ hPutStrLn stderr $ "FAILED: "++error main = do xml <- B.readFile "test.xml"
+ test/test.xml view
@@ -0,0 +1,2 @@+<?xml version="1.0" encoding="UTF-8"?>+<mnemonics><mnemonic name="geo.BD" category="geo"><text lang="" time="0">Gana Prajatantri Bangladesh</text><text lang="scn" time="0">Bangladesci</text><text lang="gd" time="0">Bangladesh</text><text lang="ga" time="0">An Bhanglaidéis</text><text lang="gl" time="0">Bangladesh - বাংলাদেশ</text><text lang="la" time="0">Bangladesia</text><text lang="lo" time="0">ບັງກະລາເທດ</text><text lang="tr" time="0">Bangladeş</text><text lang="li" time="0">Bangladesj</text><text lang="lv" time="0">Bangladeša</text><text lang="lt" time="0">Bangladešas</text><text lang="th" time="0">บังคลาเทศ</text><text lang="tg" time="0">Бангладеш</text><text lang="te" time="0">బంగ్లాదేశ్</text><text lang="ta" time="0">பங்களாதேஷ்</text><text lang="de" time="0">Bangladesch</text><text lang="da" time="0">Bangladesh</text><text lang="dz" time="0">བངྒ་ལ་དེཤ</text><text lang="qu" time="0">Bangladesh</text><text lang="kn" time="0">ಬಾಂಗ್ಲಾದೇಶ</text><text lang="bpy" time="0">বাংলাদেশ</text><text lang="el" time="0">Μπανγκλαντές</text><text lang="eo" time="0">Bangladeŝo</text><text lang="en" time="0">Bangladesh</text><text lang="zh" time="0">孟加拉国</text><text lang="eu" time="0">Bangladesh</text><text lang="et" time="0">Bangladesh</text><text lang="es" time="0">Bangladesh</text><text lang="ru" time="0">Бангладеш</text><text lang="ro" time="0">Bangladesh</text><text lang="be" time="0">Бангладэш</text><text lang="bg" time="0">Бангладеш</text><text lang="ms" time="0">Bangladesh</text><text lang="ast" time="0">Bangladesh</text><text lang="bn" time="0">Gonaoprojatontri Bangladesh</text><text lang="bs" time="0">Bangladeš</text><text lang="ja" time="0">バングラデシュ</text><text lang="oc" time="0">Bangladèsh</text><text lang="nds" time="0">Bangladesch</text><text lang="os" time="0">Бангладеш</text><text lang="ca" time="0">Bangla Desh</text><text lang="cy" time="0">Bangladesh</text><text lang="cs" time="0">Bangladéš</text><text lang="ps" time="0">بنګلهدیش</text><text lang="pt" time="0">Bangladesh</text><text lang="tl" time="0">Bangladesh</text><text lang="pl" time="0">Bangladesz</text><text lang="hy" time="0">Բանգլադեշ</text><text lang="hr" time="0">Bangladeš</text><text lang="ht" time="0">Bangladèch</text><text lang="hu" time="0">Banglades</text><text lang="hi" time="0">बंगलादेश</text><text lang="he" time="0">בנגלאדש</text><text lang="fur" time="0">Bangladesh</text><text lang="ml" time="0">ബംഗ്ലാദേശ്</text><text lang="mk" time="0">Бангладеш</text><text lang="ur" time="0">بنگلہ دیش</text><text lang="mt" time="0">Bangladexx</text><text lang="uk" time="0">Бангладеш</text><text lang="mr" time="0">बांगलादेश</text><text lang="ug" time="0">بېنگلا</text><text lang="af" time="0">Bangladesj</text><text lang="vi" time="0">Bangladesh</text><text lang="is" time="0">Bangladess</text><text lang="am" time="0">ባንግላዲሽ</text><text lang="it" time="0">Bangladesh</text><text lang="an" time="0">Bangladesh</text><text lang="ar" time="0">بنغلاديش</text><text lang="io" time="0">Bangladesh</text><text lang="ia" time="0">Bangladesh</text><text lang="id" time="0">Bangladesh</text><text lang="ks" time="0">बंगलादेश</text><text lang="nl" time="0">Bangladesh</text><text lang="nn" time="0">Bangladesh</text><text lang="no" time="0">Bangladesh</text><text lang="na" time="0">Bangladesh</text><text lang="nb" time="0">Bangladesh</text><text lang="so" time="0">Bangaala-Deesh</text><text lang="pam" time="0">Bangladesh</text><text lang="fr" time="0">Bangladesh</text><text lang="fy" time="0">Banglades</text><text lang="fa" time="0">بنگلادش</text><text lang="fi" time="0">Bangladesh</text><text lang="fo" time="0">Bangladesj</text><text lang="ka" time="0">ბანგლადეში</text><text lang="sr" time="0">Бангладеш</text><text lang="sq" time="0">Bangladeshi</text><text lang="ko" time="0">방글라데시</text><text lang="sv" time="0">Bangladesh</text><text lang="km" time="0">បង់ក្លាដេស្ហ</text><text lang="sk" time="0">Bangladéš</text><text lang="sh" time="0">Bangladeš</text><text lang="kw" time="0">Bangladesh</text><text lang="ku" time="0">Bangladeş</text><text lang="sl" time="0">Bangladeš</text><text lang="se" time="0">Bangladesh</text></mnemonic><mnemonic name="geo.BE" category="geo"><text lang="" time="0">Belgien</text><text lang="gv" time="0">Yn Velg</text><text lang="zea" time="0">België</text><text lang="scn" time="0">Belgiu</text><text lang="ga" time="0">An Bheilg</text><text lang="gl" time="0">Bélxica - België</text><text lang="nov" time="0">Belgia</text><text lang="lb" time="0">Belsch</text><text lang="la" time="0">Belgia</text><text lang="ln" time="0">Bɛ́ljika</text><text lang="lo" time="0">ເບວຢຽມ</text><text lang="tr" time="0">Belçika</text><text lang="li" time="0">Belsj</text><text lang="lv" time="0">Beļģija</text><text lang="tl" time="0">Belhika</text><text lang="th" time="0">เบลเยียม</text><text lang="tg" time="0">Белгия</text><text lang="ta" time="0">பெல்ஜியம்</text><text lang="de" time="0">Belgien</text><text lang="da" time="0">Belgien</text><text lang="dz" time="0">བེལ་ཇིཡམ</text><text lang="bar" time="0">Belgien</text><text lang="vls" time="0">Belgje</text><text lang="qu" time="0">Bilgasuyu</text><text lang="gd" time="0">A' Bheilg</text><text lang="el" time="0">Βέλγιο</text><text lang="eo" time="0">Belgujo</text><text lang="en" time="0">Belgium</text><text lang="zh" time="0">比利时</text><text lang="pms" time="0">Belgio</text><text lang="arc" time="0">ܒܠܓܝܟܐ</text><text lang="eu" time="0">Belgika</text><text lang="et" time="0">Belgia</text><text lang="tet" time="0">Béljika</text><text lang="es" time="0">Bélgica</text><text lang="ru" time="0">Бельгия</text><text lang="rm" time="0">Belgia</text><text lang="ro" time="0">Belgia</text><text lang="bn" time="0">বেল্জিয়ম</text><text lang="hsb" time="0">Belgiska</text><text lang="be" time="0">Бэльгія</text><text lang="bg" time="0">Белгия</text><text lang="uk" time="0">Бельгія</text><text lang="wa" time="0">Beldjike</text><text lang="ast" time="0">Bélxica</text><text lang="jv" time="0">Belgia</text><text lang="bo" time="0">པེར་ཅིན</text><text lang="br" time="0">Belgia</text><text lang="bs" time="0">Belgija</text><text lang="ja" time="0">ベルギー</text><text lang="ilo" time="0">Belgium</text><text lang="oc" time="0">Belgica</text><text lang="nds" time="0">Belgien</text><text lang="os" time="0">Бельги</text><text lang="ca" time="0">Bèlgica</text><text lang="cy" time="0">Gwlad Belg</text><text lang="cs" time="0">Belgie</text><text lang="cv" time="0">Бельги</text><text lang="ps" time="0">بلجيم</text><text lang="pt" time="0">Bélgica</text><text lang="lt" time="0">Belgija</text><text lang="frp" time="0">Bèlg·ique</text><text lang="vi" time="0">Bỉ</text><text lang="war" time="0">Belhika</text><text lang="pl" time="0">Belgia</text><text lang="hy" time="0">Բելգիա</text><text lang="nrm" time="0">Belgique</text><text lang="hr" time="0">Belgija</text><text lang="ht" time="0">Bèljik</text><text lang="hu" time="0">Belgium</text><text lang="hi" time="0">बेल्जियम</text><text lang="he" time="0">בלגיה</text><text lang="fur" time="0">Belgjo</text><text lang="mk" time="0">Белгија</text><text lang="mt" time="0">Belġju</text><text lang="ms" time="0">Belgium</text><text lang="mr" time="0">बेल्जियम</text><text lang="ang" time="0">Belgium</text><text lang="af" time="0">België</text><text lang="ko" time="0">벨기에</text><text lang="is" time="0">Belgía</text><text lang="am" time="0">ቤልጄም</text><text lang="it" time="0">Belgio</text><text lang="an" time="0">Belchica</text><text lang="ar" time="0">بلجيكا</text><text lang="km" time="0">បែលហ្ស៉ិក</text><text lang="io" time="0">Belgia</text><text lang="ia" time="0">Belgica</text><text lang="id" time="0">Belgia</text><text lang="nl" time="0">Koninkrijk België</text><text lang="nn" time="0">Belgia</text><text lang="no" time="0">Belgia</text><text lang="na" time="0">Belgium</text><text lang="nb" time="0">Belgia</text><text lang="ne" time="0">बेल्जियम</text><text lang="so" time="0">Beljiyam</text><text lang="pam" time="0">Belgium</text><text lang="fr" time="0">Belgique</text><text lang="fy" time="0">Belgje</text><text lang="fa" time="0">بلژیک</text><text lang="fi" time="0">Belgia</text><text lang="fo" time="0">Belgia</text><text lang="ka" time="0">ბელგია</text><text lang="sr" time="0">Белгија</text><text lang="sq" time="0">Belgjikë</text><text lang="sw" time="0">Ubelgiji</text><text lang="sv" time="0">Belgien</text><text lang="tpi" time="0">Belsum</text><text lang="sk" time="0">Belgicko</text><text lang="sh" time="0">Belgija</text><text lang="kw" time="0">Pow Belg</text><text lang="ku" time="0">Belçîka</text><text lang="sl" time="0">Belgija</text><text lang="jbo" time="0">gugdrbelgi</text><text lang="sa" time="0">बेल्जियम</text><text lang="se" time="0">Belgia</text></mnemonic></mnemonics>
+ test/tests.hs view
@@ -0,0 +1,642 @@+import Test.HUnit hiding (Node)+import Text.XML.Expat.Pickle+import Text.XML.Expat.Tree+import Text.XML.Expat.Format+import Control.Exception.Extensible as E+import Control.Parallel.Strategies+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B+import Data.ByteString.Internal (c2w)+import qualified Data.Map as M+import Control.Arrow++-- | Tests where input and XML output differ+u2 :: (NFData a, Eq a, Show a) => String -> String -> String -> Either String a -> PU (UNodes String) a -> IO ()+u2 title inXML chkXML inEVal inPU = do+ let inTree = parseTreeThrowing (Just UTF8) (L.pack $ map c2w inXML)+ inTreeXML = formatTree' inTree+ eVal = unpickleTree' (xpRoot inPU) inTree+ assertEqual (title++" - strict unpickle") inEVal eVal+ case eVal of+ Right val -> do+ -- Make sure that the lazy unpickler gives the same result+ assertEqual (title++" - lazy unpickle") val (unpickleTree (xpRoot inPU) inTree)+ let chkTree = parseTreeThrowing (Just UTF8) (L.pack $ map c2w chkXML) :: UNode String+ chkTreeXML = formatTree' chkTree+ outXML = pickleXML' (xpRoot inPU) val+ assertEqual (title++" - pickle") chkTreeXML outXML+ Left err ->+ -- Make sure that the lazy unpickler also fails, but we don't care+ -- what the message is (it won't be the same)+ E.catch (do+ let val2 = unpickleTree (xpRoot inPU) inTree+ rnf val2 `seq`+ assertFailure $ title++" - lazy unpickle didn't throw expected exception ("++err++")"+ ) (\exc -> return (exc::SomeException) >> return ())++-- | Tests where input and output XML are the same+u title inXML inEVal inPU = u2 title inXML inXML inEVal inPU++main = runTestTT $ TestList $ map TestCase $ [+ u "xpUnit"+ "<top/>" (Right ()) $ xpElemNodes "top" xpUnit,++ u "xpUnit"+ "<top/>"+ (Left "in <top>, got xpZero" :: Either String ()) $+ xpElemNodes "top" xpZero,++ u "xpLift"+ "<top/>" (Right "banana") $ xpElemNodes "top" $ xpLift "banana",++ u "xpElem"+ "<top><fruit>apple</fruit><pet>cat</pet></top>"+ (Right ("apple","cat")) $+ xpElemNodes "top" $+ xpPair+ (xpElemNodes "fruit" $ xpContent xpText) + (xpElemNodes "pet" $ xpContent xpText),++ u2 "xpElem - with elements out of order"+ "<top><fruit>apple</fruit><pet>cat</pet></top>"+ "<top><pet>cat</pet><fruit>apple</fruit></top>"+ (Right ("cat","apple")) $+ xpElemNodes "top" $+ xpPair+ (xpElemNodes "pet" $ xpContent xpText) + (xpElemNodes "fruit" $ xpContent xpText),++ u2 "xpElem - Check ignoring of extra elements"+ "<top><vegetable>onion</vegetable><fruit>apple</fruit><furniture>chair</furniture><pet>cat</pet></top>"+ "<top><fruit>apple</fruit><pet>cat</pet></top>"+ (Right ("apple","cat")) $+ xpElemNodes "top" $+ xpPair+ (xpElemNodes "fruit" $ xpContent xpText) + (xpElemNodes "pet" $ xpContent xpText),++ u2 "xpElem - Check ignoring of extra text"+ "<top>Onion<fruit>apple</fruit><furniture>chair</furniture>Chair<pet>cat</pet></top>"+ "<top><fruit>apple</fruit><pet>cat</pet></top>"+ (Right ("apple","cat")) $+ xpElemNodes "top" $+ xpPair+ (xpElemNodes "fruit" $ xpContent xpText) + (xpElemNodes "pet" $ xpContent xpText),++ u "xpElem - check missing element"+ "<top><fruit>apple</fruit></top>"+ (Left "in <top>, in 2nd of pair, can't find <pet>") $+ xpElemNodes "top" $+ xpPair+ (xpElemNodes "fruit" $ xpContent xpText) + (xpElemNodes "pet" $ xpContent xpText),++ u "xpAttr"+ "<top fruit=\"apple\" pet=\"cat\"/>"+ (Right ("apple", "cat")) $+ xpElemAttrs "top" $+ xpPair+ (xpAttr "fruit" xpText0)+ (xpAttr "pet" xpText),++ u2 "xpAttr - Attributes out of order"+ "<top pet=\"cat\" fruit=\"apple\"/>"+ "<top fruit=\"apple\" pet=\"cat\"/>"+ (Right ("apple", "cat")) $+ xpElemAttrs "top" $+ xpPair+ (xpAttr "fruit" xpText0)+ (xpAttr "pet" xpText),++ u2 "xpAttr - Ignore extra attributes"+ "<top pet=\"cat\" furniture=\"chair\" fruit=\"apple\"/>"+ "<top fruit=\"apple\" pet=\"cat\"/>"+ (Right ("apple", "cat")) $+ xpElemAttrs "top" $+ xpPair+ (xpAttr "fruit" xpText0)+ (xpAttr "pet" xpText),++ u "xpAttr - Missing attribute"+ "<top pet=\"cat\"/>"+ (Left "in <top>, in 1st of pair, can't find attribute fruit") $+ xpElemAttrs "top" $+ xpPair+ (xpAttr "fruit" xpText0)+ (xpAttr "pet" xpText),+ + u "xpAttrImplied - Nothing value"+ "<top/>"+ (Right Nothing) $+ xpElemAttrs "top" $+ xpAttrImplied "missing" xpText0,++ u "xpAttrImplied - Just value"+ "<top missing=\"not missing\"/>"+ (Right $ Just "not missing") $+ xpElemAttrs "top" $+ xpAttrImplied "missing" xpText0,++ u "xpAttrFixed"+ "<top fixed=\"horse\"/>"+ (Right ()) $+ xpElemAttrs "top" $+ xpAttrFixed "fixed" "horse",++ u "xpAttrFixed - missing attribute on unpickle"+ "<top/>"+ (Left "in <top>, can't find attribute fixed") $+ xpElemAttrs "top" $+ xpAttrFixed "fixed" "horse",+ + u "xpAddFixedAttr"+ "<top fixed=\"horse\" unfixed=\"sheep\"/>"+ (Right "sheep") $+ xpElemAttrs "top" $+ xpAddFixedAttr "fixed" "horse" $+ xpAttr "unfixed" xpText0,++ u "xpContent xpText0"+ "<top>Shoe</top>"+ (Right "Shoe") $+ xpElemNodes "top" $ xpContent $ xpText0,++ u "xpAttr .. xpText0"+ "<top clothes=\"Shoe\"/>"+ (Right "Shoe") $+ xpElemAttrs "top" $ xpAttr "clothes" xpText0,++ u "xpContent xpText0 - empty string"+ "<top/>"+ (Right "") $+ xpElemNodes "top" $ xpContent $ xpText0,++ u "xpAttr .. xpText0 - empty string"+ "<top clothes=\"\"/>"+ (Right "") $+ xpElemAttrs "top" $ xpAttr "clothes" xpText0,++ u "xpContent xpText"+ "<top>Shoe</top>"+ (Right "Shoe") $+ xpElemNodes "top" $ xpContent $ xpText,++ u "xpAttr .. xpText"+ "<top clothes=\"Shoe\"/>"+ (Right "Shoe") $+ xpElemAttrs "top" $ xpAttr "clothes" xpText,++ u "xpContent xpText - empty string"+ "<top/>"+ (Left "in <top>, empty text") $+ xpElemNodes "top" $ xpContent $ xpText,++ u "xpAttr .. xpText - empty string"+ "<top clothes=\"\"/>"+ (Left "in <top>, in attribute clothes, empty text") $+ xpElemAttrs "top" $ xpAttr "clothes" xpText,++ u "xpPrim"+ "<top>1234</top>"+ (Right 1234 :: Either String Int) $+ xpElemNodes "top" $ xpContent $ xpPrim,++ u "xpPrim"+ "<top>1234!</top>"+ (Left "in <top>, failed to read text: 1234!" :: Either String Int) $+ xpElemNodes "top" $ xpContent $ xpPrim,+ + u "xpPair"+ "<top><a>1</a><b>2</b></top>"+ (Right (1,2) :: Either String (Int,Int)) $+ xpElemNodes "top" $ xpPair+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpContent xpPrim),++ u "xpPair - failure in 1st"+ "<top><a>1</a><b>2</b></top>"+ (Left "in <top>, in 1st of pair, in <a>, got xpZero" :: Either String (Int,Int)) $+ xpElemNodes "top" $ xpPair+ (xpElemNodes "a" $ xpZero)+ (xpElemNodes "b" $ xpContent xpPrim),++ u "xpPair - failure in 2nd"+ "<top><a>1</a><b>2</b></top>"+ (Left "in <top>, in 2nd of pair, in <b>, got xpZero" :: Either String (Int,Int)) $+ xpElemNodes "top" $ xpPair+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpZero),++ u "xpTriple"+ "<top><a>1</a><b>2</b><c>3</c></top>"+ (Right (1,2,3) :: Either String (Int,Int,Int)) $+ xpElemNodes "top" $ xpTriple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpContent xpPrim),++ u "xpTriple - failure in 1st"+ "<top><a>1</a><b>2</b><c>3</c></top>"+ (Left "in <top>, in 1st of triple, in <a>, got xpZero" :: Either String (Int,Int,Int)) $+ xpElemNodes "top" $ xpTriple+ (xpElemNodes "a" $ xpZero)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpContent xpPrim),++ u "xpTriple - failure in 2nd"+ "<top><a>1</a><b>2</b><c>3</c></top>"+ (Left "in <top>, in 2nd of triple, in <b>, got xpZero" :: Either String (Int,Int,Int)) $+ xpElemNodes "top" $ xpTriple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpZero)+ (xpElemNodes "c" $ xpContent xpPrim),++ u "xpTriple - failure in 3rd"+ "<top><a>1</a><b>2</b><c>3</c></top>"+ (Left "in <top>, in 3rd of triple, in <c>, got xpZero" :: Either String (Int,Int,Int)) $+ xpElemNodes "top" $ xpTriple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpZero),++ u "xp4Tuple"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d></top>"+ (Right (1,2,3,4) :: Either String (Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp4Tuple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpContent xpPrim)+ (xpElemNodes "d" $ xpContent xpPrim),++ u "xp4Tuple - failure in 1st"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d></top>"+ (Left "in <top>, in 1st of 4-tuple, in <a>, got xpZero" :: Either String (Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp4Tuple+ (xpElemNodes "a" $ xpZero)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpContent xpPrim)+ (xpElemNodes "d" $ xpContent xpPrim),++ u "xp4Tuple - failure in 2nd"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d></top>"+ (Left "in <top>, in 2nd of 4-tuple, in <b>, got xpZero" :: Either String (Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp4Tuple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpZero)+ (xpElemNodes "c" $ xpContent xpPrim)+ (xpElemNodes "d" $ xpContent xpPrim),++ u "xp4Tuple - failure in 3rd"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d></top>"+ (Left "in <top>, in 3rd of 4-tuple, in <c>, got xpZero" :: Either String (Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp4Tuple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpZero)+ (xpElemNodes "d" $ xpContent xpPrim),++ u "xp4Tuple - failure in 4th"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d></top>"+ (Left "in <top>, in 4th of 4-tuple, in <d>, got xpZero" :: Either String (Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp4Tuple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpContent xpPrim)+ (xpElemNodes "d" $ xpZero),++ u "xp5Tuple"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d><e>5</e></top>"+ (Right (1,2,3,4,5) :: Either String (Int,Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp5Tuple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpContent xpPrim)+ (xpElemNodes "d" $ xpContent xpPrim)+ (xpElemNodes "e" $ xpContent xpPrim),++ u "xp5Tuple - failure in 1st"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d><e>5</e></top>"+ (Left "in <top>, in 1st of 5-tuple, in <a>, got xpZero" :: Either String (Int,Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp5Tuple+ (xpElemNodes "a" $ xpZero)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpContent xpPrim)+ (xpElemNodes "d" $ xpContent xpPrim)+ (xpElemNodes "e" $ xpContent xpPrim),++ u "xp5Tuple - failure in 2nd"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d><e>5</e></top>"+ (Left "in <top>, in 2nd of 5-tuple, in <b>, got xpZero" :: Either String (Int,Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp5Tuple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpZero)+ (xpElemNodes "c" $ xpContent xpPrim)+ (xpElemNodes "d" $ xpContent xpPrim)+ (xpElemNodes "e" $ xpContent xpPrim),++ u "xp5Tuple - failure in 3rd"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d><e>5</e></top>"+ (Left "in <top>, in 3rd of 5-tuple, in <c>, got xpZero" :: Either String (Int,Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp5Tuple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpZero)+ (xpElemNodes "d" $ xpContent xpPrim)+ (xpElemNodes "e" $ xpContent xpPrim),++ u "xp5Tuple - failure in 4th"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d><e>5</e></top>"+ (Left "in <top>, in 4th of 5-tuple, in <d>, got xpZero" :: Either String (Int,Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp5Tuple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpContent xpPrim)+ (xpElemNodes "d" $ xpZero)+ (xpElemNodes "e" $ xpContent xpPrim),++ u "xp5Tuple - failure in 5th"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d><e>5</e></top>"+ (Left "in <top>, in 5th of 5-tuple, in <e>, got xpZero" :: Either String (Int,Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp5Tuple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpContent xpPrim)+ (xpElemNodes "d" $ xpContent xpPrim)+ (xpElemNodes "e" $ xpZero),++ u "xp6Tuple"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d><e>5</e><f>6</f></top>"+ (Right (1,2,3,4,5,6) :: Either String (Int,Int,Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp6Tuple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpContent xpPrim)+ (xpElemNodes "d" $ xpContent xpPrim)+ (xpElemNodes "e" $ xpContent xpPrim)+ (xpElemNodes "f" $ xpContent xpPrim),++ u "xp6Tuple - failure in 1st"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d><e>5</e><f>6</f></top>"+ (Left "in <top>, in 1st of 6-tuple, in <a>, got xpZero" :: Either String (Int,Int,Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp6Tuple+ (xpElemNodes "a" $ xpZero)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpContent xpPrim)+ (xpElemNodes "d" $ xpContent xpPrim)+ (xpElemNodes "e" $ xpContent xpPrim)+ (xpElemNodes "f" $ xpContent xpPrim),++ u "xp6Tuple - failure in 2nd"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d><e>5</e><f>6</f></top>"+ (Left "in <top>, in 2nd of 6-tuple, in <b>, got xpZero" :: Either String (Int,Int,Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp6Tuple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpZero)+ (xpElemNodes "c" $ xpContent xpPrim)+ (xpElemNodes "d" $ xpContent xpPrim)+ (xpElemNodes "e" $ xpContent xpPrim)+ (xpElemNodes "f" $ xpContent xpPrim),++ u "xp6Tuple - failure in 3rd"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d><e>5</e><f>6</f></top>"+ (Left "in <top>, in 3rd of 6-tuple, in <c>, got xpZero" :: Either String (Int,Int,Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp6Tuple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpZero)+ (xpElemNodes "d" $ xpContent xpPrim)+ (xpElemNodes "e" $ xpContent xpPrim)+ (xpElemNodes "f" $ xpContent xpPrim),++ u "xp6Tuple - failure in 4th"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d><e>5</e><f>6</f></top>"+ (Left "in <top>, in 4th of 6-tuple, in <d>, got xpZero" :: Either String (Int,Int,Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp6Tuple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpContent xpPrim)+ (xpElemNodes "d" $ xpZero)+ (xpElemNodes "e" $ xpContent xpPrim)+ (xpElemNodes "f" $ xpContent xpPrim),++ u "xp6Tuple - failure in 5th"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d><e>5</e><f>6</f></top>"+ (Left "in <top>, in 5th of 6-tuple, in <e>, got xpZero" :: Either String (Int,Int,Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp6Tuple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpContent xpPrim)+ (xpElemNodes "d" $ xpContent xpPrim)+ (xpElemNodes "e" $ xpZero)+ (xpElemNodes "f" $ xpContent xpPrim),++ u "xp6Tuple - failure in 6th"+ "<top><a>1</a><b>2</b><c>3</c><d>4</d><e>5</e><f>6</f></top>"+ (Left "in <top>, in 6th of 6-tuple, in <f>, got xpZero" :: Either String (Int,Int,Int,Int,Int,Int)) $+ xpElemNodes "top" $ xp6Tuple+ (xpElemNodes "a" $ xpContent xpPrim)+ (xpElemNodes "b" $ xpContent xpPrim)+ (xpElemNodes "c" $ xpContent xpPrim)+ (xpElemNodes "d" $ xpContent xpPrim)+ (xpElemNodes "e" $ xpContent xpPrim)+ (xpElemNodes "f" $ xpZero),++ u "xpList0"+ "<top><name>Matthew</name><name>Stephen</name></top>"+ (Right ["Matthew", "Stephen"]) $+ xpElemNodes "top" $ xpList0 $ xpElemNodes "name" $ xpContent xpText0,++ u "xpList0 with failure in element"+ "<top><name>Matthew</name><kiwifruit>Stephen</kiwifruit></top>"+ (Left "in <top>, in list, can't find <name>") $+ xpElemNodes "top" $ xpList0 $ xpElemNodes "name" $ xpContent xpText0,++ u "xpList0 with empty list"+ "<top/>"+ (Right []) $+ xpElemNodes "top" $ xpList0 $ xpElemNodes "name" $ xpContent xpText0,++ u "xpList"+ "<top><name>Matthew</name><name>Stephen</name></top>"+ (Right ["Matthew", "Stephen"]) $+ xpElemNodes "top" $ xpList $ xpElemNodes "name" $ xpContent xpText0,++ u2 "xpList with failure in element"+ "<top><name>Matthew</name><kiwifruit>Stephen</kiwifruit></top>"+ "<top><name>Matthew</name></top>"+ (Right ["Matthew"]) $+ xpElemNodes "top" $ xpList $ xpElemNodes "name" $ xpContent xpText0,++ u "xpList with empty list"+ "<top/>"+ (Right []) $+ xpElemNodes "top" $ xpList $ xpElemNodes "name" $ xpContent xpText0,++ u "xpListMinLength (len 2)"+ "<top><name>Matthew</name><name>Stephen</name></top>"+ (Right ["Matthew", "Stephen"]) $+ xpElemNodes "top" $ xpListMinLen 1 $ xpElemNodes "name" $ xpContent xpText0,++ u "xpListMinLength (len 1)"+ "<top><name>Matthew</name></top>"+ (Right ["Matthew"]) $+ xpElemNodes "top" $ xpListMinLen 1 $ xpElemNodes "name" $ xpContent xpText0,++ u "xpListMinLength (len 0)"+ "<top/>"+ (Left "in <top>, Expecting at least 1 elements") $+ xpElemNodes "top" $ xpListMinLen 1 $ xpElemNodes "name" $ xpContent xpText0,++ u2 "xpListMinLength error in 2nd elt"+ "<top><name>Matthew</name><orange>Stephen</orange></top>"+ "<top><name>Matthew</name></top>"+ (Right ["Matthew"]) $+ xpElemNodes "top" $ xpListMinLen 1 $ xpElemNodes "name" $ xpContent xpText0,++ u "xpListMinLength error in 1st elt"+ "<top><apricot>Matthew</apricot><orange>Stephen</orange></top>"+ (Left "in <top>, Expecting at least 1 elements") $+ xpElemNodes "top" $ xpListMinLen 1 $ xpElemNodes "name" $ xpContent xpText0,++ u2 "xpMap"+ "<top><animal name=\"dog\">4</animal><animal name=\"spider\">8</animal><animal name=\"fish\">0</animal></top>"+ "<top><animal name=\"dog\">4</animal><animal name=\"fish\">0</animal><animal name=\"spider\">8</animal></top>"+ (Right $ M.fromList [("dog",4),("spider",8),("fish",0)] :: Either String (M.Map String Int)) $+ xpElemNodes "top" $ xpMap "animal" "name" xpText0 (xpContent xpickle),++ u "xpMap - empty"+ "<top/>"+ (Right $ M.empty :: Either String (M.Map String Int)) $+ xpElemNodes "top" $ xpMap "animal" "name" xpText0 (xpContent xpickle),++ u2 "xpMap - error in elt"+ "<top><animal name=\"dog\">4</animal><plant name=\"spider plant\">378</plant><animal name=\"fish\">0</animal></top>"+ "<top><animal name=\"dog\">4</animal></top>"+ (Right $ M.fromList [("dog",4)] :: Either String (M.Map String Int)) $+ xpElemNodes "top" $ xpMap "animal" "name" xpText0 (xpContent xpickle),++ u "xpWrap"+ "<top><animal name=\"dog\">4</animal><animal name=\"spider\">8</animal><animal name=\"fish\">0</animal></top>"+ (Right [("_dog",400),("_spider",800),("_fish",0)] :: Either String [(String,Int)]) $+ xpElemNodes "top" $ xpList $+ xpWrap (('_':) *** (*100), tail *** (`div` 100)) $ + xpElem "animal" (xpAttr "name" xpText0) (xpContent xpickle),++ u "xpWrapMaybe"+ "<top><animal name=\"dog\">4</animal><animal name=\"spider\">8</animal><animal name=\"fish\">0</animal></top>"+ (Right [("_dog",400),("_spider",800),("_fish",0)] :: Either String [(String,Int)]) $+ xpElemNodes "top" $ xpList $+ xpWrapMaybe (Just . (('_':) *** (*100)), tail *** (`div` 100)) $ + xpElem "animal" (xpAttr "name" xpText0) (xpContent xpickle),++ u2 "xpWrapMaybe failure with xpList"+ "<top><animal name=\"dog\">4</animal><animal name=\"spider\">8</animal><animal name=\"fish\">0</animal></top>"+ "<top><animal name=\"dog\">4</animal></top>"+ (Right [("_dog",400)] :: Either String [(String,Int)]) $+ xpElemNodes "top" $ xpList $+ xpWrapMaybe (\(a,b) -> if b < 6 then Just (('_':a),b*100) else Nothing, tail *** (`div` 100)) $ + xpElem "animal" (xpAttr "name" xpText0) (xpContent xpickle),++ u "xpWrapMaybe with xpList0"+ "<top><animal name=\"dog\">4</animal><animal name=\"spider\">8</animal><animal name=\"fish\">0</animal></top>"+ (Right [("_dog",400),("_spider",800),("_fish",0)] :: Either String [(String,Int)]) $+ xpElemNodes "top" $ xpList0 $+ xpWrapMaybe (Just . (('_':) *** (*100)), tail *** (`div` 100)) $ + xpElem "animal" (xpAttr "name" xpText0) (xpContent xpickle),++ u "xpWrapMaybe failure with xpList0"+ "<top><animal name=\"dog\">4</animal><animal name=\"spider\">8</animal><animal name=\"fish\">0</animal></top>"+ (Left "in <top>, in list, xpWrapMaybe can't encode Nothing value" :: Either String [(String,Int)]) $+ xpElemNodes "top" $ xpList0 $+ xpWrapMaybe (\(a,b) -> if b < 6 then Just (('_':a),b*100) else Nothing, tail *** (`div` 100)) $ + xpElem "animal" (xpAttr "name" xpText0) (xpContent xpickle),++ u "xpWrapMaybe_ failure with xpList0"+ "<top><animal name=\"dog\">4</animal><animal name=\"spider\">8</animal><animal name=\"fish\">0</animal></top>"+ (Left "in <top>, in list, no invertebrates, please" :: Either String [(String,Int)]) $+ xpElemNodes "top" $ xpList0 $+ xpWrapMaybe_ "no invertebrates, please" (\(a,b) -> if b < 6 then Just (('_':a),b*100) else Nothing, tail *** (`div` 100)) $ + xpElem "animal" (xpAttr "name" xpText0) (xpContent xpickle),++ u "xpWrapEither"+ "<top><animal name=\"dog\">4</animal><animal name=\"spider\">8</animal><animal name=\"fish\">0</animal></top>"+ (Right [("_dog",400),("_spider",800),("_fish",0)] :: Either String [(String,Int)]) $+ xpElemNodes "top" $ xpList0 $+ xpWrapEither (Right . (('_':) *** (*100)), tail *** (`div` 100)) $ + xpElem "animal" (xpAttr "name" xpText0) (xpContent xpickle),++ u "xpWrapEither failure"+ "<top><animal name=\"dog\">4</animal><animal name=\"spider\">8</animal><animal name=\"fish\">0</animal></top>"+ (Left "in <top>, in list, no invertibrates, I said" :: Either String [(String,Int)]) $+ xpElemNodes "top" $ xpList0 $+ xpWrapEither (\(a,b) -> if b < 6 then Right (('_':a),b*100) else Left "no invertibrates, I said", tail *** (`div` 100)) $ + xpElem "animal" (xpAttr "name" xpText0) (xpContent xpickle),++ u "xpOption present"+ "<top><mineral>salt</mineral></top>"+ (Right $ Just "salt") $+ xpElemNodes "top" $ xpOption $ xpElemNodes "mineral" $ xpContent xpText0,++ u "xpOption absent"+ "<top/>"+ (Right $ Nothing) $+ xpElemNodes "top" $ xpOption $ xpElemNodes "mineral" $ xpContent xpText0,++ u "xpDefault present"+ "<top><mineral>salt</mineral></top>"+ (Right $ "salt") $+ xpElemNodes "top" $ xpDefault "quartz" $ xpElemNodes "mineral" $ xpContent xpText0,++ u "xpDefault absent"+ "<top/>" -- omits default if it matches+ (Right $ "quartz") $+ xpElemNodes "top" $ xpDefault "quartz" $ xpElemNodes "mineral" $ xpContent xpText0,++ u "xpWithDefault present"+ "<top><mineral>salt</mineral></top>"+ (Right $ "salt") $+ xpElemNodes "top" $ xpDefault "quartz" $ xpElemNodes "mineral" $ xpContent xpText0,++ u2 "xpWithDefault absent"+ "<top/>"+ "<top><mineral>quartz</mineral></top>" -- encodes default on pickle+ (Right $ "quartz") $+ xpElemNodes "top" $ xpWithDefault "quartz" $ xpElemNodes "mineral" $ xpContent xpText0,+ + u "xpAlt"+ "<top><duck/><pukeko/><swan/></top>"+ (Right $ [1,0,2] :: Either String [Int]) $+ xpElemNodes "top" $ xpList0 $+ xpAlt id [xpElemNodes "pukeko" $ xpContent $ xpLift 0,+ xpElemNodes "duck" $ xpContent $ xpLift 1,+ xpElemNodes "swan" $ xpContent $ xpLift 2],++ u2 "xpTryCatch"+ "<top>five</top>"+ "<top>4</top>"+ (Right 4 :: Either String Int) $+ xpElemNodes "top" $ xpContent $+ xpTryCatch xpPrim (xpWrap (length, const "x") xpText0),++ u "xpThrow"+ "<top/>"+ (Left "in <top>, Oh!" :: Either String Int) $+ xpElemNodes "top" $ xpThrow "Oh!",+ + u "xpAttrs"+ "<top name=\"Stephen\" favouriteColour=\"green\"/>"+ (Right [("name", "Stephen"),("favouriteColour","green")]) $+ xpElemAttrs "top" xpAttrs,++ u "xpTree"+ "<top test=\"1\">hello</top>"+ (Right (Element "top" [("test","1")] [Text "hello"])) $+ xpTree,++ u "xpTrees"+ "<top test=\"1\">hello</top>"+ (Right [Element "top" [("test","1")] [Text "hello"]]) $+ xpTrees+ ]+