xml-picklers 0.3.2 → 0.3.3
raw patch · 2 files changed
+99/−72 lines, 2 files
Files
- src/Data/XML/Pickle.hs +97/−71
- xml-picklers.cabal +2/−1
src/Data/XML/Pickle.hs view
@@ -1,6 +1,10 @@ {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances,- UndecidableInstances, FunctionalDependencies, DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} -- | This module provides XML picklers that plug into the xml tree of the@@ -94,6 +98,7 @@ , xpZero , xpThrow , xpIso+ , xpPartial -- * Value-preserving picklers , xpId , xpFst@@ -114,6 +119,7 @@ , xpAttr , xpAttrImplied , xpAttrFixed+ , xpAddFixedAttr -- ** Elements , xpElem , xpElemWithName@@ -162,6 +168,7 @@ , xpList0 , xpSeqWhile , xpList+ , xpListMinLen -- *** Tuples -- | Tuple combinators apply their picklers from left to right , xp2Tuple@@ -210,13 +217,13 @@ import Data.Either import Data.List(partition)-import Data.Monoid(Monoid, mempty, mappend) import Data.Char(isSpace) import Control.Exception import Control.Monad 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@@ -229,19 +236,21 @@ | 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..])- . (map $ map ( " " ++))+ . zipWith (:) (map (\x -> show x ++ ")") [(1 :: Int)..])+ . map (map ( " " ++)) $ (printUPE <$> vs) ppUnpickleError :: UnpickleError -> String ppUnpickleError e = "Error while unpickling:\n"- ++ (unlines $ map (" " ++) (printUPE e))+ ++ unlines (map (" " ++) (printUPE e)) instance Exception UnpickleError @@ -269,30 +278,40 @@ 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)-+ ": " ++ 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 _ (Just _es) -> leftoverE "" Result r Nothing -> Result r Nothing -leftover t = Result () t+leftover :: Maybe t -> UnpickleResult t ()+leftover = Result () +remList :: [t] -> Maybe [t] remList [] = Nothing remList xs = Just xs -mapUnpickleError f (UnpickleError e) = (UnpickleError $ f e)+mapUnpickleError :: (UnpickleError -> UnpickleError)+ -> UnpickleResult t a+ -> UnpickleResult t a+mapUnpickleError f (UnpickleError e) = UnpickleError $ f e mapUnpickleError _ x = x data PU t a = PU@@ -300,6 +319,7 @@ , pickleTree :: a -> t } +mapError :: (UnpickleError -> UnpickleError) -> PU t a -> PU t a mapError f xp = PU { unpickleTree = mapUnpickleError f . unpickleTree xp , pickleTree = pickleTree xp }@@ -307,7 +327,7 @@ infixl 6 <++> (<++>) :: (Text, Text) -> UnpickleError -> UnpickleError-(<++>) s e = TraceStep s e+(<++>) = TraceStep infixl 6 <++.> (<++.>) :: (Text, Text) -> UnpickleResult t a -> UnpickleResult t a@@ -318,21 +338,21 @@ (<?>) :: (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+ 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+ 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)+(<?+>) tr = mapError (tr <++>) data UnresolvedEntityException = UnresolvedEntityException deriving (Typeable, Show)@@ -363,19 +383,25 @@ for :: [a] -> (a -> b) -> [b] for = flip map --mapLeft _ (Right r) = Right r-mapLeft f (Left l ) = Left $ f l- type Attribute = (Name,[Content]) -- | Isomorphic pickler xpIso :: (a -> b) -> (b -> a) -> PU a b xpIso f g = PU (\t -> Result (f t) Nothing) g +xpPartial :: (a -> Either Text b)+ -> (b -> a)+ -> PU a b+xpPartial f g = ("xpEither", "") <?+>+ PU { pickleTree = g+ , unpickleTree = \v -> case f v of+ Left e -> UnpickleError $ ErrorMessage e+ Right r -> Result r Nothing+ }+ -- | Doesn't create or consume anything, always succeeds xpUnit :: PU [a] ()-xpUnit = PU (\x -> Result () (remList x)) (const [])+xpUnit = PU (Result () . remList) (const []) -- | Returns everything (remaining), untouched.@@ -435,7 +461,7 @@ Nothing -> UnpickleError $ upe errorMsg NoResult e -> NoResult e UnpickleError e -> UnpickleError e- , pickleTree = \value -> pickleTree pua (b2a value)+ , pickleTree = pickleTree pua . b2a } @@ -461,12 +487,12 @@ doUnpickle t = case unpickleTree pu t of Result r t' -> Result (Just r) t'- NoResult e -> Result Nothing (remList t)+ NoResult _e -> Result Nothing (remList t) UnpickleError e -> UnpickleError e -- | return one element, untouched xpHead :: PU [a] a-xpHead = PU {unpickleTree = \t -> case t of+xpHead = PU {unpickleTree = \t' -> case t' of [] -> UnpickleError $ ("xpHead","") <++> upe "No element remaining" t:ts -> Result t (if null ts then Nothing else Just ts)@@ -512,7 +538,7 @@ xpRoot pa = ("xpRoot","") <?+> PU { unpickleTree = \t -> case unpickleTree pa [t] of Result x Nothing -> Result x Nothing- Result x (Just _) -> UnpickleError $ upe "Leftover entities"+ Result _x (Just _) -> UnpickleError $ upe "Leftover entities" UnpickleError e -> UnpickleError e NoResult e -> NoResult e , pickleTree = \t -> case pickleTree pa t of@@ -524,7 +550,7 @@ getFirst _ [] = Nothing getFirst p (x:xs) = case p x of True -> Just (x,xs)- False -> (second (x:)) <$> getFirst p xs+ False -> second (x:) <$> getFirst p xs -- | pickle to/from attribute@@ -536,11 +562,11 @@ where doUnpickle attrs = case getFirst ((== name) . fst) attrs of Nothing -> NoResult $ Text.pack $ ppName name- Just ((_,[ContentText x]), rem) -> case unpickleTree pu x of+ Just ((_,[ContentText x]), rem') -> case unpickleTree pu x of NoResult e -> missingE $ Text.unpack e UnpickleError e -> UnpickleError e Result _ (Just e) -> leftoverE $ show e- Result r Nothing -> Result r (remList rem)+ Result r Nothing -> Result r (remList rem') _ -> UnpickleError $ upe ("Unresolved entities in " ++ ppName name ++ ".") -- | (/compat/)@@ -580,7 +606,7 @@ where nc = NodeContent . ContentText addConcatText [] = id- addConcatText xs = let txt = Text.concat xs in+ addConcatText xs' = let txt = Text.concat xs' in if Text.all isSpace txt then id else (nc txt :) -- | When unpickling, tries to find the first element with the supplied name.@@ -598,16 +624,16 @@ ] } where doUnpickleTree nodes = case getFirst (nodeElementNameHelper name) nodes of- Just ((NodeElement (Element _ attrs children)), rem) -> do+ Just (NodeElement (Element _ attrs children), rem') -> do as <- ("attrs","") <++.> child attrP attrs cs <- ("children","") <++.> child nodeP (flattenContent children)- leftover $ remList rem+ leftover $ remList rem' return (as, cs) _ -> NoResult $ Text.pack $ ppName name tr = ("xpElem", Text.pack $ ppName name) - nodeElementNameHelper name (NodeElement (Element n _ _)) = n == name+ nodeElementNameHelper name' (NodeElement (Element n _ _)) = n == name' nodeElementNameHelper _ _ = False -- | Handle all elements with a given name. The unpickler will fail when any of@@ -628,10 +654,9 @@ -- fails if any of them don't match xpAll :: PU [a] b -> PU [a] [b] xpAll xp = ("xpAll", "") <?+> PU { unpickleTree = doUnpickleTree- , pickleTree = \xs ->- concatMap (pickleTree xp) xs+ , pickleTree = concatMap (pickleTree xp) } where- doUnpickleTree xs = mapM (child' xp . return) xs+ doUnpickleTree = mapM (child' xp . return) -- | For unpickling, apply the given pickler to a subset of the elements -- determined by a given predicate@@ -640,12 +665,12 @@ xpSubsetAll :: (a -> Bool) -- ^ predicate to select the subset -> PU [a] b -- ^ pickler to apply on the subset -> PU [a] [b]-xpSubsetAll pred xp = ("xpSubsetAll","") <?+> PU { unpickleTree = \t ->- let (targets, rest) = partition pred t in+xpSubsetAll p xp = ("xpSubsetAll","") <?+> PU { unpickleTree = \t ->+ let (targets, rest) = partition p t in do leftover $ remList rest child' (xpAll xp) targets- , pickleTree = pickleTree (xpAll $ xp)+ , pickleTree = pickleTree $ xpAll xp } @@ -675,13 +700,13 @@ ] } where doUnpickleTree nodes = case getFirst nodeElementHelper nodes of- Just ((NodeElement (Element name attrs children)), rem) -> do+ Just (NodeElement (Element name attrs children), rem') -> do x <- child attrP attrs y <- child nodeP $ flattenContent children- leftover $ remList rem+ leftover $ remList rem' return (name, x, y) _ -> NoResult "element"- nodeElementHelper (NodeElement (Element _ _ _)) = True+ nodeElementHelper (NodeElement Element{}) = True nodeElementHelper _ = False -- | find element by name space, prefixes are ignored@@ -699,12 +724,12 @@ ] } where doUnpickleTree nodes = case getFirst (nodeElementNSHelper ns) nodes of- Just ((NodeElement (Element name attrs children)), rem) -> tr name $+ Just (NodeElement (Element name attrs children), rem') -> tr name $ do name' <- child nameP (nameLocalName name) attrs' <- child attrP attrs nodes' <- child nodeP children- leftover $ remList rem+ leftover $ remList rem' return (name', attrs', nodes') _ -> NoResult $ "Element with namepspace " `Text.append` ns@@ -717,8 +742,8 @@ e) x -> x - nodeElementNSHelper ns (NodeElement (Element n _ _)) = nameNamespace n == Just ns- nodeElementNSHelper ns _ = False+ nodeElementNSHelper ns' (NodeElement (Element n _ _)) = nameNamespace n == Just ns'+ nodeElementNSHelper _ns _ = False -- | Pickler Returns the first found Element untouched --@@ -729,20 +754,20 @@ , pickleTree = \e -> [NodeElement e] } where doUnpickleTree nodes = case getFirst nodeElementHelper nodes of- Just ((NodeElement e@(Element _ _ _)), rem) -> Result e (remList rem)+ Just (NodeElement e@Element{}, re) -> Result e (remList re) _ -> NoResult "element" - nodeElementHelper (NodeElement (Element _ _ _)) = True+ 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,())) $+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)) $+xpElemNodes name puChildren = xpWrap snd (\a -> ((),a)) $ xpElem name xpUnit puChildren -- | A helper variant of xpElem for elements that contain only character data@@ -772,8 +797,8 @@ , pickleTree = return . NodeContent . ContentText . pickleTree xp } where doUnpickle nodes = case getFirst nodeContentHelper nodes of -- flatten- Just ((NodeContent (ContentText t)), rem) -> child xp t- Just ((NodeContent (ContentEntity t)), _) ->+ Just (NodeContent (ContentText t), _re) -> child xp t+ Just (NodeContent (ContentEntity t), _) -> UnpickleError . upe $ "Unresolved entity" ++ show t ++ "." _ -> NoResult "node content" @@ -835,8 +860,9 @@ 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)+getRest (UnpickleError e) = UnpickleError e +tErr :: Text -> UnpickleResult t a -> UnpickleResult t a tErr tr = mapUnpickleError (("tuple", tr) <++>) -- | Combines 2 picklers@@ -958,14 +984,13 @@ xpIsolate :: PU [t] a -> PU [t] a xpIsolate xp = ("xpIsolate","") <?+> PU { pickleTree = pickleTree xp- , unpickleTree = \xs -> case xs of+ , unpickleTree = \xs' -> case xs' of [] -> NoResult "entity" (x:xs) -> case unpickleTree xp [x] of Result r t -> Result r (remList $ mbToList t ++ xs) NoResult e -> missingE $ Text.unpack e- x -> x+ y -> y } where- handleRest r xs = case mbToList r ++ xs of [] -> Nothing; rs -> Just rs mbToList Nothing = [] mbToList (Just r) = r @@ -981,9 +1006,9 @@ PU { pickleTree = pickleTree xp , unpickleTree = \xs -> case break p xs of (_, []) -> NoResult "entity"- (xs,y:ys) -> do- leftover . remList $ xs ++ ys- child' xp [y]+ (ys,z:zs) -> do+ leftover . remList $ ys ++ zs+ child' xp [z] } -- | Ignore input/output and replace with constant values@@ -1011,7 +1036,7 @@ case unpickleTree xp [x] of NoResult _ -> Left x Result r Nothing -> Right $ Result r Nothing- Result r (Just _) -> Right $ leftoverE ""+ Result _r (Just _) -> Right $ leftoverE "" UnpickleError e -> Right $ UnpickleError e in leftover (remList ls) >> sequence rs @@ -1019,7 +1044,7 @@ xpList0 :: PU [a] b -> PU [a] [b] xpList0 = xpAll --- | Like xpList, but only succeed during deserialization if at least a+-- | Like xpList, but only succeed during unpickling if at least a -- minimum number of elements are unpickled. xpListMinLen :: Int -> PU [a] b -> PU [a] [b] xpListMinLen ml = xpWrapEither testLength id . xpList@@ -1038,9 +1063,9 @@ } where doUnpickle [] = Result [] Nothing- doUnpickle es@(elt:rem) =+ doUnpickle es@(elt:re) = case unpickleTree pu [elt] of- Result val _ -> case doUnpickle rem of+ Result val _ -> case doUnpickle re of Result xs r -> Result (val:xs) r e -> e NoResult _ -> Result [] (Just es)@@ -1086,7 +1111,7 @@ NoResult e -> NoResult e UnpickleError e -> UnpickleError e ,- pickleTree = \value -> pickleTree pua (b2a value)+ pickleTree = pickleTree pua . b2a } -- | Execute one of a list of picklers. The /selector function/ is used during@@ -1101,17 +1126,18 @@ -> PU t a xpAlt selector picklers = PU { unpickleTree = doUnpickle,- pickleTree = \value -> pickleTree (picklers !! (selector value)) value+ pickleTree = \value -> pickleTree (picklers !! selector value) value } where eitherResult (Result r t) = Right (Result r t)- eitherResult (UnpickleError e) = Left $ e+ eitherResult (UnpickleError e) = Left e eitherResult (NoResult e) = Left . missing $ Text.unpack e splitResults v = partitionEithers $ map (eitherResult . flip unpickleTree v) picklers doUnpickle v = case splitResults v of- (_, (Result r t):_) -> Result r t+ (_, Result r t:_) -> Result r t (es, []) -> ("xpAlt", "") <++.> UnpickleError (Variants es)+ _ -> error "xpAlt: splitResults returned impossible result" -- | Try the left pickler first and if that doesn't produce anything the right -- one. wrapping the result in Left or Right, respectively@@ -1126,9 +1152,9 @@ } where doUnpickle t = case unpickleTree xpl t of- Result r t -> Result (Left r) t+ Result r s -> Result (Left r) s NoResult e1 -> case unpickleTree xpr t of- Result r t -> Result (Right r) t+ Result r s -> Result (Right r) s NoResult e2 -> UnpickleError $ ("xpEither","") <++> Variants [ missing $ Text.unpack e1 , missing $ Text.unpack e2@@ -1172,7 +1198,7 @@ => String -- ^ Error message -> PU m a xpThrow msg = PU- { unpickleTree = \t -> UnpickleError $ ("xpThrow",Text.pack msg) <++> upe msg+ { unpickleTree = \_ -> UnpickleError $ ("xpThrow",Text.pack msg) <++> upe msg , pickleTree = const mempty } @@ -1212,9 +1238,9 @@ , unpickleTree = \val -> case unpickleTree f val of UnpickleError e -> UnpickleError e NoResult e -> NoResult e- Result resf rem -> case unpickleTree g resf of+ Result resf re -> case unpickleTree g resf of UnpickleError e -> UnpickleError e NoResult e -> NoResult e Result _ (Just _) -> leftoverE ""- Result resg Nothing -> Result resg rem+ Result resg Nothing -> Result resg re }
xml-picklers.cabal view
@@ -1,6 +1,6 @@ Cabal-Version: >= 1.2 Name: xml-picklers-Version: 0.3.2+Version: 0.3.3 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,7 @@ , text >= 0.11 , containers >= 0.4 Exposed-Modules: Data.XML.Pickle+ GHC-Options: -Wall Source-Repository head type: git