xml-picklers (empty) → 0.1
raw patch · 4 files changed
+1000/−0 lines, 4 filesdep +basedep +containersdep +textsetup-changed
Dependencies added: base, containers, text, xml-types
Files
- LICENSE +30/−0
- Setup.hs +4/−0
- src/Data/XML/Pickle.hs +938/−0
- xml-picklers.cabal +28/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright+(c) 2009 Stephen Blackheath+(c) 2009 Matthew Pocock+(c) 2012 Philipp Balzarek++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:+* Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+* Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+* Neither the name of the author nor the names of contributors may be+ used to endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++import Distribution.Simple+main = defaultMain
+ src/Data/XML/Pickle.hs view
@@ -0,0 +1,938 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances,+ UndecidableInstances, FunctionalDependencies, DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This module provides XML picklers that plug into the xml tree of the+-- /xml-types/ package.+-- This module was \"inspired\" by hexpat-pickle.+--+-- The API differences between /hexpat-pickle/ and this module include:+--+-- * When unpickling, picklers will /consume/ matching elmements so that they will be ignored by sucessive picklers.+-- To circumvent this behaviour, use @'xpPeek'@+--+-- * wrappers like 'xpWrap' are uncurried+--+-- * There are no lazy unpicklers+--+-- * Unpicklers keep track of whether they (and any nested picklers) consumed all input, giving rise to the 'xpClean' and 'xpRecursiveClean' combinators+--+-- 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 reason why you a list of nodes instead of just one 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.+--+-- Most picklers will try to find the /first match/ rather than failing when+-- the first element doesn't match. This is why the target type often ist+-- a list. To prevent this behaviour and commit the pickler to the first+-- element available, use 'xpIsolate'.+--+-- 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 ['Node'] 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@.+--+-- /NB/: Unresolved entities are considered an error and will trigger an exception+--+-- When unpickling, the folowing invariant regarding the list of remaining elements should be observed:+-- * The returned list should be a subset of or the initial list itself, that is, no elements should be added+-- or changed+-- * The relative order of elements should be preserved+-- * Elements may, however, be removed from anywhere in the list+--+-- Here is a simple example to get you started:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Data.Text+-- > import Data.XML.Types+-- > import Data.XML.Pickle+-- >+-- > -- Person name, age and description+-- > data Person = Person Text Int Text+-- >+-- > xpPerson :: PU [Node] 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" xpId)+-- > (xpAttr "age" xpPrim))+-- > (xpContent xpId)+-- >+-- > 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+-- > print $ pickle (xpRoot $ xpElemNodes "people" $ xpAll xpPerson) people+--+-- Program outputs would be an xml-value equivalent to:+--+-- > <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>+--+-- Funktions marked with /compat/ are included for compatibility with hexpat-pickle++module Data.XML.Pickle (+ -- * Types+ PU(..)+ , Attribute+ -- * Pickler Invocation+ , pickle+ , unpickle+ -- * Primitive picklers+ , xpUnit+ , xpZero+ , xpThrow+ -- * Value-preserving picklers+ , xpId+ , xpTrees+ , xpHead+ , xpTree+ , xpText0+ , xpText+ , xpRoot+ , xpPrim+ -- * XML specific picklers+ -- ** Attributes+ , xpAttr+ , xpAttrImplied+ , xpAttrFixed+ -- ** Elements+ , xpElem+ , xpElemWithName+ , xpElemByNamespace+ , xpElemVerbatim+ , xpElemAttrs+ , xpElemNodes+ , xpElemBlank+ , xpElemExists+ -- ** Character Content+ , xpContent+ -- * Pickler combinators+ -- ** choice+ , xpOption+ , xpDefault+ , xpWithDefault+ , xpMap+ , xpAlt+ , xpEither+ , xpTryCatch+ -- ** sequencing+ -- |+ -- /NB/ The sequencing operations /do not/ enforce any order on the+ -- matched elements unless stated otherwise, but you can commit individial+ -- picklers to the next available element with 'xpIsolate'.+ -- Applying @xpIsolate@ on all nested Picklers will in effect enforce order.+ --+ -- Howver, once a pickler consumes an element it will not be available to+ -- following picklers. You can circumvent this behaviour with 'xpPeek'.+ --+ -- If you want ensure that all elements are consumed after the last pickler is+ -- run you may want to use 'xpClean'++ -- *** Lists+ -- |+ -- The List pickler combinators will pickle lists in the given order+ -- without any special treatment and unpickle as stated.+ , xpFindMatches+ , xpAll+ , xpList0+ , xpSeqWhile+ , xpList+ -- *** Tuples+ -- | Tuple combinators apply their picklers from left to right+ , xp2Tuple+ , xpPair+ , (<++>)+ , xp3Tuple+ , xpTriple+ , xp4Tuple+ , xp5Tuple+ , xp6Tuple+ -- ** Wrappers+ -- *** value wrappers+ , xpWrap+ , xpWrapEither+ , xpWrapMaybe+ , xpWrapMaybe_+ , xpAssert+ , xpElems+ -- *** Book keeping+ -- | Change the semantics of picklers+ , xpIsolate+ , xpPeek+ -- *** Cleannes+ -- |+ -- Picklers keep track of elements left over after unpickling,+ -- so the may be+ --+ -- [@clean@] an unpickling is considered @clean@ when it doesn't leave any remainng elements+ --+ -- [@recursively clean@] an unpickling is considered @recursively clean@ if it and any nested picklers are clean+ --++ , xpClean+ , xpRecursiveClean+ -- * Exceptions+ , UnresolvedEntityException+ -- * helper functions+ , flattenContent+) where++import Control.Applicative ((<$>))+import Control.Arrow+import qualified Control.Category as Cat++import Data.Either+import Data.List(intersperse)+import Data.Monoid(Monoid, mempty)++import Control.Exception+import qualified Data.Map as M+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Typeable++import Data.XML.Types++data PU t a = PU+ { unpickleTree :: t+ -> Either String (a, (Maybe t, Bool))+ -- ^ Either an error or the return value,+ -- any remaining input and a Bool value indicating whether+ -- all nested picklers where clean+ , pickleTree :: a -> t+ }++data UnresolvedEntityException = UnresolvedEntityException+ deriving (Typeable, Show)+instance Exception UnresolvedEntityException++ppName :: Name -> String+ppName (Name local ns pre) = let+ ns' = case ns of+ Nothing -> []+ Just ns'' -> ["{", Text.unpack ns'',"}"]+ pre' = case pre of+ Nothing -> []+ Just pre'' -> [Text.unpack pre'',":"]+ in concat . concat $ [["\""],ns', pre', [Text.unpack local], ["\""]]++-- | pickle a Tree+pickle :: PU t a -> a -> t+pickle = pickleTree++-- | unpickle a tree, throws away information concerning cleannes+unpickle :: PU t a -> t -> Either String a+unpickle xp x = fst <$> unpickleTree xp x+++for :: [a] -> (a -> b) -> [b]+for = flip map++mapLeft _ (Right r) = Right r+mapLeft f (Left l ) = Left $ f l++type Attribute = (Name,[Content])+++-- | Returns everything (remaining), untouched.+xpId :: PU a a+xpId = PU (\t -> Right (t, (Nothing,True))) id++-- | 'xpId' (/compat/)+xpTrees :: PU a a+xpTrees = xpId++-- | return one element, untouched+xpHead :: PU [a] a+xpHead = PU {unpickleTree = \t -> case t of+ [] -> Left $ "xpHead: No element remaining"+ t:ts -> Right (t , (if null ts then Nothing else Just ts, True))+ , pickleTree = return+ }++-- | 'xpHead' (/compat/)+xpTree :: PU [a] a+xpTree = xpHead++-- | specialised version of 'xpId' (/compat/)+xpText0 :: PU Text Text+xpText0 = xpId+++-- | Test predicate when unpickling. Fails with given error message when the+-- predicate return false.+--+-- N.B.: The predicate will only be tested while /unpickling/. When pickling,+-- this is a noop.+xpAssert :: String -> (a -> Bool) -> PU t a -> PU t a+xpAssert error p xp = PU { unpickleTree = \t -> case unpickleTree xp t of+ Left e -> Left e+ Right (r,c) -> case p r of+ True -> Right (r,c)+ False -> Left error+ , pickleTree = pickleTree xp+ }++-- | Like 'xpText0', but fails on non-empty input.+xpText :: PU Text Text+xpText = xpAssert "xpText: Text value is null" Text.null xpText0++-- | Adapts a list of nodes to a single node. Generally used at the top level of+-- an XML document.+xpRoot ::PU [a] b -> PU a b+xpRoot pa = PU+ { unpickleTree = \t -> case unpickleTree pa [t] of+ Left l -> Left l+ Right (a,(Nothing,True)) -> Right (a, (Nothing,True ))+ Right (a,(_ ,_ )) -> Right (a, (Nothing,False))+ , pickleTree = \t -> case pickleTree pa t of+ [t1] -> t1+ _ -> error "pickler called by xpRoot must output only one element"+ }+++getFirst :: (t -> Bool) -> [t] -> Maybe (t, [t])+getFirst _ [] = Nothing+getFirst p (x:xs) = case p x of+ True -> Just (x,xs)+ False -> (second (x:)) <$> getFirst p xs+++-- | pickle to/from attribute+xpAttr :: Name -> PU Text a -> PU [Attribute] a+xpAttr name pu = PU+ { unpickleTree = doUnpickle+ , pickleTree = \value -> [(name, [ContentText $ pickleTree pu value])]+ }+ where+ doUnpickle attrs = case getFirst ((== name) . fst) attrs of+ Nothing -> Left $ "attribute " ++ ppName name ++ " not found."+ Just ((_,[ContentText x]), rem) -> case unpickleTree pu x of+ Left e -> Left $ "in attribute " ++ ppName name ++ " : " ++ e+ Right (y,(_,c)) -> let rem' = if null rem then Nothing else Just rem+ in Right (y,(rem',c))+ _ -> Left $ "xpAttr: Unresolved entities in " ++ ppName name ++ "."++-- | Pickle attribute if Just is given, on unpickling return Just <val> when+-- the attribute is found, Nothing otherwise+xpAttrImplied :: Name -> PU Text a -> PU [Attribute] (Maybe a)+xpAttrImplied name pu = xpOption $ xpAttr name pu++-- | Pickle an attribute with the specified name and value, fail if the same attribute is+-- not present on unpickle.+xpAttrFixed :: Name -> Text -> PU [Attribute] ()+xpAttrFixed name val =+ xpWrapMaybe_ ("expected fixed attribute "++ ppName name++"="++show val)+ (\v -> if v == val then Just () else Nothing) (const val) $+ xpAttr name xpId++-- | Add an attribute with a fixed value.+xpAddFixedAttr :: Name -> Text -> PU [Attribute] b -> PU [Attribute] b+xpAddFixedAttr name val pa+ = xpWrap snd ((,) ()) $+ xp2Tuple (xpAttrFixed name val) pa+++-- merge successive NodeCotents+flattenContent :: [Node] -> [Node]+flattenContent xs = case foldr (\x (buf, res) -> case x of+ NodeContent (ContentText txt)+ -> (txt : buf, res)+ e@(NodeElement _)+ -> ([] , e : addConcatText buf res)+ _ -> throw UnresolvedEntityException+ ) ([], []) xs+ of+ (buf, res) -> addConcatText buf res+ where+ nc = NodeContent . ContentText+ addConcatText [] = id+ addConcatText xs = (nc (Text.concat xs) :)+++-- | When unpickling, tries to find the first element with the supplied name.+-- Once such an element is found, it will commit to it and /fail/ if any of the+-- picklers don't match.+xpElem :: Name -- ^ name of the Element+ -> PU [Attribute] a -- ^ pickler for attributes+ -> PU [Node] n -- ^ pickler for child nodes+ -> PU [Node] (a,n)+xpElem name attrP nodeP = PU+ { unpickleTree = doUnpickleTree+ , pickleTree = \(a,n) -> [NodeElement $ Element name+ (pickleTree attrP a)+ (pickleTree nodeP n)+ ]+ } where+ doUnpickleTree nodes = case getFirst (nodeElementNameHelper name) nodes of+ Just ((NodeElement (Element _ attrs children)), rem) ->+ case unpickleTree attrP attrs of+ Left e -> Left $ "in element " ++ ppName name ++ " : " ++ e+ Right (x,(_,ca)) -> case unpickleTree nodeP+ $ flattenContent children of+ Left e -> Left $ "in element " ++ ppName name ++ " : " ++ e+ Right (y,(_,cc)) ->+ let rem' = if null rem then Nothing else Just rem+ in Right ((x,y), (rem' , ca && cc))+ _ -> Left $ "xpElem: " ++ ppName name ++ " not found."++ nodeElementNameHelper name (NodeElement (Element n _ _)) = n == name+ nodeElementNameHelper _ _ = False++-- | pickle Element without restriction on the name.+-- the name as taken / returned as the first element of the triple+xpElemWithName :: PU [Attribute] a -- ^ pickler for attributes+ -> PU [Node] n -- ^ pickler for child nodes+ -> PU [Node] (Name,a,n)+xpElemWithName attrP nodeP = PU+ { unpickleTree = doUnpickleTree+ , pickleTree = \(name, a,n) -> [NodeElement $ Element name+ (pickleTree attrP a)+ (pickleTree nodeP n)+ ]+ } where+ doUnpickleTree nodes = case getFirst nodeElementHelper nodes of+ Just ((NodeElement (Element name attrs children)), rem) ->+ case unpickleTree attrP attrs of+ Left e -> Left $ "in element " ++ ppName name ++ " : " ++ e+ Right (x,(_,ca)) -> case unpickleTree nodeP $+ flattenContent children of+ Left e -> Left $ "in element " ++ ppName name ++ " : " ++ e+ Right (y,(_,cc)) ->+ let rem' = if null rem then Nothing else Just rem+ in Right ((name,x,y), (rem' , ca && cc))+ _ -> Left $ "xpElemWithName: no element found."++ nodeElementHelper (NodeElement (Element _ _ _)) = True+ nodeElementHelper _ = False++-- | find element by name space, prefixes are ignored+xpElemByNamespace :: Text -- ^ Namespace+ -> PU Text name -- ^ Pickler for the local name+ -> PU [Attribute] a -- ^ pickler for attributes+ -> PU [Node] n -- ^ pickler for child nodes+ -> PU [Node] (name,a,n)+xpElemByNamespace ns nameP attrP nodeP = PU+ { unpickleTree = doUnpickleTree+ , pickleTree = \(name, a,n) -> [NodeElement $ Element+ (Name (pickleTree nameP name) (Just ns) Nothing)+ (pickleTree attrP a)+ (pickleTree nodeP n)+ ]+ } where+ doUnpickleTree nodes = case getFirst (nodeElementNSHelper ns) nodes of+ Just ((NodeElement (Element name attrs children)), rem) ->+ case (do+ (name' , (_, cn)) <- unpickleTree nameP (nameLocalName name)+ (attrs', (_, ca)) <- unpickleTree attrP attrs+ (nodes', (_, cns)) <- unpickleTree nodeP nodes+ return ((name', attrs', nodes')+ ,(if null rem then Nothing else Just rem, cn && ca && cns))+ ) of+ Left e -> Left $ "in xpElemByNamespace with element " ++ ppName name ++ " : " ++ e+ Right r -> Right r+ _ -> Left $ "xpElemByNamespace: no element found."++ nodeElementNSHelper ns (NodeElement (Element n _ _)) = nameNamespace n == Just ns+ nodeElementNSHelper ns _ = False++-- | use Element untouched+xpElemVerbatim :: PU [Node] (Element)+xpElemVerbatim = PU+ { unpickleTree = doUnpickleTree+ , pickleTree = \e -> [NodeElement e]+ } where+ doUnpickleTree nodes = case getFirst nodeElementHelper nodes of+ Just ((NodeElement e@(Element _ _ _)), rem) ->+ let rem' = if null rem then Nothing else Just rem+ in Right (e, (rem', True))+ _ -> Left $ "xpElemVerbatim: no element found."++ nodeElementHelper (NodeElement (Element _ _ _)) = True+ nodeElementHelper _ = False++-- | A helper variant of xpElem for elements that contain attributes but no child tags.+xpElemAttrs :: Name -> PU [Attribute] b -> PU [Node] b+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 :: Name -> PU [Node] b -> PU [Node] b+xpElemNodes name puChildren = xpWrap (snd) (\a -> ((),a)) $+ xpElem name xpUnit puChildren++-- | Helper for Elements that don't contain anything+xpElemBlank :: Name -> PU [Node] ()+xpElemBlank name = xpWrap (const () ) (const ((),())) $+ xpElem name xpUnit xpUnit++-- | When pickling, creates an empty element iff parameter is True+--+-- When unpickling, checks whether element exists+xpElemExists :: Name -> PU [Node] Bool+xpElemExists name = xpWrap (\x -> case x of Nothing -> False; Just _ -> True)+ (\x -> if x then Just () else Nothing) $+ xpOption (xpElemBlank name)++-- | Get the Content from a node+xpContent :: PU Text a -> PU [Node] a+xpContent xp = PU+ { unpickleTree = doUnpickle+ , pickleTree = return . NodeContent . ContentText . pickleTree xp+ } where+ doUnpickle nodes = case getFirst nodeContentHelper nodes of+ Just ((NodeContent (ContentText t)), rem) -> case unpickleTree xp t of+ Right (a,(_,c)) -> Right (a, (if null rem then Nothing else Just rem,c))+ Left l -> Left $ "In xpContent: " ++ l+ Just ((NodeContent (ContentEntity t)), _) ->+ Left $ "xpContent: unresolved entity" ++ show t ++ "."+ _ -> Left $ "xpContent: No content found"++ nodeContentHelper (NodeContent _) = True+ nodeContentHelper _ = False++-- | Unlift a pickler on Nodes to a Pickler on Elements. Generated+-- Nodes that are not Elements will be silently discarded+xpElems :: PU [Node] a -> PU [Element] a+xpElems xp = PU+ { unpickleTree = doUnpickle+ , pickleTree = nodesToElems . pickleTree xp+ }+ where+ doUnpickle nodes = case unpickleTree xp (map NodeElement nodes) of+ Left e -> Left $ "In xpElems :" ++ e+ Right (a,(r,c)) -> let r' = case r of+ Nothing -> Nothing+ Just rs' -> case nodesToElems rs' of+ [] -> Nothing+ rs -> Just rs+ in Right (a,(r', c))+ nodesToElems = foldr (\n es -> case n of+ NodeElement e -> e : es+ _ -> es) []++-- | 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 = Right . doUnpickle,+ pickleTree = \mValue ->+ case mValue of+ Just value -> pickleTree pu value+ Nothing -> []+ }+ where+ doUnpickle t =+ case unpickleTree pu t of+ Right (val, (rest, clean)) -> ((Just val), (rest, clean))+ Left _ -> (Nothing, (Just t, True))++-- | 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+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.+xpWithDefault :: a -> PU t a -> PU t a+xpWithDefault a pa = xpTryCatch pa (lift a)+ where+ -- use this instead of standard xpLift, allowing us to use a more general tree type+ lift a = PU+ { unpickleTree = \t -> Right (a, (Just t, True))+ , pickleTree = error "xpWithDefault impossible" -- xpTryCatch never runs the second pickler+ }++-- TODO:+-- We could use Monoid m => m instead of [a], but that is for another day...++-- | Try to extract the reaming elements, fail if there are none+getRest :: (a, (Maybe [r], c)) -> (a, ([r], c))+-- getRest (_, (Nothing, _)) = Left $ "Not enough elements"+getRest (l, (Just r, c)) = (l,(r, c))+getRest (l, (Nothing, c)) =(l,([], c))+++-- | Doesn't create or consume anything, always succeeds+xpUnit :: PU [a] ()+xpUnit = PU (\x -> Right ((), (Just x, True))) (const [])+++-- | Combines 2 picklers++xp2Tuple :: PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2)+xp2Tuple xp1 xp2 = PU {pickleTree = \(t1, t2) ->+ pickleTree xp1 t1 ++ pickleTree xp2 t2+ , unpickleTree = doUnpickleTree+ } where+ doUnpickleTree r0 = mapLeft ("In xp2Tuple: " ++) $ do+ -- The /Either String/ monad+ (x1 ,(r1,c1)) <- getRest <$> unpickleTree xp1 r0+ (x2 ,(r ,c2)) <- unpickleTree xp2 r1+ return ((x1,x2),(r,c1 && c2))++-- | 'xp2Tuple' (/compat/)+xpPair :: PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2)+xpPair = xp2Tuple++-- | 'xp2Tuple'+(<++>) :: PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2)+(<++>) = xp2Tuple++-- | Combines 3 picklers+xp3Tuple :: PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] (a1, a2, a3)+xp3Tuple xp1 xp2 xp3 = PU {pickleTree = \(t1, t2, t3) ->+ pickleTree xp1 t1+ ++ pickleTree xp2 t2+ ++ pickleTree xp3 t3+ , unpickleTree = doUnpickleTree+ } where+ doUnpickleTree r0 = mapLeft ("In xp3Tuple: " ++) $ do+ (x1 ,(r1,c1)) <- getRest <$> unpickleTree xp1 r0+ (x2 ,(r2,c2)) <- getRest <$> unpickleTree xp2 r1+ (x3 ,(r ,c3)) <- unpickleTree xp3 r2+ return ((x1,x2,x3),(r, c1 && c2 && c3))++-- | 'xp3Tuple' (/compat/)+xpTriple :: PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] (a1, a2, a3)+xpTriple = xp3Tuple++-- | Combines 4 picklers+xp4Tuple :: PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] a4+ -> PU [a] (a1, a2, a3,a4)+xp4Tuple xp1 xp2 xp3 xp4+ = PU {pickleTree = \(t1, t2, t3, t4) ->+ pickleTree xp1 t1+ ++ pickleTree xp2 t2+ ++ pickleTree xp3 t3+ ++ pickleTree xp4 t4+ , unpickleTree = doUnpickleTree+ } where+ doUnpickleTree r0 = mapLeft ("In xp4Tuple: " ++) $ do+ (x1 ,(r1, c1)) <- getRest <$> unpickleTree xp1 r0+ (x2 ,(r2, c2)) <- getRest <$> unpickleTree xp2 r1+ (x3 ,(r3, c3)) <- getRest <$> unpickleTree xp3 r2+ (x4 ,(r , c4)) <- unpickleTree xp4 r3+ return ((x1,x2,x3,x4),(r, c1 && c2 && c3 && c4))++-- | Combines 5 picklers+xp5Tuple :: PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] a4 -> PU [a] a5+ -> PU [a] (a1, a2, a3, a4, a5)+xp5Tuple xp1 xp2 xp3 xp4 xp5+ = PU {pickleTree = \(t1, t2, t3, t4, t5) ->+ pickleTree xp1 t1+ ++ pickleTree xp2 t2+ ++ pickleTree xp3 t3+ ++ pickleTree xp4 t4+ ++ pickleTree xp5 t5+ , unpickleTree = doUnpickleTree+ } where+ doUnpickleTree r0 = mapLeft ("In xp5Tuple: " ++) $ do+ (x1 ,(r1,c1)) <- getRest <$> unpickleTree xp1 r0+ (x2 ,(r2,c2)) <- getRest <$> unpickleTree xp2 r1+ (x3 ,(r3,c3)) <- getRest <$> unpickleTree xp3 r2+ (x4 ,(r4,c4)) <- getRest <$> unpickleTree xp4 r3+ (x5 ,(r ,c5)) <- unpickleTree xp5 r4+ return ((x1,x2,x3,x4,x5),(r, c1 && c2 && c3 && c4 && c5))++-- | You guessed it ... Combines 6 picklers+xp6Tuple :: PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] a4 -> PU [a] a5+ -> PU [a] a6+ -> PU [a] (a1, a2, a3, a4, a5, a6)+xp6Tuple xp1 xp2 xp3 xp4 xp5 xp6+ = PU {pickleTree = \(t1, t2, t3, t4, t5, t6) ->+ pickleTree xp1 t1+ ++ pickleTree xp2 t2+ ++ pickleTree xp3 t3+ ++ pickleTree xp4 t4+ ++ pickleTree xp5 t5+ ++ pickleTree xp6 t6+ , unpickleTree = doUnpickleTree+ } where+ doUnpickleTree r0 = mapLeft ("In xp5Tuple: " ++) $ do+ (x1 ,(r1,c1)) <- getRest <$> unpickleTree xp1 r0+ (x2 ,(r2,c2)) <- getRest <$> unpickleTree xp2 r1+ (x3 ,(r3,c3)) <- getRest <$> unpickleTree xp3 r2+ (x4 ,(r4,c4)) <- getRest <$> unpickleTree xp4 r3+ (x5 ,(r5,c5)) <- getRest <$> unpickleTree xp5 r4+ (x6 ,(r ,c6)) <- {- return-} unpickleTree xp6 r5+ return ((x1,x2,x3,x4,x5,x6),(r, c1 && c2 && c3 && c4 && c5 && c6))++-- | When unpickling, don't consume the matched element(s), noop when pickling+xpPeek :: PU t a -> PU t a+xpPeek xp = PU { pickleTree = pickleTree xp+ , unpickleTree = \xs ->+ case unpickleTree xp xs of+ Left e -> Left e+ Right (r,(_,c)) -> Right (r,(Just xs,c))+ }++-- | Noop when pickling+--+-- When unpickling, only give access to the first element+xpIsolate :: PU [t] a -> PU [t] a+xpIsolate xp = PU { pickleTree = pickleTree xp+ , unpickleTree = \xs -> case xs of+ [] -> Left $ "xpIsolate: no elements left"+ (x:xs) -> case unpickleTree xp [x] of+ Left l -> Left l+ Right (v,(r,c)) -> Right (v,(handleRest r xs, c))+ } where+ handleRest r xs = case mbToList r ++ xs of [] -> Nothing; rs -> Just rs+ mbToList Nothing = []+ mbToList (Just r) = r++-- | apply a bijection before pickling / after unpickling+xpWrap :: (a -> b) -> (b -> a) -> PU t a -> PU t b+xpWrap to from xp = PU { unpickleTree = \x -> (first to) <$> unpickleTree xp x+ , pickleTree = pickleTree xp . from+ }++-- | Convert XML text content \<-\> any type that implements 'Read' and 'Show'.+-- Fails on unpickle if 'read' fails.+xpPrim :: (Show a, Read a) => PU Text a+xpPrim = PU { unpickleTree = \x -> case reads $ Text.unpack x of+ [] -> Left $ "In xpPrim: couldn't read " ++ show x ++ "."+ (r,rest):_ -> Right (r,(Nothing, True))+ , pickleTree = Text.pack . show+ }++-- | When unpickling, tries to apply the pickler to all elements+-- returning and consuming only matched elements+xpFindMatches :: PU [b] a -> PU [b] [a]+xpFindMatches xp = PU { unpickleTree = doUnpickleTree+ , pickleTree = \xs -> pickleTree xp =<< xs+ } where+ doUnpickleTree xs =+ let (ls, rs) = partitionEithers . for xs $ \x ->+ case unpickleTree xp [x] of+ Left _ -> Left x+ Right (r,(_,c)) -> Right (r, c)+ in Right (fst <$> rs, (if null ls then Nothing else Just ls,all snd rs))++-- | Tries to apply the pickler to all the remaining elements;+-- fails if any of them don't match+xpAll :: PU [a] b -> PU [a] [b]+xpAll xp = PU { unpickleTree = \x ->+ let Right (xs, (rs,c)) = unpickleTree (xpFindMatches xp) x+ in case rs of+ Just (_:_) -> Left "In xpAll: not all Elements matched"+ _ -> Right (xs, (Nothing,c))+ , pickleTree = \xs -> pickleTree xp =<< xs+ }++-- | 'xpAll' (/compat/)+xpList0 :: PU [a] b -> PU [a] [b]+xpList0 = xpAll++-- | Like xpList, but only succeed during deserialization if at least a+-- minimum number of elements are unpickled.+xpListMinLen :: Int -> PU [a] b -> PU [a] [b]+xpListMinLen ml = xpWrapEither testLength id . xpList+ where+ testLength as+ | length as < ml = Left $ "Expecting at least " ++ show ml ++ " elements"+ testLength as = Right as+++-- | When unpickling, sucessively applies pickler to single elements until it+-- fails; returns all matched elements.+xpSeqWhile :: PU [a] b -> PU [a] [b]+xpSeqWhile pu = PU {+ unpickleTree = Right . doUnpickle,+ pickleTree = \t -> (pickleTree pu) =<< t+ }+ where+ doUnpickle [] = ([],(Nothing,True))+ doUnpickle es@(elt:rem) =+ case unpickleTree pu [elt] of+ Right (val,(_,c)) -> let (xs,(r,c')) = doUnpickle rem in+ (val:xs,(r,c && c'))+ Left _ -> ([],(Just es,True))++-- | 'xpSeqWhile' (/compat/)+xpList :: PU [a] b -> PU [a] [b]+xpList = xpSeqWhile++-- | Standard pickler for maps+--+-- This pickler converts a map into a list of pairs of the form+--+-- > <elt attr="key">value</elt>+xpMap :: Ord k =>+ Name -- ^ Element name (elt)+ -> Name -- ^ Attribute name (attr)+ -> PU Text k -- ^ Pickler for keys (key)+ -> PU [Node] a -- ^ Pickler for values (value)+ -> PU [Node] (M.Map k a)+xpMap en an xpk xpv+ = xpWrap M.fromList+ M.toList+ $+ xpAll $+ xpElem en+ (xpAttr an xpk)+ xpv++-- | 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 = 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 unpickleTree pua t of+ Right (val, rest) ->+ case a2b val of+ Just val' -> Right (val', rest)+ Nothing -> Left errorMsg+ Left err -> Left err,+ pickleTree = \value -> pickleTree pua (b2a value)+ }++-- | 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+--+-- not to be confuesd with 'xpEither'+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+ Right (val, rest) -> (flip (,) rest) <$> a2b val+ Left err -> Left $ "xpWrapEither failed: "++err,+ pickleTree = \value -> pickleTree pua (b2a value)+ }++-- | 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 = doUnpickle,+ pickleTree = \value -> pickleTree (picklers !! (selector value)) value+ }+ where+ doUnpickle t =+ let tryAll [] = Left []+ tryAll (x:xs) =+ case unpickleTree x t of+ Right r -> Right r+ Left err -> case tryAll xs of+ Left errs -> Left $ err : errs+ Right r -> Right r+ in case tryAll picklers of+ Left errs -> Left $ "In xpAlt:\n " ++ concat (intersperse ";\n " errs)+ Right r -> Right r+++-- | Try the left pickler first and if that failes the right one.+-- wrapping the result in Left or Right, respectively+--+-- Not to be confued with 'xpWrapEither'+xpEither :: PU n t1 -> PU n t2 -> PU n (Either t1 t2)+xpEither xpl xpr = PU {+ unpickleTree = doUnpickle,+ pickleTree = \v -> case v of+ Left l -> pickleTree xpl l+ Right r -> pickleTree xpr r+ }+ where+ doUnpickle t = case unpickleTree xpl t of+ Right (val, rst) -> Right (Left val, rst)+ Left err -> case unpickleTree xpr t of+ Right (val, rst) -> Right (Right val, rst)+ Left _ -> Left $ "xpEither: both unpicklers failed"++-- | 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, rest) -> Right (val1, rest)+ Left err1 -> case unpickleTree pu2 t of+ Right (val2, rest) -> Right (val2, rest)+ Left err2 -> Left $ "Both xpTryCatch picklers failed: <" ++ err1 ++ "> <" ++ err2 ++ ">"+ , pickleTree = pickleTree pu1+ }++-- | The zero pickler+--+-- Encodes nothing, always fails 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+ , pickleTree = const []+ }++-- | When unpickling check that all elements have been consumed after this+-- pickler, fails otherwise+--+-- When pickling, this is a noop+xpClean :: PU t a -> PU t a+xpClean xp = PU { unpickleTree = \x -> case unpickleTree xp x of+ Left l -> Left l+ Right (y, (Nothing, c )) -> Right (y, (Nothing, c ))+ _ -> Left $ "xpClean: not clean"++ , pickleTree = pickleTree xp+ }++-- | When unpickling check that all elements have been consumed and+-- that the same is true for all nested picklers, fails otherwise+--+-- When pickling, this is a noop+xpRecursiveClean :: PU t a -> PU t a+xpRecursiveClean xp = PU { unpickleTree = \x -> case unpickleTree xp x of+ Left l -> Left l+ Right (_, (Just _, _)) ->+ Left $ "xpRecursiveClean: not clean"+ Right (_, (Nothing, False)) ->+ Left $ "xpRecursiveClean: not recursive clean"+ Right (y , (Nothing, True)) -> Right (y , (Nothing, True))+ , pickleTree = pickleTree xp+ }++instance Cat.Category PU where+ id = xpId+ g . f = PU { pickleTree = pickleTree f . pickleTree g+ , unpickleTree = \val -> case unpickleTree f val of+ Left e -> Left e+ Right (resf , (rem, cg)) -> case unpickleTree g resf of+ Left e -> Left e+ Right (resg, (_, cf)) -> Right (resg, (rem, cg && cf))+ }
+ xml-picklers.cabal view
@@ -0,0 +1,28 @@+Cabal-Version: >= 1.2+Name: xml-picklers+Version: 0.1+Synopsis: XML picklers based on xml-types, ported from hexpat-pickle+Description:+ A library of combinators that allows Haskell data structures to be pickled+ (serialized) to/from a representation of XML as defined in xml-types+Category: XML+License: BSD3+License-File: LICENSE+Author: Philipp Balzarek+Maintainer: Philipp Balzarek+Build-Type: Simple+Stability: experimental+Cabal-version: >= 1.8++Library+ hs-source-dirs: src+ Build-Depends:+ base >= 3 && < 5+ , xml-types >= 0.3+ , text >= 0.11+ , containers >= 0.4+ Exposed-Modules: Data.XML.Pickle++Source-Repository head+ type: git+ location: https://github.com/Philonous/xml-picklers