xml-picklers 0.2.2 → 0.3.0
raw patch · 2 files changed
+412/−309 lines, 2 files
Files
- src/Data/XML/Pickle.hs +407/−307
- xml-picklers.cabal +5/−2
src/Data/XML/Pickle.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, FunctionalDependencies, DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}@@ -84,6 +85,7 @@ -- * Types PU(..) , Attribute+ , UnpickleResult(..) -- * Pickler Invocation , pickle , unpickle@@ -91,17 +93,24 @@ , xpUnit , xpZero , xpThrow+ , xpIso -- * Value-preserving picklers , xpId+ , xpFst+ , xpSnd , xpTrees , xpHead , xpTree , xpText0 , xpText+ , xpString , xpRoot , xpPrim -- * XML specific picklers -- ** Attributes+ , xpAttribute+ , xpAttribute'+ , xpAttribute_ , xpAttr , xpAttrImplied , xpAttrFixed@@ -112,6 +121,7 @@ , xpElemVerbatim , xpElemAttrs , xpElemNodes+ , xpElemText , xpElemBlank , xpElemExists , xpElems@@ -146,6 +156,7 @@ , xpFindMatches , xpAll , xpSubsetAll+ , xpAllByNamespace , xpList0 , xpSeqWhile , xpList@@ -162,10 +173,12 @@ -- ** Wrappers -- *** value wrappers , xpWrap+ , xpConst , xpWrapEither , xpWrapMaybe , xpWrapMaybe_ , xpAssert+ , xpMayFail , xpUnliftElems -- *** Book keeping -- | Change the semantics of picklers@@ -177,12 +190,7 @@ -- 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 -- * Error handling , UnpickleError(..) , ppUnpickleError@@ -192,7 +200,7 @@ , UnresolvedEntityException(..) -- * helper functions , flattenContent-) where+) where import Control.Applicative ((<$>)) import Control.Arrow@@ -200,9 +208,11 @@ import Data.Either import Data.List(partition)-import Data.Monoid(Monoid, mempty)+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.Text (Text)@@ -211,14 +221,12 @@ import Data.XML.Types + data UnpickleError = ErrorMessage Text | TraceStep (Text, Text) UnpickleError | Variants [UnpickleError] deriving (Show, Typeable) -upe :: String -> UnpickleError-upe e = ErrorMessage (Text.pack e)- showTr (name, "") = Text.unpack name showTr (name, extra) = concat [Text.unpack name , " (", Text.unpack extra, ")"] @@ -229,22 +237,64 @@ . (map $ map ( " " ++)) $ (printUPE <$> vs) -ppUnpickleError :: UnpickleError -> Text-ppUnpickleError e = Text.pack $- "Error while unpickling:\n" ++ (unlines $ map (" " ++) (printUPE e))+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+ 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 e = upe $ "Entity not found: " ++ e+missingE = UnpickleError . missing++leftoverE l = UnpickleError . upe $ "Leftover Entities" ++ if null l then "" else+ (": " ++ l)++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' 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 t = Result () t++remList [] = Nothing+remList xs = Just xs++mapUnpickleError f (UnpickleError e) = (UnpickleError $ f e)+mapUnpickleError _ x = x+ data PU t a = PU- { unpickleTree :: t- -> Either UnpickleError (a, (Maybe t, Bool))+ { unpickleTree :: t -> UnpickleResult t a -- ^ Either an error or the return value, -- any remaining input and a Bool value indicating whether -- all nested picklers where clean , pickleTree :: a -> t } -mapError f xp = PU { unpickleTree = mapLeft f . unpickleTree xp+mapError f xp = PU { unpickleTree = mapUnpickleError f . unpickleTree xp , pickleTree = pickleTree xp } @@ -253,6 +303,10 @@ (<++>) :: (Text, Text) -> UnpickleError -> UnpickleError (<++>) s e = TraceStep s e +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@@ -261,7 +315,7 @@ 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@@ -294,31 +348,96 @@ -- | unpickle a tree, throws away information concerning cleannes unpickle :: PU t a -> t -> Either UnpickleError a-unpickle xp x = fst <$> unpickleTree xp x+unpickle xp x = case unpickleTree xp x of+ UnpickleError e -> Left e+ NoResult e -> Left . ErrorMessage $ "Entity not found " `Text.append` e+ Result r _ -> Right r 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 +-- | Doesn't create or consume anything, always succeeds+xpUnit :: PU [a] ()+xpUnit = PU (\x -> Result () (remList x)) (const [])++ -- | Returns everything (remaining), untouched. xpId :: PU a a-xpId = PU (\t -> Right (t, (Nothing,True))) id+xpId = xpIso id id -- | 'xpId' (/compat/) xpTrees :: PU a a xpTrees = xpId +-- | Apply a bijection before pickling / after unpickling+xpWrap :: (a -> b) -> (b -> a) -> PU t a -> PU t b+xpWrap to from xp = ("xpWrap","") <?+>+ PU { unpickleTree = \x -> to <$> unpickleTree xp x+ , pickleTree = pickleTree xp . from+ }++-- | Like xpWrap, but strips Just (and treats Nothing as a failure) during unpickling.+xpWrapMaybe :: (a -> Maybe b) -> (b -> a) -> PU t a -> PU t b+xpWrapMaybe a2b b2a pua = ("xpWrapMaybe","") <?>+ xpWrapMaybe_ "xpWrapMaybe can't encode Nothing" a2b b2a pua++-- | 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 = ("xpWrapMaybe_","") <?+> PU {+ unpickleTree = \t -> case unpickleTree pua t of+ Result val rest ->+ case a2b val of+ Just val' -> Result val' rest+ Nothing -> UnpickleError $ upe errorMsg+ NoResult e -> NoResult e+ UnpickleError e -> UnpickleError e+ , pickleTree = \value -> pickleTree pua (b2a value)+ }+++-- | Lift a pickler. Nothing is returned when the given pickler+-- doesn't return a value (e.g. the element isn't found). Does not affect+-- unpickling errors.+-- Nothing is pickled to mempty+--+-- A typical example is:+--+-- > xpElemAttributes "score" $ xpOption $ xpAttribute "value" xpPrim+--+-- in which @Just 5@ is encoded as @\<score value=\"5\"\/\>@ and @Nothing@+-- as @\<score\/\>@.+xpOption :: PU [t] a -> PU [t] (Maybe a)+xpOption pu = PU { unpickleTree = doUnpickle+ , pickleTree = \mValue ->+ case mValue of+ Just value -> pickleTree pu value+ Nothing -> mempty+ }+ where+ doUnpickle t =+ case unpickleTree pu t of+ Result r t' -> Result (Just r) 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- [] -> Left $ ("xpHead","") <++> upe "No element remaining"- t:ts -> Right (t , (if null ts then Nothing else Just ts, True))+ [] -> UnpickleError $ ("xpHead","")+ <++> upe "No element remaining"+ t:ts -> Result t (if null ts then Nothing else Just ts) , pickleTree = return } @@ -330,24 +449,25 @@ xpText0 :: PU Text Text xpText0 = xpId +-- | Convert text to/from String+xpString :: PU Text String+xpString = ("xpString", "") <?> xpIso Text.unpack Text.pack+ -- | 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 :: Text -> (a -> Bool) -> PU t a -> PU t a-xpAssert err p xp = PU { unpickleTree = \t -> case unpickleTree xp t of- Left e -> Left $ ("xpAssert",err) <++> e- Right (r,c) -> case p r of- True -> Right (r,c)- False -> Left $ assertErr-+xpAssert err p xp = ("xpAssert",err) <?+>+ PU { unpickleTree = \t -> do+ r <- unpickleTree xp t+ unless (p r) $ UnpickleError assertErr+ return r , pickleTree = pickleTree xp } where- assertErr = ("xpAssert", err)- <++> upe ("Assertion failed; " ++ Text.unpack err)-+ assertErr = upe ("Assertion failed; " ++ Text.unpack err) -- | Like 'xpText0', but fails on non-empty input. xpText :: PU Text Text@@ -356,17 +476,17 @@ -- | 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+xpRoot pa = ("xpRoot","") <?+> PU { unpickleTree = \t -> case unpickleTree pa [t] of- Left l -> Left $ ("xpRoot","") <++> l- Right (a,(Nothing,True)) -> Right (a, (Nothing,True ))- Right (a,(_ ,_ )) -> Right (a, (Nothing,False))+ Result x Nothing -> Result x Nothing+ Result x (Just _) -> UnpickleError $ upe "Leftover entities"+ UnpickleError e -> UnpickleError e+ NoResult e -> NoResult e , pickleTree = \t -> case pickleTree pa t of [t1] -> t1 _ -> error "pickler called by xpRoot must output exactly one element" } - getFirst :: (t -> Bool) -> [t] -> Maybe (t, [t]) getFirst _ [] = Nothing getFirst p (x:xs) = case p x of@@ -375,40 +495,43 @@ -- | pickle to/from attribute-xpAttr :: Name -> PU Text a -> PU [Attribute] a-xpAttr name pu = PU+xpAttribute :: Name -> PU Text a -> PU [Attribute] a+xpAttribute name pu = ("xpAttr" , Text.pack $ ppName name) <?+> PU { unpickleTree = doUnpickle , pickleTree = \value -> [(name, [ContentText $ pickleTree pu value])] } where- tr = ("xpAttr" , Text.pack $ ppName name) doUnpickle attrs = case getFirst ((== name) . fst) attrs of- Nothing -> Left $ tr <++> upe ("attribute not found")+ Nothing -> NoResult $ Text.pack $ ppName name Just ((_,[ContentText x]), rem) -> case unpickleTree pu x of- Left e -> Left $ tr <++> e- Right (y,(_,c)) -> let rem' = if null rem then Nothing else Just rem- in Right (y,(rem',c))- _ -> Left $ tr <++> upe ("Unresolved entities in " ++ ppName name ++ ".")+ NoResult e -> missingE $ Text.unpack e+ UnpickleError e -> UnpickleError e+ Result _ (Just e) -> leftoverE $ show e+ Result r Nothing -> Result r (remList rem)+ _ -> UnpickleError $ upe ("Unresolved entities in " ++ ppName name ++ ".") +-- | (/compat/)+xpAttr :: Name -> PU Text a -> PU [Attribute] a+xpAttr = xpAttribute+ -- | Pickle attribute if Just is given, on unpickling return Just <val> when -- the attribute is found, Nothing otherwise+xpAttribute' :: Name -> PU Text a -> PU [Attribute] (Maybe a)+xpAttribute' name pu = xpOption $ xpAttr name pu+ xpAttrImplied :: Name -> PU Text a -> PU [Attribute] (Maybe a)-xpAttrImplied name pu = xpOption $ xpAttr name pu+xpAttrImplied = xpAttribute' -- | 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 =+xpAttribute_ :: Name -> Text -> PU [Attribute] ()+xpAttribute_ 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-+xpAttrFixed :: Name -> Text -> PU [Attribute] ()+xpAttrFixed = xpAttribute_ -- merge successive NodeCotents flattenContent :: [Node] -> [Node]@@ -424,8 +547,8 @@ where nc = NodeContent . ContentText addConcatText [] = id- addConcatText xs = (nc (Text.concat xs) :)-+ 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. -- Once such an element is found, it will commit to it and /fail/ if any of the@@ -434,7 +557,7 @@ -> PU [Attribute] a -- ^ pickler for attributes -> PU [Node] n -- ^ pickler for child nodes -> PU [Node] (a,n)-xpElem name attrP nodeP = PU+xpElem name attrP nodeP = tr <?+> PU { unpickleTree = doUnpickleTree , pickleTree = \(a,n) -> [NodeElement $ Element name (pickleTree attrP a)@@ -442,16 +565,12 @@ ] } where doUnpickleTree nodes = case getFirst (nodeElementNameHelper name) nodes of- Just ((NodeElement (Element _ attrs children)), rem) ->- case unpickleTree attrP attrs of- Left e -> Left $ tr <++> e- Right (x,(_,ca)) -> case unpickleTree nodeP- $ flattenContent children of- Left e -> Left $ tr <++> e- Right (y,(_,cc)) ->- let rem' = if null rem then Nothing else Just rem- in Right ((x,y), (rem' , ca && cc))- _ -> Left $ tr <++> upe "Element not found"+ Just ((NodeElement (Element _ attrs children)), rem) -> do+ as <- ("attrs","") <++.> child attrP attrs+ cs <- ("children","") <++.> child nodeP (flattenContent children)+ leftover $ remList rem+ return (as, cs)+ _ -> NoResult $ Text.pack $ ppName name tr = ("xpElem", Text.pack $ ppName name) @@ -472,6 +591,15 @@ tr = ("xpElems", Text.pack $ ppName name) +-- | 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 = ("xpAll", "") <?+> PU { unpickleTree = doUnpickleTree+ , pickleTree = \xs ->+ concatMap (pickleTree xp) xs+ } where+ doUnpickleTree xs = mapM (child' xp . return) xs+ -- | For unpickling, apply the given pickler to a subset of the elements -- determined by a given predicate --@@ -480,23 +608,33 @@ -> 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- rest' = if null rest then Nothing else Just rest- in- case unpickleTree (xpAll xp) targets of- Left e -> Left e- Right (r, (_, c)) ->- Right (r,(rest', c && not (null rest)))+ let (targets, rest) = partition pred t in+ do+ leftover $ remList rest+ child' (xpAll xp) targets , pickleTree = pickleTree (xpAll $ xp)- } ++-- | Apply unpickler to all elements with the given ns.+--+-- Pickles like 'xpAll'.+xpAllByNamespace :: Text -> PU [Node] b -> PU [Node] [b]+xpAllByNamespace namespace xp = ("xpAllByNamespace",namespace)+ <?> xpSubsetAll helper xp++ where+ helper (NodeElement (Element (Name _local (Just ns) _pre) _ _ ))+ = ns == namespace+ helper _ = 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+xpElemWithName attrP nodeP = ("xpElemWithName", "") <?+> PU { unpickleTree = doUnpickleTree , pickleTree = \(name, a,n) -> [NodeElement $ Element name (pickleTree attrP a)@@ -504,19 +642,12 @@ ] } where doUnpickleTree nodes = case getFirst nodeElementHelper nodes of- Just ((NodeElement (Element name attrs children)), rem) ->- case unpickleTree attrP attrs of- Left e -> Left $ tr <++> e- Right (x,(_,ca)) -> case unpickleTree nodeP $- flattenContent children of- Left e -> Left $ tr <++> e- Right (y,(_,cc)) ->- let rem' = if null rem then Nothing else Just rem- in Right ((name,x,y), (rem' , ca && cc))- _ -> Left $ tr <++> upe "No element found"-- tr = ("xpElemWithName", "")-+ Just ((NodeElement (Element name attrs children)), rem) -> do+ x <- child attrP attrs+ y <- child nodeP $ flattenContent children+ leftover $ remList rem+ return (name, x, y)+ _ -> NoResult "element" nodeElementHelper (NodeElement (Element _ _ _)) = True nodeElementHelper _ = False @@ -526,7 +657,7 @@ -> PU [Attribute] a -- ^ pickler for attributes -> PU [Node] n -- ^ pickler for child nodes -> PU [Node] (name,a,n)-xpElemByNamespace ns nameP attrP nodeP = PU+xpElemByNamespace ns nameP attrP nodeP = tr ns <?+> PU { unpickleTree = doUnpickleTree , pickleTree = \(name, a,n) -> [NodeElement $ Element (Name (pickleTree nameP name) (Just ns) Nothing)@@ -536,34 +667,30 @@ } 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 $ (tr $ ppName name) <++> e- Right r -> Right r- _ -> Left $ (tr "") <++> upe "No element found"+ do+ name' <- child nameP (nameLocalName name)+ attrs' <- child attrP attrs+ nodes' <- child nodeP nodes+ leftover $ remList rem+ return (name', attrs', nodes') - tr a = ("xpElemByNamespace", if null a then ns- else Text.concat [ns, " ; ", Text.pack a])+ _ -> NoResult $ "Element with namepspace " `Text.append` ns+ tr a = ("xpElemByNamespace", Text.concat [ns, " ; ", a]) nodeElementNSHelper ns (NodeElement (Element n _ _)) = nameNamespace n == Just ns nodeElementNSHelper ns _ = False --- | use Element untouched+-- | Pickler Returns the first found Element untouched+--+-- Unpickler wraps element in 'NodeElement' 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","") <++> upe "no element found."+ Just ((NodeElement e@(Element _ _ _)), rem) -> Result e (remList rem)+ _ -> NoResult "element" nodeElementHelper (NodeElement (Element _ _ _)) = True nodeElementHelper _ = False@@ -578,6 +705,10 @@ xpElemNodes name puChildren = xpWrap (snd) (\a -> ((),a)) $ xpElem name xpUnit puChildren +-- | A helper variant of xpElem for elements that contain only character data+xpElemText :: Name -> PU [Node] Text+xpElemText name = xpElemNodes name $ xpContent xpId+ -- | Helper for Elements that don't contain anything xpElemBlank :: Name -> PU [Node] () xpElemBlank name = xpWrap (const () ) (const ((),())) $@@ -585,75 +716,56 @@ -- | When pickling, creates an empty element iff parameter is True ----- When unpickling, checks whether element exists+-- When unpickling, checks whether element exists. Generates an error when the+-- element is not empty 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++-- | Get the first non-element NodeContent from a node xpContent :: PU Text a -> PU [Node] a xpContent xp = ("xpContent","") <?+> 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 l+ doUnpickle nodes = case getFirst nodeContentHelper nodes of -- flatten+ Just ((NodeContent (ContentText t)), rem) -> child xp t Just ((NodeContent (ContentEntity t)), _) ->- Left . upe $ "Unresolved entity" ++ show t ++ "."- _ -> Left $ upe "No content found"+ UnpickleError . upe $ "Unresolved entity" ++ show t ++ "."+ _ -> NoResult "node content" nodeContentHelper (NodeContent _) = True nodeContentHelper _ = False + -- | Unlift a pickler on Nodes to a Pickler on Elements. Nodes generated during -- pickling that are not Elements will be silently discarded xpUnliftElems :: PU [Node] a -> PU [Element] a-xpUnliftElems xp = PU+xpUnliftElems xp = ("xpUnliftElems","") <?+> PU { unpickleTree = doUnpickle , pickleTree = nodesToElems . pickleTree xp } where doUnpickle nodes = case unpickleTree xp (map NodeElement nodes) of- Left e -> Left $ ("xpUnliftElems","") <++> 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))+ UnpickleError e -> UnpickleError e+ NoResult e -> NoResult e+ Result a r -> let r' = case r of+ Nothing -> Nothing+ Just rs' -> case nodesToElems rs' of+ [] -> Nothing+ rs -> Just rs+ in Result a r' 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+-- during unpickling the default value is inserted if the pickler doesn't+-- returna a value xpDefault :: (Eq a) => a -> PU [t] a -> PU [t] a xpDefault df = xpWrap (fromMaybe df)@@ -661,34 +773,30 @@ . xpOption --- | Attempt to use a pickler. On failure, return a default value.+-- | Attempt to use a pickler. Return a default value when the pickler doesn't+-- return anything (Doesn't touch on UnpickleError) -- -- 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- }+xpWithDefault a pa = PU { pickleTree = pickleTree pa+ , unpickleTree = \v -> case unpickleTree pa v of+ Result r t -> Result r t+ NoResult _ -> Result a (Just v)+ UnpickleError e -> UnpickleError e+ } + -- 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 [])-+-- | 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 tr = mapLeft (("tuple", tr) <++>)+tErr tr = mapUnpickleError (("tuple", tr) <++>) -- | Combines 2 picklers xp2Tuple :: PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2)@@ -699,10 +807,11 @@ } where doUnpickleTree r0 = do -- The /Either String/ monad- (x1 ,(r1,c1)) <- tErr "1" $ getRest <$> unpickleTree xp1 r0- (x2 ,(r ,c2)) <- tErr "2" $ unpickleTree xp2 r1- return ((x1,x2),(r,c1 && c2))+ (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@@ -720,10 +829,10 @@ , unpickleTree = doUnpickleTree } where doUnpickleTree r0 = do- (x1 ,(r1,c1)) <- tErr "1" $ getRest <$> unpickleTree xp1 r0- (x2 ,(r2,c2)) <- tErr "2" $ getRest <$> unpickleTree xp2 r1- (x3 ,(r ,c3)) <- tErr "3" $ unpickleTree xp3 r2- return ((x1,x2,x3),(r, c1 && c2 && c3))+ (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)@@ -742,11 +851,11 @@ , unpickleTree = doUnpickleTree } where doUnpickleTree r0 = do- (x1 ,(r1, c1)) <- tErr "1" $ getRest <$> unpickleTree xp1 r0- (x2 ,(r2, c2)) <- tErr "2" $ getRest <$> unpickleTree xp2 r1- (x3 ,(r3, c3)) <- tErr "3" $ getRest <$> unpickleTree xp3 r2- (x4 ,(r , c4)) <- tErr "4" $ unpickleTree xp4 r3- return ((x1,x2,x3,x4),(r, c1 && c2 && c3 && c4))+ (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@@ -762,12 +871,12 @@ , unpickleTree = doUnpickleTree } where doUnpickleTree r0 = do- (x1 ,(r1,c1)) <- tErr "1" $ getRest <$> unpickleTree xp1 r0- (x2 ,(r2,c2)) <- tErr "2" $ getRest <$> unpickleTree xp2 r1- (x3 ,(r3,c3)) <- tErr "3" $ getRest <$> unpickleTree xp3 r2- (x4 ,(r4,c4)) <- tErr "4" $ getRest <$> unpickleTree xp4 r3- (x5 ,(r ,c5)) <- tErr "5" $ unpickleTree xp5 r4- return ((x1,x2,x3,x4,x5),(r, c1 && c2 && c3 && c4 && c5))+ (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@@ -785,21 +894,21 @@ , unpickleTree = doUnpickleTree } where doUnpickleTree r0 = do- (x1 ,(r1,c1)) <- tErr "1" $ getRest <$> unpickleTree xp1 r0- (x2 ,(r2,c2)) <- tErr "2" $ getRest <$> unpickleTree xp2 r1- (x3 ,(r3,c3)) <- tErr "3" $ getRest <$> unpickleTree xp3 r2- (x4 ,(r4,c4)) <- tErr "4" $ getRest <$> unpickleTree xp4 r3- (x5 ,(r5,c5)) <- tErr "5" $ getRest <$> unpickleTree xp5 r4- (x6 ,(r ,c6)) <- tErr "6" $ {- return-} unpickleTree xp6 r5- return ((x1,x2,x3,x4,x5,x6),(r, c1 && c2 && c3 && c4 && c5 && c6))+ (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 , unpickleTree = \xs -> case unpickleTree xp xs of- Left e -> Left e- Right (r,(_,c)) -> Right (r,(Just xs,c))+ Result r _ -> Result r (Just xs)+ x -> x } -- | Noop when pickling@@ -809,29 +918,26 @@ xpIsolate xp = ("xpIsolate","") <?+> PU { pickleTree = pickleTree xp , unpickleTree = \xs -> case xs of- [] -> Left $ upe "No elements left"+ [] -> NoResult "entity" (x:xs) -> case unpickleTree xp [x] of- Left l -> Left l- Right (v,(r,c)) -> Right (v,(handleRest r xs, c))+ Result r t -> Result r (remList $ mbToList t ++ xs)+ NoResult e -> missingE $ Text.unpack e+ x -> x } 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 = ("xpWrap","") <?+>- PU { unpickleTree = \x -> (first to) <$> unpickleTree xp x- , pickleTree = pickleTree xp . from- }+xpConst :: a -> PU t () -> PU t a+xpConst c xp = ("xpConst" ,"") <?> xpWrap (const c) (const ()) xp --- | Convert XML text content \<-\> any type that implements 'Read' and 'Show'.+-- | Convert text to/from 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 $ ("xpPrim","") <++>+ [] -> UnpickleError $ ("xpPrim","") <++> upe ("Couldn't read " ++ show x ++ ".")- (r,rest):_ -> Right (r,(Nothing, True))+ (r,rest):_ -> Result r (Text.pack <$> remList rest) , pickleTree = Text.pack . show } @@ -844,24 +950,11 @@ 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 [b] a -> PU [b] [a]-xpAll 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 e -> Left e- Right (r,(_,c)) -> Right (r, c)- in case ls of- [] -> Right (fst <$> rs , (Nothing, and $ snd <$> rs))- (_:_) -> Left $ Variants ls+ NoResult _ -> Left x+ Result r Nothing -> Right $ Result r Nothing+ Result r (Just _) -> Right $ leftoverE ""+ UnpickleError e -> Right $ UnpickleError e+ in leftover (remList ls) >> sequence rs -- | 'xpAll' (/compat/) xpList0 :: PU [a] b -> PU [a] [b]@@ -878,19 +971,21 @@ -- | When unpickling, sucessively applies pickler to single elements until it--- fails; returns all matched elements.+-- doesn't return anything; returns all matched elements. xpSeqWhile :: PU [a] b -> PU [a] [b]-xpSeqWhile pu = PU {- unpickleTree = Right . doUnpickle,- pickleTree = \t -> (pickleTree pu) =<< t- }+xpSeqWhile pu = ("xpSeqWhile", "") <?+> PU {+ unpickleTree = doUnpickle+ , pickleTree = concatMap $ pickleTree pu+ } where- doUnpickle [] = ([],(Nothing,True))+ doUnpickle [] = Result [] Nothing 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))+ Result val _ -> case doUnpickle rem of+ Result xs r -> Result (val:xs) r+ e -> e+ NoResult _ -> Result [] (Just es)+ UnpickleError e -> UnpickleError e -- | 'xpSeqWhile' (/compat/) xpList :: PU [a] b -> PU [a] [b]@@ -916,41 +1011,29 @@ (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 a2b b2a pua = ("xpWrapMaybe","") <?>- xpWrapMaybe_ "xpWrapMaybe can't encode Nothing" a2b b2a pua --- | 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 $ ("xpWrapMaybe_","") <++> upe 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 :: Show e => (a -> Either e b) -> (b -> a) -> PU t a -> PU t b xpWrapEither a2b b2a pua = ("xpWrapEither","") <?+> PU { unpickleTree = \t -> case unpickleTree pua t of- Right (val, rest) -> mapLeft upe $ (flip (,) rest) <$> a2b val- Left err -> Left err,+ Result val rest -> case a2b val of+ Left e -> UnpickleError . upe $ "Function returned Left "+ ++ show e+ Right r -> Result r rest+ NoResult e -> NoResult e+ UnpickleError e -> UnpickleError e+ , 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).+-- | 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. (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.@@ -962,21 +1045,17 @@ 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 $ ("xpAlt","") <++> Variants errs- Right r -> Right r-+ eitherResult (Result r t) = Right (Result r t)+ 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+ (es, []) -> ("xpAlt", "") <++.> UnpickleError (Variants es) --- | Try the left pickler first and if that failes the right one.--- wrapping the result in Left or Right, respectively+-- | Try the left pickler first and if that doesn't produce anything 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)@@ -988,22 +1067,38 @@ } where doUnpickle t = case unpickleTree xpl t of- Right (val, rst) -> Right (Left val, rst)- Left errl -> case unpickleTree xpr t of- Right (val, rst) -> Right (Right val, rst)- Left errr -> Left $ ("xpEither","")- <++> Variants [errl, errr]+ Result r t -> Result (Left r) t+ NoResult e1 -> case unpickleTree xpr t of+ Result r t -> Result (Right r) t+ NoResult e2 -> UnpickleError $ ("xpEither","")+ <++> Variants [ missing $ Text.unpack e1+ , missing $ Text.unpack e2+ ]+ UnpickleError e -> UnpickleError $ ("xpEither","Right")+ <++> e+ UnpickleError e -> UnpickleError $ ("xpEither","Left")+ <++> e -- | 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 $ ("xpTryCatch","")- <++> Variants [err1, err2]+ Result val1 rest -> Result val1 rest+ NoResult e1 -> case unpickleTree pu2 t of+ Result val2 rest -> Result val2 rest+ NoResult e2 -> NoResult $ Text.concat [e1, " / ", e2]+ UnpickleError e2 -> UnpickleError $ ("xpTryCatch","Right")+ <++> e2+ UnpickleError e1 -> case unpickleTree pu2 t of+ Result val2 rest -> Result val2 rest+ NoResult e2 -> UnpickleError+ $ Variants [ e1+ , upe $ " / not found:"+ ++ Text.unpack e2+ ]+ UnpickleError e2 -> UnpickleError $ ("xpTryCatch","")+ <++> Variants [e1, e2] , pickleTree = pickleTree pu1 } @@ -1014,47 +1109,52 @@ xpZero = ("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 :: Monoid m+ => String -- ^ Error message+ -> PU m a xpThrow msg = PU- { unpickleTree = \t -> Left $ ("xpThrow",Text.pack msg) <++> upe msg- , pickleTree = const []+ { unpickleTree = \t -> UnpickleError $ ("xpThrow",Text.pack msg) <++> upe msg+ , pickleTree = const mempty } --- | When unpickling check that all elements have been consumed after this--- pickler, fails otherwise+-- | 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++xpFst :: Monoid b => PU t (a, b) -> PU t a+xpFst = xpWrap fst (\x -> (x, mempty))++xpSnd :: Monoid a => PU t (a, b) -> PU t b+xpSnd = xpWrap snd (\y -> (mempty, y))++xpMayFail :: PU t a -> PU t a+xpMayFail xp = PU { pickleTree = pickleTree xp+ , unpickleTree = \v -> case unpickleTree xp v of+ UnpickleError _ -> NoResult "failed with xpMayFail"+ x -> x+ }++-- | Discard any leftover elements -- -- 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","") <++> upe "not clean"-+ Result r _ -> Result r Nothing+ e -> e , 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","") <++> upe "not clean"- Right (_, (Nothing, False)) ->- Left $ ("xpRecursiveClean","") <++> upe "not recursively 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))+ UnpickleError e -> UnpickleError e+ NoResult e -> NoResult e+ Result resf rem -> case unpickleTree g resf of+ UnpickleError e -> UnpickleError e+ NoResult e -> NoResult e+ Result _ (Just _) -> leftoverE ""+ Result resg Nothing -> Result resg rem }
xml-picklers.cabal view
@@ -1,6 +1,6 @@ Cabal-Version: >= 1.2 Name: xml-picklers-Version: 0.2.2+Version: 0.3.0 Synopsis: XML picklers based on xml-types, ported from hexpat-pickle Description: A library of combinators that allows Haskell data structures to be pickled@@ -8,7 +8,10 @@ . Release history .- [0.2] Error system overhaul. New picklers: @xpSubsetAll@, @xpElems@+ [0.3] Changed the Result type of unpicklers. Unpicklers now fail by default when+ there are remaining elements+ .+ [0.2] Error system overhaul . [0.1] Initial release Category: XML