hexpat-pickle 0.1 → 0.2
raw patch · 5 files changed
+671/−430 lines, 5 filesdep +textdep ~hexpat
Dependencies added: text
Dependency ranges changed: hexpat
Files
- Text/XML/Expat/Pickle.hs +474/−252
- hexpat-pickle.cabal +16/−14
- test.hs +0/−164
- test/example.hs +30/−0
- test/test.hs +151/−0
Text/XML/Expat/Pickle.hs view
@@ -1,186 +1,284 @@-{-# LANGUAGE Rank2Types, FlexibleInstances, TypeSynonymInstances,- FlexibleContexts, MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances,+ UndecidableInstances, FunctionalDependencies #-} --- | XML picklers based on hexpat which are almost source code compatible with--- HXT.+-- | @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.+--+-- 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.+--+-- * HXT's list of pickler primitives is a little more complete.+--+-- 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):+--+-- * @'Element' t String String => 'PU' t a@ /(for working with an XML element)/+--+-- * @'PU' ['Node' String String] a@ /(for working with lists of elements)/+--+-- * @'TextContent' t String => 'PU' t a@ /(for working with text content)/+--+-- * @'PU' [(String, String)] a@ /(for working with attributes)/+--+-- 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.+--+-- @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@+--+-- * @'PU' ['Node' /tag/ /text/] a@+--+-- * @'TextContent' t /text/ => 'PU' t a@+--+-- * @'PU' [(/tag/, /text/)]@+--+-- /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'.+--+-- @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:+--+-- @+-- {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,+-- TypeSynonymInstances, UndecidableInstances #-}+-- @+--+-- 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+--+-- Program output:+--+-- > <?xml version="1.0" encoding="UTF-8"?>+-- > <people><person name="Dave" age="27">A fat thin man with long short hair</person>+-- > <person name="Jane" age="21">Lives in a white house with green windows</person></people>+ module Text.XML.Expat.Pickle (- PU_(PU),- Node,- PU,- pickleXML,- unpickleXML,+ -- * Primary interface+ PU(PU),+ Node(..), XmlPickler(..),- pickleTree, unpickleTree,+ pickleTree,+ -- * Classes for abstracting parts of the tree+ Element(..),+ TextContent(..), -- * Pickler primitives- xpReadShow, -- nmrp3/drdozer- xpText0,- xpText,+ xpUnit, xpElem,+ xpElemAttrs,+ xpElemNodes, xpAttr,- xpOption,+ xpText0,+ xpText,+ xpReadShow,+ -- * Pickler combinators xpPair, xpTriple, xp4Tuple, xp5Tuple,+ xp6Tuple, xpList,+ xpListMinLen,+ -- * Pickler type conversion xpWrap, xpWrapMaybe,- xpWrapEither, -- nmrp3/drdozer- xpAllAttrs,+ xpWrapEither,+ -- * Pickler conditionals+ xpOption, xpAlt,- xpUnit,- -- * Classes for abstracting parts of the tree- Stringable,- Nodeable,- Attrable+ xpTryCatch,+ xpThrow,+ xpWithDefault,+ -- * Pickler other+ xpConst,+ xpAttrs,+ xpTree,+ xpTrees,+ -- * Abstraction of string types+ GenericXMLString(..) ) where +import Text.XML.Expat.IO (Encoding) import Text.XML.Expat.Tree import Text.XML.Expat.Format+import Text.XML.Expat.Qualified import Data.Maybe import Data.Either import Data.List import Data.Char+import Data.Monoid 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 --- | A two-way pickler/unpickler that pickles a ''t'' to type ''a''. See--- /Text.XML.Expat.Tree/ for the tree structure as used with ''t''. ''t'' can be--- /Node/, /[Node]/, /[(String,String)]/, /(String,String)/ or /String/.------ A /PU_/ can be composed using the pickler primitives defined in this module.-data PU_ t a = PU {- unpickleTree_ :: t -> Either String a,- pickleTree_ :: a -> t -> t+-- | 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.+data PU t a = PU {+ -- | 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,+ -- | Convert a Haskell value of type @a@ to a @t@ XML tree part.+ pickleTree :: a -> t } --- | In the most common case, where the part of the tree you're pickling/unpickling--- is of type /Node/, you can use /PU/ and maintain source code compatibility with HXT. In--- other cases you will need to use PU_, which will break compatibility.-type PU a = PU_ Node a- toByteString :: String -> B.ByteString toByteString = B.pack . map (fromIntegral . ord) --- | Pickle a Haskell data structure to XML text. Outputs a strict ByteString.-pickleXML :: Maybe Encoding -> PU_ Node a -> a -> B.ByteString-pickleXML mEnc pu value = toByteString $ formatDoc mEnc $ pickleTree pu value---- | Unpickle XML text to a Haskell data structure. Takes a lazy ByteString.-unpickleXML :: PU_ Node a -> Maybe Encoding -> BL.ByteString -> Either String a-unpickleXML pu enc xml = do- case parse enc xml of- Just tree -> unpickleTree pu tree- Nothing -> Left "XML parse failed"- -- | We build the attributes and tags lists backwards, then reverse them afterwards -- for speed.-reverseElement :: Node -> Node+reverseElement :: Node tag text -> Node tag text reverseElement (Element eName eAttrs eChildren) = Element eName (reverse eAttrs) (reverse eChildren) reverseElement other = other -pickleTree :: PU a -> a -> Node-pickleTree pu value =- let Element _ _ elems = pickleTree_ pu value (Element "" [] [])- in case elems of- elem:_ -> elem- _ -> error "No top-level element"+-- | 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 -unpickleTree :: PU a -> Node -> Either String a-unpickleTree pu tree = unpickleTree_ pu (Element "" [] [tree])+instance GenericXMLString String where+ gxNullString = null+ gxToString = id+ gxFromString = id --- | Takes one more argument than the HXT version of XmlPickler, which is the--- type of the part of the tree, like /PU_/ does.-class XmlPickler t a where- xpickle :: PU_ t a+instance GenericXMLString B.ByteString where+ gxNullString = B.null+ gxToString = U8.decodeString . map w2c . B.unpack+ gxFromString = B.pack . map c2w . U8.encodeString -class Show t => Stringable t where- getString :: t -> String- putString :: String -> t -> t+instance GenericXMLString T.Text where+ gxNullString = T.null+ gxToString = T.unpack+ gxFromString = T.pack -instance Stringable String where- getString = id- putString = \_ -> id+-- | Define a generic 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 -instance Stringable (String, String) where- getString (name, value) = value- putString value (name, _) = (name, value)- -instance Stringable Node where- getString (Element _ _ eChildren) = getString eChildren- getString (Text str) = str- putString value (Element eName eAttrs eChildren) = Element eName eAttrs (putString value eChildren)- putString _ (Text _) = error "Can't put string into an existing text node"+-- | 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 --- | Tree parts that can be treated as strings.-instance Stringable [Node] where- getString = concatMap ex- where- ex (Text str) = str- ex _ = []- putString "" nodes = nodes- putString txt nodes = Text txt:nodes+instance TextContent String String where+ getString = id+ putString = id --- | Tree parts that can be treated as nodes.-class Show t => Nodeable t where- getNodes :: t -> [Node]- getSubnodes :: t -> [Node]- addChild :: Node -> t -> t+instance TextContent B.ByteString B.ByteString where+ getString = id+ putString = id -instance Nodeable [Node] where- getNodes = id- getSubnodes = id- addChild = (:)+instance TextContent T.Text T.Text where+ getString = id+ putString = id -instance Nodeable Node where- getNodes elt@(Element _ _ _) = [elt]- getNodes _ = error "No nodes to be found inside tag text"- getSubnodes (Element _ _ children) = children- getSubnodes _ = error "No subnodes to be found inside tag text"- addChild value elt@(Element name attrs children) = Element name attrs (value `addChild` children)- addChild _ _ = error "Can't append node to text tag"+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] --- | Tree parts that can be treated as attributes.-class Show t => Attrable t where- getAttrs :: t -> [(String,String)]- putAttrs :: [(String,String)] -> t -> t+-- | 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 Attrable Node where- getAttrs (Element _ attrs _) = attrs- getAttrs _ = error "No attributes to be found inside tag text"- putAttrs attrs (Element name _ children) = Element name attrs children- putAttrs _ _ = error "Can't put attributes into tag text"- -instance Attrable [(String,String)] where- getAttrs = id- putAttrs attrs _ = attrs+instance (Show tag, Show text) => Element [Node tag text] tag text where+ getElements = id+ putElement t = [t] -getAttributes (Element _ eAttrs _) = eAttrs-getAttributes (Text _) = error "No attributes to be found inside tag text"-setAttribute (name, value) (Element eName eAttrs eChildren) =- Element eName eAttrs' eChildren- where- eAttrs' = (name, value):eAttrs-setAttribute _ (Text _) = error "No attributes to be found inside tag text"+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 --- | Convert XML text \<-\> String. Handles empty strings.-xpText0 :: Stringable t => PU_ t String+-- | Convert XML text content \<-\> String. Handles empty strings.+xpText0 :: TextContent t text => PU t text xpText0 = PU {- unpickleTree_ = Right . U8.decodeString . getString,- pickleTree_ = putString . U8.encodeString+ unpickleTree = Right . getString,+ pickleTree = putString } --- | Convert XML text \<-\> String. Empty strings result in unpickle failure.-xpText :: Stringable t => PU_ t String+-- | Convert XML text content \<-\> String. Empty strings result in unpickle failure (Be warned!).+xpText :: TextContent t text => PU t text xpText = PU {- unpickleTree_ = \t ->+ unpickleTree = \t -> case getString t of- "" -> Left "empty text"- txt -> Right (U8.decodeString txt),- pickleTree_ = putString . U8.encodeString+ txt | gxNullString txt -> Left "empty text"+ txt -> Right txt,+ pickleTree = putString } maybeRead :: Read a => String -> Maybe a@@ -188,209 +286,333 @@ [(x, "")] -> Just x _ -> Nothing -instance Stringable s => XmlPickler s Int where+instance TextContent s text => XmlPickler s Int where xpickle = xpReadShow -instance Stringable s => XmlPickler s Integer where+instance TextContent s text => XmlPickler s Integer where xpickle = xpReadShow --- | Convert an XML string \<-\> a type that implements Read and Show.-xpReadShow :: (Stringable s, Read n, Show n) => PU_ s n+-- | 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 ->- case maybeRead (getString t) of+ unpickleTree = \t ->+ let txt = gxToString $ getString t+ in case maybeRead txt of Just val -> Right val- Nothing -> Left "bad numeric value",- pickleTree_ = \n -> putString (show n)+ Nothing -> Left $ "failed to read text: "++txt,+ pickleTree = \n -> putString (gxFromString $ show n) } -instance XmlPickler Node a => XmlPickler Node [a] where+instance (XmlPickler (Node tag text) a, Show tag, Show text) =>+ XmlPickler [Node tag text] [a] where xpickle = xpList xpickle --- | Create/parse an XML element of the specified name. Fails if an element of--- this name can't be found at this point in the tree. This implementation unpickles--- elements of different names in any order, while HXT's xpElem will fail if the--- XML order doesn't match the Haskell code.-xpElem :: Nodeable t => String -> PU_ Node a -> PU_ t a-xpElem name pu = PU {- unpickleTree_ = \t ->- let nodes = getSubnodes t- doElem elt@(Element eName _ _) | eName == name =- Just $ unpickleTree_ pu elt+-- | 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+-- 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+-- 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 name puAttrs puChildren = PU {+ unpickleTree = \t ->+ let doElem elt@(Element eName attrs children) | eName == name =+ Just $ (unpickleTree puAttrs attrs, unpickleTree puChildren children) doElem _ = Nothing- mVals = map doElem nodes- in case catMaybes mVals of- Right val:_ -> Right val- Left err:_ -> Left $ "in <"++name++">, "++err- [] -> Left $ "can't find element <"++name++">",- pickleTree_ = \value nodes ->- reverseElement (pickleTree_ pu value (Element name [] []))- `addChild` nodes+ mChildren = map doElem (getElements t)+ in case catMaybes mChildren of+ [] -> Left $ "can't find element <"++show 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,+ pickleTree = \(a,b) ->+ putElement $ 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) =>+ tag -- ^ Element name+ -> PU [(tag, text)] a -- ^ Pickler for attributes+ -> PU t 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 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 :: String -> PU_ (String, String) a -> PU_ Node a+xpAttr :: (Eq tag, Show tag) => tag -> PU text a -> PU [(tag,text)] a xpAttr name pu = PU {- unpickleTree_ = \t ->- let attrs = getAttributes t- doAttr attr@(aName, value) | aName == name =- case unpickleTree_ pu attr of+ unpickleTree = \attrs ->+ let doAttr attr@(aName, value) | aName == name =+ case unpickleTree pu value of Right val -> Just val Left _ -> Nothing doAttr _ = Nothing- mVals = map doAttr attrs- in case catMaybes mVals of+ mAttrs = map doAttr attrs+ in case catMaybes mAttrs of val:_ -> Right val- [] -> Left $ "can't find attribute '"++name++"'",- pickleTree_ = \value attrs ->- pickleTree_ pu value (name, "") `setAttribute` attrs+ [] -> Left $ "can't find attribute '"++show name++"'",+ pickleTree = \value -> [(name, pickleTree pu value)] } --- | Convert XML text <-> a Maybe type. During unpickling, Nothing is returned--- if there's a failure during the unpickling of the first argument.-xpOption :: PU_ t a -> PU_ t (Maybe a)+-- | 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:+--+-- > xpElemAttrs "score" $ xpOption $ xpAttr "value" xpickle+--+-- in which @Just 5@ would be encoded as @\<score value=\"5\"\/\>@ and @Nothing@ would be+-- encoded as @\<score\/\>@.+xpOption :: PU [t] a -> PU [t] (Maybe a) xpOption pu = PU {- unpickleTree_ = \t ->- case unpickleTree_ pu t of+ unpickleTree = \t ->+ case unpickleTree pu t of Right val -> Right (Just val) Left _ -> Right Nothing,- pickleTree_ = \mValue t ->+ pickleTree = \mValue -> case mValue of- Just value -> pickleTree_ pu value t- Nothing -> t+ Just value -> pickleTree pu value+ Nothing -> [] } -- | Convert XML text \<-\> a 2-tuple using the two arguments.-xpPair :: PU_ t a -> PU_ t b -> PU_ t (a,b)+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 ->+ case (unpickleTree pua t, unpickleTree pub t) of (Right a, Right b) -> Right (a,b)- (Left err, _) -> Left err- (_, Left err) -> Left err,- pickleTree_ = \(a, b) t ->- pickleTree_ pub b $ pickleTree_ pua a t+ (Left err, _) -> Left $ "in 1st of pair, "++err+ (_, Left err) -> Left $ "in 2nd of pair, "++err,+ pickleTree = \(a, b) ->+ pickleTree pua a +++ pickleTree pub b } -- | 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 :: 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 ->+ case (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t) of (Right a, Right b, Right c) -> Right (a,b,c)- (Left err, _, _) -> Left err- (_, Left err, _) -> Left err- (_, _, Left err) -> Left err,- pickleTree_ = \(a, b, c) t ->- pickleTree_ puc c $ pickleTree_ pub b $ pickleTree_ pua a t+ (Left err, _, _) -> Left $ "in 1st of triple, "++err+ (_, Left err, _) -> Left $ "in 2nd of triple, "++err+ (_, _, Left err) -> Left $ "in 3rd of triple, "++err,+ pickleTree = \(a, b, c) ->+ pickleTree pua a +++ pickleTree pub b +++ pickleTree puc c } -- | 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 :: 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 ->+ 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 err- (_, Left err, _, _) -> Left err- (_, _, Left err, _) -> Left err- (_, _, _, Left err) -> Left err,- pickleTree_ = \(a, b, c, d) t ->- pickleTree_ pud d $ pickleTree_ puc c $ pickleTree_ pub b $ pickleTree_ pua a t+ (Left err, _, _, _) -> Left $ "in 1st of 4-tuple, "++err+ (_, Left err, _, _) -> Left $ "in 2nd of 4-tuple, "++err+ (_, _, Left err, _) -> Left $ "in 3rd of 4-tuple, "++err+ (_, _, _, Left err) -> Left $ "in 4th of 4-tuple, "++err,+ pickleTree = \(a, b, c, d) ->+ pickleTree pua a +++ pickleTree pub b +++ pickleTree puc c +++ pickleTree pud d } -- | 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 :: 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 ->+ 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 err- (_, Left err, _, _, _) -> Left err- (_, _, Left err, _, _) -> Left err- (_, _, _, Left err, _) -> Left err- (_, _, _, _, Left err) -> Left err,- pickleTree_ = \(a, b, c, d, e) t ->- pickleTree_ pue e $ pickleTree_ pud d $ pickleTree_ puc c $ pickleTree_ pub b $ pickleTree_ pua a t+ (Left err, _, _, _, _) -> Left $ "in 1st of 5-tuple, "++err+ (_, Left err, _, _, _) -> Left $ "in 2nd of 5-tuple, "++err+ (_, _, Left err, _, _) -> Left $ "in 3rd of 5-tuple, "++err+ (_, _, _, Left err, _) -> Left $ "in 4th of 5-tuple, "++err+ (_, _, _, _, Left err) -> Left $ "in 5th of 5-tuple, "++err,+ pickleTree = \(a, b, c, d, e) ->+ pickleTree pua a +++ pickleTree pub b +++ pickleTree puc c +++ pickleTree pud d +++ pickleTree pue e } +-- | 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+ (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+ (_, _, Left err, _, _, _) -> Left $ "in 3rd of 6-tuple, "++err+ (_, _, _, Left err, _, _) -> Left $ "in 4th of 6-tuple, "++err+ (_, _, _, _, Left err, _) -> Left $ "in 5th of 6-tuple, "++err+ (_, _, _, _, _, Left err) -> Left $ "in 6th of 6-tuple, "++err,+ pickleTree = \(a, b, c, d, e, f) ->+ pickleTree pua a +++ pickleTree pub b +++ pickleTree puc c +++ pickleTree pud d +++ pickleTree pue e +++ pickleTree puf f+ }+ -- | 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 :: PU_ Node a -> PU_ Node [a]+xpList :: (Show tag, Show text) => PU (Node tag text) a -> PU [Node tag text] [a] xpList pu = PU {- unpickleTree_ = \t ->- let nodes = getSubnodes t- munge [] out = out- munge elts@(Element _ _ _:rest) out =- case unpickleTree_ pu (Element "" [] [head elts]) of- Right val -> munge rest (val:out)- Left _ -> out- munge (Text _:rest) out = munge rest out- in Right $ reverse $ munge nodes [],- pickleTree_ = \list t ->- foldr (\elt t -> pickleTree_ pu elt t) t (reverse list)+ unpickleTree = \nodes ->+ let munge [] = []+ munge (elt@(Element _ _ _):rem) =+ case unpickleTree pu elt of+ Right val -> val:munge rem+ Left _ -> []+ munge (_:rem) = munge rem -- ignore text nodes+ in Right $ munge nodes,+ pickleTree = map (pickleTree pu) } --- | Apply a lens to convert the type of your data structure into something that--- the pickler primitives can handle (such as tuples).-xpWrap :: (a -> b, b -> a) -> PU_ t a -> PU_ t b+-- | 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]+xpListMinLen ml = xpWrapEither (testLength, id) . xpList+ where+ testLength as | length as < ml = Left $ "Expecting at least " ++ show ml ++ " elements"+ testLength as = Right as++-- | 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:+--+-- > xpWrap (\(name, address) -> Person name address,+-- > \(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 -> case unpickleTree pua t of Right val -> Right (a2b val) Left err -> Left err,- pickleTree_ = \value t -> pickleTree_ pua (b2a value) t+ pickleTree = \value -> pickleTree pua (b2a value) } --- Like xpWrap, but removes Just (and treats Nothing as a failure) during unpickling.-xpWrapMaybe :: (a -> Maybe b, b -> a) -> PU_ t a -> PU_ t b+-- | 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+ 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" Left err -> Left err,- pickleTree_ = \value t -> pickleTree_ pua (b2a value) t+ pickleTree = \value -> pickleTree pua (b2a value) } --- Like xpWrap, except it removes Right (and treats Left as a failure) during unpickling.-xpWrapEither :: (a -> Either String b, b -> a) -> PU_ t a -> PU_ t b+-- | 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 unpickleTree pua t of Right val -> a2b val- Left err -> Left err,- pickleTree_ = \value t -> pickleTree_ pua (b2a value) t- }---- Convert an attribute list in the XML tree into [(String, String)]. (Does not--- exist in HXT.)-xpAllAttrs :: Attrable t => PU_ t [(String, String)]-xpAllAttrs = PU {- unpickleTree_ = \t -> Right (getAttrs t),- pickleTree_ = putAttrs+ Left err -> Left $ "xpWrapEither failed: "++err,+ pickleTree = \value -> pickleTree pua (b2a value) } --- | Allow alternative picklers. Selector function is used during pickling, but--- unpickling is done by trying each list element in order until one succeeds.-xpAlt :: (a -> Int) -- ^ Selector- -> [PU_ t a]- -> PU_ t a+-- | Execute one of a list of picklers. The /selector function/ is used during pickling, and+-- the integer returned is taken as a 0-based index to select a pickler from /pickler options/.+-- Unpickling is done by trying each list element in order until one succeeds+-- (the /selector/ is not used).+--+-- 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.+xpAlt :: (a -> Int) -- ^ selector function+ -> [PU t a] -- ^ list of picklers+ -> PU t a xpAlt selector picklers = PU {- unpickleTree_ = \t ->+ unpickleTree = \t -> let tryAll [] = Left "all xpAlt unpickles failed" tryAll (x:xs) =- case unpickleTree_ x t of+ case unpickleTree x t of Right val -> Right val Left err -> tryAll xs in tryAll picklers,- pickleTree_ = \value t -> pickleTree_ (picklers !! (selector value)) value t+ pickleTree = \value -> pickleTree (picklers !! (selector value)) value } -- | Convert nothing \<-\> (). Does not output or consume any XML text. -xpUnit :: PU_ t ()-xpUnit = PU {- unpickleTree_ = \t -> Right (),- pickleTree_ = \_ t -> t+xpUnit :: PU [t] ()+xpUnit = xpConst ()++-- | Convert nothing \<-\> constant value. Does not output or consume any XML text.+xpConst :: a -> PU [t] a+xpConst a = PU+ { unpickleTree = const $ Right a+ , pickleTree = const []+ }++-- | Pickler that during pickling always uses the first pickler, and during+-- unpickling tries the first, and on failure then tries the second.+xpTryCatch :: PU t a -> PU t a -> PU t a+xpTryCatch pu1 pu2 = PU+ { unpickleTree = \t -> case unpickleTree pu1 t of+ Right val1 -> Right val1+ Left err1 -> case unpickleTree pu2 t of+ Right val2 -> Right val2+ Left err2 -> Left $ "Both xpTryCatch picklers failed: <" ++ err1 ++ "> <" ++ err2 ++ ">"+ , pickleTree = pickleTree pu1+ }++-- | 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+ , 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,+ pickleTree = id+ }++-- | Insert/extract a tree node literally in the xml stream.+xpTree :: Element t tag text => PU t (Node tag text)+xpTree = PU {+ unpickleTree = \t -> case getElements t of+ [elt] -> Right elt+ otherwise -> Left "xpLiteral expects a single node",+ pickleTree = putElement+ }++-- | Insert/extract a list of tree nodes literally in the xml stream.+xpTrees :: PU [Node tag text] [Node tag text]+xpTrees = PU {+ unpickleTree = Right,+ pickleTree = id }
hexpat-pickle.cabal view
@@ -1,32 +1,34 @@ Cabal-Version: >= 1.2 Name: hexpat-pickle-Version: 0.1-Synopsis: XML picklers based on hexpat, almost source code compatible with HXT+Version: 0.2+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- to/from the Tree datatype defined in the hexpat package. It is almost source- code compatible with the pickling functionality of the HXT package, to allow- you to switch easily between the two implementations. This implementation is- simpler and more limited than HXT, but considerably faster.- This package does not depend on HXT.+ (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. .+ Note that hexpat-pickle is still under development, so it is fairly likely+ that there will be some API changes coming.+ . DARCS repository: <http://code.haskell.org/hexpat-pickle/>- .- Information/tutorial about the picklers found in the HXT package:- <http://www.haskell.org/haskellwiki/HXT/Conversion_of_Haskell_data_from/to_XML> Category: XML License: BSD3 License-File: LICENSE-Author: Stephen Blackheath, Matthew Pocock+Author: Stephen Blackheath (blackh), Matthew Pocock (drdozer) Maintainer: http://blacksapphire.com/antispam/-Copyright: (c) 2009 Stephen Blackheath+Copyright:+ (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.hs+Extra-Source-Files: test/test.hs, test/example.hs Build-Type: Simple Stability: alpha Library- Build-Depends: base, hexpat >= 0.3, utf8-string >= 0.3.3, bytestring >= 0.9+ Build-Depends: base, hexpat >= 0.4, utf8-string >= 0.3.3, bytestring >= 0.9,+ text >= 0.1 Exposed-Modules: Text.XML.Expat.Pickle
− test.hs
@@ -1,164 +0,0 @@-{-# LANGUAGE Rank2Types, FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-}--import qualified Text.XML.Expat.IO as EIO-import Text.XML.Expat.Tree as ETree-import Text.XML.Expat.Pickle-import Text.XML.Expat.Format-import Data.Tree-import qualified Data.ByteString.Lazy as B-import qualified Data.ByteString.Internal as B (w2c)-import Control.Monad-import Data.Maybe-import Data.Either-import Data.List-import Data.Char-import Debug.Trace-import Data.Time.Clock-import Numeric-import System.IO--class Key k where- keyValue :: k -> String--class Key k => LanguageKey k where- isoOf :: k -> String- makeLanguageKey :: String -> k--data MnemonicKey = MnemonicKey String- deriving Show--instance Key MnemonicKey where- keyValue (MnemonicKey str) = str--data LanguageKey k => MultiText k = MultiText {- lang :: k,- languageText :: String,- timestamp :: Integer- }- deriving (Eq, Show)--instance LanguageKey k => XmlPickler Node (MultiText k) where- xpickle = xpMultiText "text"--data SiteLanguageKey = SiteLanguageKey String- deriving Show--instance Key SiteLanguageKey where- keyValue (SiteLanguageKey a) = a--instance LanguageKey SiteLanguageKey where- isoOf = keyValue- makeLanguageKey str = SiteLanguageKey str--maybeRead :: Read a => String -> Maybe a-maybeRead s = case reads s of- [(x, "")] -> Just x- _ -> Nothing--xpMultiText :: LanguageKey k => String -> PU (MultiText k)-xpMultiText tagName =- xpWrap (- (\(lan, tex1, tim, tex2) -> MultiText- (makeLanguageKey lan)- (if tex2 /= "" then tex2 else fromMaybe "" tex1)- (truncate $ fromMaybe 0 ((maybeRead (fromMaybe "0" tim))::Maybe Float))),- (\(MultiText lan tex tim) -> (isoOf lan, Nothing, Just $ show tim, tex))- ) $- xpElem tagName $- xp4Tuple- (xpAttr "lang" xpText0)- (xpOption $ xpAttr "text" xpText0)- (xpOption $ xpAttr "time" xpText0)- xpText0--data LanguageKey k => MultiLanguage k = MultiLanguage {- texts :: [MultiText k]- }- deriving (Eq, Show)--nullMultiLanguage :: LanguageKey k => MultiLanguage k-nullMultiLanguage = MultiLanguage []--instance XmlPickler Node (MultiLanguage SiteLanguageKey) where- xpickle = xpMultiLanguage "text"--xpMultiLanguage :: LanguageKey k => String -> PU (MultiLanguage k)-xpMultiLanguage childTagName =- xpWrap (- (\ts -> MultiLanguage ts),- (\(MultiLanguage ts) -> ts)- ) $- xpList (xpMultiText childTagName)--data Mnemonic = Mnemonic {- mnemonicKey :: MnemonicKey,- category :: String,- comment :: String,- multiLanguage :: MultiLanguage SiteLanguageKey,- linkTo :: Maybe MnemonicKey- }- deriving (Show)--instance XmlPickler Node Mnemonic where- xpickle = xpMnemonic--xpMnemonic :: PU Mnemonic-xpMnemonic = xpElem "mnemonic" $ xpMnemonicAttrs--xpMnemonicAttrs :: PU Mnemonic-xpMnemonicAttrs =- xpWrap (- (\(mne, cat, com, tex, lin) ->- Mnemonic (MnemonicKey mne) cat (fromMaybe "" com) tex- (liftM (MnemonicKey . ("category."++)) lin)),- (\(Mnemonic (MnemonicKey mne) cat com tex lin) ->- (mne, cat, if com == "" then Nothing else Just com, tex,- liftM ((fromMaybe "" . stripPrefix "category.") . keyValue) lin))- ) $- xp5Tuple- (xpAttr "name" xpText0)- (xpAttr "category" xpText0)- (xpOption $ xpAttr "comment" $ xpText0)- (xpMultiLanguage "text")- (xpOption $ xpAttr "link" $ xpText)--main_eio doc = do- parser <- EIO.newParser Nothing- EIO.setStartElementHandler parser startElement- EIO.parse parser doc -- True- putStrLn "ok"- where- startElement name attrs = putStrLn $ show name ++ " " ++ show attrs--main_tree doc = do- start <- getCurrentTime- let mTree = ETree.parse Nothing doc- --putStrLn $ show mTree- case mTree of- Just tree -> do- let pickler = xpElem "mnemonics" $ xpList xpMnemonic- let eMnems = unpickleTree pickler tree- case eMnems of- Right mnems -> do- --putStrLn $ show mnems- let pickled = pickleTree pickler mnems- out = formatDocS (Just UTF8) pickled "\n"- --putStrLn $ show pickled- --putStrLn $ out- let xml = map B.w2c (B.unpack doc)- if out == xml- then do- end <- getCurrentTime- let took = end `diffUTCTime` start- hPutStrLn stderr $ "passed"- hPutStrLn stderr $ "took "++showFFloat (Just 3) (realToFrac took) ""++" sec"- else do- hPutStrLn stderr $ "Failed - mismatch:"- putStr out- Left error -> do- hPutStrLn stderr $ "FAILED: "++error- Nothing -> return ()--main = do- xml <- B.readFile "test.xml"- main_tree xml
+ test/example.hs view
@@ -0,0 +1,30 @@+{-# 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+
+ test/test.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-}++import Text.XML.Expat.Tree+import Text.XML.Expat.Pickle+import Text.XML.Expat.Format+import Data.Tree+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.ByteString.Internal (w2c, c2w)+import Control.Monad+import Data.Maybe+import Data.Either+import Data.List+import Data.Char+import Debug.Trace+import Data.Time.Clock+import Numeric+import System.IO+import Data.Monoid++class Key k where+ keyValue :: k -> String++class Key k => LanguageKey k where+ isoOf :: k -> String+ makeLanguageKey :: String -> k++data MnemonicKey = MnemonicKey String+ deriving Show++instance Key MnemonicKey where+ keyValue (MnemonicKey str) = str++data LanguageKey k => MultiText k = MultiText {+ lang :: k,+ languageText :: String,+ timestamp :: Integer+ }+ deriving (Eq, Show)++instance LanguageKey k => XmlPickler (Node String String) (MultiText k) where+ xpickle = xpMultiText "text"++data SiteLanguageKey = SiteLanguageKey String+ deriving Show++instance Key SiteLanguageKey where+ keyValue (SiteLanguageKey a) = a++instance LanguageKey SiteLanguageKey where+ isoOf = keyValue+ makeLanguageKey str = SiteLanguageKey str++maybeRead :: Read a => String -> Maybe a+maybeRead s = case reads s of+ [(x, "")] -> Just x+ _ -> Nothing++xpMultiText :: LanguageKey k => String -> PU (Node String String) (MultiText k)+xpMultiText tagName =+ xpWrap (+ (\((lan, tex1, tim), tex2) -> MultiText+ (makeLanguageKey lan)+ (if tex2 /= "" then tex2 else fromMaybe "" tex1)+ (truncate $ fromMaybe 0 ((maybeRead (fromMaybe "0" tim))::Maybe Float))),+ (\(MultiText lan tex tim) -> ((isoOf lan, Nothing, Just $ show tim), tex))+ ) $+ xpElem tagName+ (xpTriple+ (xpAttr "lang" xpText0)+ (xpOption $ xpAttr "text" xpText0)+ (xpOption $ xpAttr "time" xpText0))+ xpText0++data LanguageKey k => MultiLanguage k = MultiLanguage {+ texts :: [MultiText k]+ }+ deriving (Eq, Show)++nullMultiLanguage :: LanguageKey k => MultiLanguage k+nullMultiLanguage = MultiLanguage []++instance XmlPickler [Node String String] (MultiLanguage SiteLanguageKey) where+ xpickle = xpMultiLanguage "text"++xpMultiLanguage :: LanguageKey k => String -> PU [Node String String] (MultiLanguage k)+xpMultiLanguage childTagName =+ xpWrap (+ (\ts -> MultiLanguage ts),+ (\(MultiLanguage ts) -> ts)+ ) $+ xpList (xpMultiText childTagName)++data Mnemonic = Mnemonic {+ mnemonicKey :: MnemonicKey,+ category :: String,+ comment :: String,+ multiLanguage :: MultiLanguage SiteLanguageKey,+ linkTo :: Maybe MnemonicKey+ }+ deriving (Show)++instance XmlPickler (Node String String) Mnemonic where+ xpickle = xpMnemonic++xpMnemonic :: PU (Node String String) Mnemonic+xpMnemonic =+ xpWrap (+ (\((mne, cat, com, lin), tex) ->+ Mnemonic (MnemonicKey mne) cat (fromMaybe "" com) tex+ (liftM (MnemonicKey . ("category."++)) lin)),+ (\(Mnemonic (MnemonicKey mne) cat com tex lin) ->+ ((mne, cat, if com == "" then Nothing else Just com,+ liftM ((fromMaybe "" . stripPrefix "category.") . keyValue) lin), tex))+ ) $+ xpElem "mnemonic"+ (xp4Tuple+ (xpAttr "name" xpText0)+ (xpAttr "category" xpText0)+ (xpOption $ xpAttr "comment" $ xpText0)+ (xpOption $ xpAttr "link" $ xpText))+ (xpMultiLanguage "text")++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")+ if xml == doc+ then do+ end <- getCurrentTime+ let took = end `diffUTCTime` start+ hPutStrLn stderr $ "passed"+ hPutStrLn stderr $ "took "++showFFloat (Just 3) (realToFrac took) ""++" sec"+ else do+ hPutStrLn stderr $ "Failed - mismatch:"+ B.putStr xml+ Left error -> do+ hPutStrLn stderr $ "FAILED: "++error+ Left error -> do+ hPutStrLn stderr $ "FAILED: "++show error++main = do+ xml <- B.readFile "test.xml"+ main_tree xml