diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +import Distribution.Simple +main = defaultMain diff --git a/src/Data/XML/Pickle.hs b/src/Data/XML/Pickle.hs new file mode 100644 --- /dev/null +++ b/src/Data/XML/Pickle.hs @@ -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: +-- +-- > A fat thin man with long short hair +-- > Lives in a white house with green windows +-- +-- 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 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 @\@ and @Nothing@ would be +-- encoded as @\@. +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 +-- +-- > value +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)) + } diff --git a/xml-picklers.cabal b/xml-picklers.cabal new file mode 100644 --- /dev/null +++ b/xml-picklers.cabal @@ -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