diff --git a/src/Data/XML/Pickle.hs b/src/Data/XML/Pickle.hs --- a/src/Data/XML/Pickle.hs +++ b/src/Data/XML/Pickle.hs @@ -78,12 +78,12 @@ -- > main = do -- > print $ pickle (xpRoot $ xpElemNodes "people" $ xpAll xpPerson) people -- --- Program outputs would be an xml-value equivalent to: +-- Program output 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 +-- Functions marked with /compat/ are included for compatibility with hexpat-pickle module Data.XML.Pickle ( -- * Types @@ -141,6 +141,7 @@ , xpWithDefault , xpMap , xpAlt + , xpChoice , xpEither , xpTryCatch -- ** sequencing @@ -170,7 +171,8 @@ , xpList , xpListMinLen -- *** Tuples - -- | Tuple combinators apply their picklers from left to right + -- | Tuple combinators apply their picklers from left to right. They will + -- succeed when all their constituents produce a value. , xp2Tuple , xpPair , (<#>) @@ -206,167 +208,30 @@ , (<++>) , () , () + , () , UnresolvedEntityException(..) -- * helper functions , flattenContent + , tErr + , getRest ) where import Control.Applicative ((<$>)) import Control.Arrow -import qualified Control.Category as Cat - -import Data.Either -import Data.List(partition) -import Data.Char(isSpace) - import Control.Exception import Control.Monad +import Data.Char (isSpace) +import Data.Either +import Data.List (partition) import qualified Data.Map as M import Data.Maybe import Data.Monoid (Monoid, mempty) import Data.Text (Text) import qualified Data.Text as Text -import Data.Typeable - import Data.XML.Types - -data UnpickleError = ErrorMessage Text - | TraceStep (Text, Text) UnpickleError - | Variants [UnpickleError] - deriving (Show, Typeable) - -showTr :: (Text, Text) -> String -showTr (name, "") = Text.unpack name -showTr (name, extra) = concat [Text.unpack name , " (", Text.unpack extra, ")"] - -printUPE :: UnpickleError -> [String] -printUPE (ErrorMessage m) = [Text.unpack m] -printUPE (TraceStep t es) = ("-> " ++ showTr t) : printUPE es -printUPE (Variants vs) = concat - . zipWith (:) (map (\x -> show x ++ ")") [(1 :: Int)..]) - . map (map ( " " ++)) - $ (printUPE <$> vs) - -ppUnpickleError :: UnpickleError -> String -ppUnpickleError e = "Error while unpickling:\n" - ++ unlines (map (" " ++) (printUPE e)) - -instance Exception UnpickleError - -data UnpickleResult t a = UnpickleError UnpickleError - | NoResult Text -- ^ Not found, description of element - | Result a (Maybe t) -- ^ Result and remainder. The - -- remainder is wrapped in Maybe to - -- avoid a Monoid constraint on t. - -- - -- /Invariant/: When t is a - -- Monoid, the empty remainder should - -- always be @Nothing@ instead of - -- @Just mempty@ - deriving (Functor, Show) - -instance Monad (UnpickleResult t) where - return x = Result x Nothing - Result x r >>= f = case f x of - Result y r' -> Result y (if isJust r then r else r') - y -> y - UnpickleError e >>= _ = UnpickleError e - NoResult e >>= _ = NoResult e - - -upe :: String -> UnpickleError -upe e = ErrorMessage (Text.pack e) - -missing :: String -> UnpickleError -missing e = upe $ "Entity not found: " ++ e - -missingE :: String -> UnpickleResult t a -missingE = UnpickleError . missing - -leftoverE :: String -> UnpickleResult t a -leftoverE l = UnpickleError . upe $ "Leftover Entities" ++ if null l then "" else - ": " ++ l -child :: Show a => PU a b -> a -> UnpickleResult t b -child xp v = case unpickleTree xp v of - UnpickleError e -> UnpickleError e - NoResult e -> missingE $ Text.unpack e - Result _ (Just es) -> leftoverE $ show es - Result r Nothing -> Result r Nothing - -child' :: PU t a -> t -> UnpickleResult t1 a -child' xp v = case unpickleTree xp v of - UnpickleError e -> UnpickleError e - NoResult e -> missingE $ Text.unpack e - Result _ (Just _es) -> leftoverE "" - Result r Nothing -> Result r Nothing - -leftover :: Maybe t -> UnpickleResult t () -leftover = Result () - -remList :: [t] -> Maybe [t] -remList [] = Nothing -remList xs = Just xs - -mapUnpickleError :: (UnpickleError -> UnpickleError) - -> UnpickleResult t a - -> UnpickleResult t a -mapUnpickleError f (UnpickleError e) = UnpickleError $ f e -mapUnpickleError _ x = x - -data PU t a = PU - { unpickleTree :: t -> UnpickleResult t a - , pickleTree :: a -> t - } - -mapError :: (UnpickleError -> UnpickleError) -> PU t a -> PU t a -mapError f xp = PU { unpickleTree = mapUnpickleError f . unpickleTree xp - , pickleTree = pickleTree xp - } - - -infixl 6 <++> -(<++>) :: (Text, Text) -> UnpickleError -> UnpickleError -(<++>) = TraceStep - -infixl 6 <++.> -(<++.>) :: (Text, Text) -> UnpickleResult t a -> UnpickleResult t a -(<++.>) s = mapUnpickleError (s <++>) - -infixr 0 --- | Override the last backtrace level in the error report -() :: (Text, Text) -> PU t a -> PU t a -() tr = mapError (swapStack tr) - where - swapStack ns (TraceStep _s e) = TraceStep ns e - swapStack _ns e = error $ "Can't replace non-trace step: " ++ show e - -() :: Text -> PU t a -> PU t a -() tr = mapError (swapStack tr) - where - swapStack ns (TraceStep (_,s) e) = TraceStep (ns,s) e - swapStack _ns e = error $ "Can't replace non-trace step: " ++ show e - - - -infixr 1 --- | Add a back trace level to the error report -() :: (Text, Text) -> PU t a -> PU t a -() tr = mapError (tr <++>) - -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], ["\""]] +import Data.XML.Pickle.Tuples +import Data.XML.Pickle.Basic -- | pickle a Tree pickle :: PU t a -> a -> t @@ -851,34 +716,6 @@ UnpickleError e -> UnpickleError e } - --- TODO: --- We could use Monoid m => m instead of [a], but that is for another day... - --- | Try to extract the remainig elements, fail if there are none -getRest :: UnpickleResult [a] b -> UnpickleResult [a] (b, [a]) -getRest (Result r (Just t)) = Result (r, t) Nothing -getRest (Result r Nothing) = Result (r, []) Nothing -getRest (NoResult e) = missingE $ Text.unpack e -getRest (UnpickleError e) = UnpickleError e - -tErr :: Text -> UnpickleResult t a -> UnpickleResult t a -tErr tr = mapUnpickleError (("tuple", tr) <++>) - --- | Combines 2 picklers -xp2Tuple :: PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2) -xp2Tuple xp1 xp2 = "xp2Tuple" - PU {pickleTree = \(t1, t2) -> - pickleTree xp1 t1 ++ pickleTree xp2 t2 - , unpickleTree = doUnpickleTree - } where - doUnpickleTree r0 = do - -- The /Either String/ monad - (x1 ,r1) <- tErr "1" . getRest $ unpickleTree xp1 r0 - x2 <- tErr "2" $ unpickleTree xp2 r1 - return (x1,x2) - - -- | 'xp2Tuple' (/compat/) xpPair :: PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2) xpPair l r = "xpPair" xp2Tuple l r @@ -887,88 +724,11 @@ (<#>) :: PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2) (<#>) l r = "(<#>)" xp2Tuple l r --- | Combines 3 picklers -xp3Tuple :: PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] (a1, a2, a3) -xp3Tuple xp1 xp2 xp3 = "xp3Tuple" PU {pickleTree = \(t1, t2, t3) -> - pickleTree xp1 t1 - ++ pickleTree xp2 t2 - ++ pickleTree xp3 t3 - , unpickleTree = doUnpickleTree - } where - doUnpickleTree r0 = do - (x1, r1) <- tErr "1" $ getRest $ unpickleTree xp1 r0 - (x2, r2) <- tErr "2" $ getRest $ unpickleTree xp2 r1 - x3 <- tErr "3" $ unpickleTree xp3 r2 - return (x1,x2,x3) - -- | 'xp3Tuple' (/compat/) xpTriple :: PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] (a1, a2, a3) xpTriple l m r = "xpTriple" xp3Tuple l m r --- | 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 - = "xp4Tuple" - PU {pickleTree = \(t1, t2, t3, t4) -> - pickleTree xp1 t1 - ++ pickleTree xp2 t2 - ++ pickleTree xp3 t3 - ++ pickleTree xp4 t4 - , unpickleTree = doUnpickleTree - } where - doUnpickleTree r0 = do - (x1 , r1) <- tErr "1" $ getRest $ unpickleTree xp1 r0 - (x2 , r2) <- tErr "2" $ getRest $ unpickleTree xp2 r1 - (x3 , r3) <- tErr "3" $ getRest $ unpickleTree xp3 r2 - x4 <- tErr "4" $ unpickleTree xp4 r3 - return (x1,x2,x3,x4) --- | 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 - = "xp5Tuple" - 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 = do - (x1 , r1) <- tErr "1" $ getRest $ unpickleTree xp1 r0 - (x2 , r2) <- tErr "2" $ getRest $ unpickleTree xp2 r1 - (x3 , r3) <- tErr "3" $ getRest $ unpickleTree xp3 r2 - (x4 , r4) <- tErr "4" $ getRest $ unpickleTree xp4 r3 - x5 <- tErr "5" $ unpickleTree xp5 r4 - return (x1,x2,x3,x4,x5) - --- | 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 - = "xp6Tuple" - 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 = do - (x1 , r1) <- tErr "1" $ getRest $ unpickleTree xp1 r0 - (x2 , r2) <- tErr "2" $ getRest $ unpickleTree xp2 r1 - (x3 , r3) <- tErr "3" $ getRest $ unpickleTree xp3 r2 - (x4 , r4) <- tErr "4" $ getRest $ unpickleTree xp4 r3 - (x5 , r5) <- tErr "5" $ getRest $ unpickleTree xp5 r4 - x6 <- tErr "6" $ unpickleTree xp6 r5 - return (x1,x2,x3,x4,x5,x6) - -- | 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 @@ -1121,6 +881,10 @@ -- -- 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. +-- +-- /NB/ This function will ignore all errors as long as one of the branches +-- returns a result. Also, it will produce an error when all branches return +-- NoResult. Use 'xpChoice' for a saner version of this function. xpAlt :: (a -> Int) -- ^ selector function -> [PU t a] -- ^ list of picklers -> PU t a @@ -1139,6 +903,34 @@ (es, []) -> ("xpAlt", "") <++.> UnpickleError (Variants es) _ -> error "xpAlt: splitResults returned impossible result" + +-- | 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 returns a Result or an Error. +-- +-- 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. +-- +-- This function is similar to 'xpAlt' but it will stop unpickling on the first +-- error. It will return NoResult iff all of the picklers return NoResult (or +-- the list of picklers is empty). +xpChoice :: (a -> Int) -- ^ selector function + -> [PU t a] -- ^ list of picklers + -> PU t a +xpChoice selector picklers = + PU { unpickleTree = go picklers (1 :: Integer) + , pickleTree = \value -> pickleTree (picklers !! selector value) value + } + where + go [] _ _ = NoResult "entity" + go (p:ps) i v = case unpickleTree p v of + r@Result{} -> r + UnpickleError e -> UnpickleError $ ("xpChoice", Text.pack $ show i) + <++> e + NoResult _ -> go ps (i+1) v + + -- | Try the left pickler first and if that doesn't produce anything the right -- one. wrapping the result in Left or Right, respectively -- @@ -1231,16 +1023,3 @@ e -> e , 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 - UnpickleError e -> UnpickleError e - NoResult e -> NoResult e - Result resf re -> case unpickleTree g resf of - UnpickleError e -> UnpickleError e - NoResult e -> NoResult e - Result _ (Just _) -> leftoverE "" - Result resg Nothing -> Result resg re - } diff --git a/src/Data/XML/Pickle/Basic.hs b/src/Data/XML/Pickle/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Data/XML/Pickle/Basic.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.XML.Pickle.Basic where + +import Control.Applicative ((<$>)) +import qualified Control.Category as Cat +import Control.Exception (Exception) +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 -> UnpickleResult t a + , pickleTree :: a -> t + } + +data UnpickleResult t a = UnpickleError UnpickleError + | NoResult Text -- ^ Not found, description of element + | Result a (Maybe t) -- ^ Result and remainder. The + -- remainder is wrapped in Maybe to + -- avoid a Monoid constraint on t. + -- + -- /Invariant/: When t is a + -- Monoid, the empty remainder should + -- always be @Nothing@ instead of + -- @Just mempty@ + deriving (Functor, Show) + +instance Monad (UnpickleResult t) where + return x = Result x Nothing + Result x r >>= f = case f x of + Result y r' -> Result y (if isJust r then r else r') + y -> y + UnpickleError e >>= _ = UnpickleError e + NoResult e >>= _ = NoResult e + + +data UnpickleError = ErrorMessage Text + | TraceStep (Text, Text) UnpickleError + | Variants [UnpickleError] + deriving (Show, Typeable) + +instance Exception UnpickleError + +infixl 6 <++> +(<++>) :: (Text, Text) -> UnpickleError -> UnpickleError +(<++>) = TraceStep + +mapUnpickleError :: (UnpickleError -> UnpickleError) + -> UnpickleResult t a + -> UnpickleResult t a +mapUnpickleError f (UnpickleError e) = UnpickleError $ f e +mapUnpickleError _ x = x + +missing :: String -> UnpickleError +missing e = upe $ "Entity not found: " ++ e + +missingE :: String -> UnpickleResult t a +missingE = UnpickleError . missing + +upe :: String -> UnpickleError +upe e = ErrorMessage (Text.pack e) + +showTr :: (Text, Text) -> String +showTr (name, "") = Text.unpack name +showTr (name, extra) = concat [Text.unpack name , " (", Text.unpack extra, ")"] + +printUPE :: UnpickleError -> [String] +printUPE (ErrorMessage m) = [Text.unpack m] +printUPE (TraceStep t es) = ("-> " ++ showTr t) : printUPE es +printUPE (Variants vs) = concat + . zipWith (:) (map (\x -> show x ++ ")") [(1 :: Int)..]) + . map (map ( " " ++)) + $ (printUPE <$> vs) + +ppUnpickleError :: UnpickleError -> String +ppUnpickleError e = "Error while unpickling:\n" + ++ unlines (map (" " ++) (printUPE e)) + +leftoverE :: String -> UnpickleResult t a +leftoverE l = UnpickleError . upe $ "Leftover Entities" ++ if null l then "" else + ": " ++ l +child :: Show a => PU a b -> a -> UnpickleResult t b +child xp v = case unpickleTree xp v of + UnpickleError e -> UnpickleError e + NoResult e -> missingE $ Text.unpack e + Result _ (Just es) -> leftoverE $ show es + Result r Nothing -> Result r Nothing + +child' :: PU t a -> t -> UnpickleResult t1 a +child' xp v = case unpickleTree xp v of + UnpickleError e -> UnpickleError e + NoResult e -> missingE $ Text.unpack e + Result _ (Just _es) -> leftoverE "" + Result r Nothing -> Result r Nothing + +leftover :: Maybe t -> UnpickleResult t () +leftover = Result () + +remList :: [t] -> Maybe [t] +remList [] = Nothing +remList xs = Just xs + +mapError :: (UnpickleError -> UnpickleError) -> PU t a -> PU t a +mapError f xp = PU { unpickleTree = mapUnpickleError f . unpickleTree xp + , pickleTree = pickleTree xp + } + +infixl 6 <++.> +(<++.>) :: (Text, Text) -> UnpickleResult t a -> UnpickleResult t a +(<++.>) s = mapUnpickleError (s <++>) + +infixr 0 +-- | Override the last backtrace level in the error report +() :: (Text, Text) -> PU t a -> PU t a +() tr = mapError (swapStack tr) + where + swapStack ns (TraceStep _s e) = TraceStep ns e + swapStack _ns e = error $ "Can't replace non-trace step: " ++ show e + +() :: Text -> PU t a -> PU t a +() tr = mapError (swapStack tr) + where + swapStack ns (TraceStep (_,s) e) = TraceStep (ns,s) e + swapStack _ns e = error $ "Can't replace non-trace step: " ++ show e + + + +infixr 1 +-- | Add a back trace level to the error report +() :: (Text, Text) -> PU t a -> PU t a +() tr = mapError (tr <++>) + +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], ["\""]] + +instance Cat.Category PU where + id = PU (\t -> Result t Nothing) id + g . f = PU { pickleTree = pickleTree f . pickleTree g + , unpickleTree = \val -> case unpickleTree f val of + UnpickleError e -> UnpickleError e + NoResult e -> NoResult e + Result resf re -> case unpickleTree g resf of + UnpickleError e -> UnpickleError e + NoResult e -> NoResult e + Result _ (Just _) -> leftoverE "" + Result resg Nothing -> Result resg re + } diff --git a/src/Data/XML/Pickle/Tuples.hs b/src/Data/XML/Pickle/Tuples.hs new file mode 100644 --- /dev/null +++ b/src/Data/XML/Pickle/Tuples.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings #-} +module Data.XML.Pickle.Tuples + ( tErr + , getRest + , xp2Tuple + , xp3Tuple + , xp4Tuple + , xp5Tuple + , xp6Tuple + ) + where + +import Control.Applicative ((<$>)) +import Control.Monad +import Data.List +import Data.Text (Text) +import qualified Data.Text as Text +import Data.XML.Pickle.Basic + +-- | Try to extract the remainig elements, fail if there are none +getRest :: UnpickleResult [a] b -> UnpickleResult [a] (b, [a]) +getRest (Result r (Just t)) = Result (r, t) Nothing +getRest (Result r Nothing) = Result (r, []) Nothing +getRest (NoResult e) = missingE $ Text.unpack e +getRest (UnpickleError e) = UnpickleError e + +tErr :: Text -> UnpickleResult t a -> UnpickleResult t a +tErr tr = mapUnpickleError (("tuple", tr) <++>) + +-- | Combines 2 picklers +xp2Tuple :: PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2) +xp2Tuple xp1 xp2 = "xp2Tuple" + PU {pickleTree = \(t1, t2) -> + pickleTree xp1 t1 ++ pickleTree xp2 t2 + , unpickleTree = doUnpickleTree + } where + doUnpickleTree r0 = do + -- The /Either String/ monad + (x1 ,r1) <- tErr "1" . getRest $ unpickleTree xp1 r0 + x2 <- tErr "2" $ unpickleTree xp2 r1 + return (x1,x2) + +-- | Combines 3 picklers +xp3Tuple :: PU [a] a1 -> PU [a] a2 -> PU [a] a3 -> PU [a] (a1, a2, a3) +xp3Tuple xp1 xp2 xp3 = "xp3Tuple" PU {pickleTree = \(t1, t2, t3) -> + pickleTree xp1 t1 + ++ pickleTree xp2 t2 + ++ pickleTree xp3 t3 + , unpickleTree = doUnpickleTree + } where + doUnpickleTree r0 = do + (x1, r1) <- tErr "1" $ getRest $ unpickleTree xp1 r0 + (x2, r2) <- tErr "2" $ getRest $ unpickleTree xp2 r1 + x3 <- tErr "3" $ unpickleTree xp3 r2 + return (x1,x2,x3) + +-- | 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 + = "xp4Tuple" + PU {pickleTree = \(t1, t2, t3, t4) -> + pickleTree xp1 t1 + ++ pickleTree xp2 t2 + ++ pickleTree xp3 t3 + ++ pickleTree xp4 t4 + , unpickleTree = doUnpickleTree + } where + doUnpickleTree r0 = do + (x1 , r1) <- tErr "1" $ getRest $ unpickleTree xp1 r0 + (x2 , r2) <- tErr "2" $ getRest $ unpickleTree xp2 r1 + (x3 , r3) <- tErr "3" $ getRest $ unpickleTree xp3 r2 + x4 <- tErr "4" $ unpickleTree xp4 r3 + return (x1,x2,x3,x4) + +-- | 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 + = "xp5Tuple" + 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 = do + (x1 , r1) <- tErr "1" $ getRest $ unpickleTree xp1 r0 + (x2 , r2) <- tErr "2" $ getRest $ unpickleTree xp2 r1 + (x3 , r3) <- tErr "3" $ getRest $ unpickleTree xp3 r2 + (x4 , r4) <- tErr "4" $ getRest $ unpickleTree xp4 r3 + x5 <- tErr "5" $ unpickleTree xp5 r4 + return (x1,x2,x3,x4,x5) + +-- | 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 + = "xp6Tuple" + 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 = do + (x1 , r1) <- tErr "1" $ getRest $ unpickleTree xp1 r0 + (x2 , r2) <- tErr "2" $ getRest $ unpickleTree xp2 r1 + (x3 , r3) <- tErr "3" $ getRest $ unpickleTree xp3 r2 + (x4 , r4) <- tErr "4" $ getRest $ unpickleTree xp4 r3 + (x5 , r5) <- tErr "5" $ getRest $ unpickleTree xp5 r4 + x6 <- tErr "6" $ unpickleTree xp6 r5 + return (x1,x2,x3,x4,x5,x6) diff --git a/xml-picklers.cabal b/xml-picklers.cabal --- a/xml-picklers.cabal +++ b/xml-picklers.cabal @@ -1,6 +1,6 @@ Cabal-Version: >= 1.2 Name: xml-picklers -Version: 0.3.3 +Version: 0.3.4 Synopsis: XML picklers based on xml-types, ported from hexpat-pickle Description: A library of combinators that allows Haskell data structures to be pickled @@ -31,6 +31,8 @@ , text >= 0.11 , containers >= 0.4 Exposed-Modules: Data.XML.Pickle + Other-Modules: Data.XML.Pickle.Basic + , Data.XML.Pickle.Tuples GHC-Options: -Wall Source-Repository head