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 @@ -16,7 +16,8 @@ -- -- * 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 +-- * Most unpicklers will produce an error when their child unpicklers fail to consume all elements. +-- Use 'xpClean' to discard those elements -- -- 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 @@ -24,10 +25,6 @@ -- 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 @@ -41,9 +38,12 @@ -- /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: @@ -154,6 +154,7 @@ -- The List pickler combinators will pickle lists in the given order -- without any special treatment and unpickle as stated. , xpFindMatches + , xpFindFirst , xpAll , xpSubsetAll , xpAllByNamespace @@ -244,8 +245,15 @@ instance Exception UnpickleError data UnpickleResult t a = UnpickleError UnpickleError - | NoResult Text -- | Not found, description of element - | Result a (Maybe t) -- result and remainder + | 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 @@ -288,9 +296,6 @@ data PU t a = PU { 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 } @@ -346,7 +351,7 @@ pickle :: PU t a -> a -> t pickle = pickleTree --- | unpickle a tree, throws away information concerning cleannes +-- | unpickle a tree unpickle :: PU t a -> t -> Either UnpickleError a unpickle xp x = case unpickleTree xp x of UnpickleError e -> Left e @@ -473,8 +478,9 @@ xpText :: PU Text Text xpText = ("xpText","") xpAssert "Input is empty" (not . Text.null) xpText0 --- | Adapts a list of nodes to a single node. Generally used at the top level of --- an XML document. +-- | Transforms a pickler on Lists to a pickler on single elements. +-- +-- /N.B./ Will error when the given pickler doesn't produce exactly one element xpRoot ::PU [a] b -> PU a b xpRoot pa = ("xpRoot","") PU { unpickleTree = \t -> case unpickleTree pa [t] of @@ -616,7 +622,7 @@ } --- | Apply unpickler to all elements with the given ns. +-- | Apply unpickler to all elements with the given namespace. -- -- Pickles like 'xpAll'. xpAllByNamespace :: Text -> PU [Node] b -> PU [Node] [b] @@ -657,7 +663,7 @@ -> PU [Attribute] a -- ^ pickler for attributes -> PU [Node] n -- ^ pickler for child nodes -> PU [Node] (name,a,n) -xpElemByNamespace ns nameP attrP nodeP = tr ns PU +xpElemByNamespace ns nameP attrP nodeP = PU { unpickleTree = doUnpickleTree , pickleTree = \(name, a,n) -> [NodeElement $ Element (Name (pickleTree nameP name) (Just ns) Nothing) @@ -666,16 +672,23 @@ ] } where doUnpickleTree nodes = case getFirst (nodeElementNSHelper ns) nodes of - Just ((NodeElement (Element name attrs children)), rem) -> + Just ((NodeElement (Element name attrs children)), rem) -> tr name $ do name' <- child nameP (nameLocalName name) attrs' <- child attrP attrs - nodes' <- child nodeP nodes + nodes' <- child nodeP children leftover $ remList rem return (name', attrs', nodes') _ -> NoResult $ "Element with namepspace " `Text.append` ns - tr a = ("xpElemByNamespace", Text.concat [ns, " ; ", a]) + tr a res = case res of + UnpickleError e -> UnpickleError (TraceStep + ( "xpElemByNamespace" + , Text.concat [ ns + , " ; " + , nameLocalName a]) + e) + x -> x nodeElementNSHelper ns (NodeElement (Element n _ _)) = nameNamespace n == Just ns nodeElementNSHelper ns _ = False @@ -683,7 +696,7 @@ -- | Pickler Returns the first found Element untouched -- -- Unpickler wraps element in 'NodeElement' -xpElemVerbatim :: PU [Node] (Element) +xpElemVerbatim :: PU [Node] Element xpElemVerbatim = PU { unpickleTree = doUnpickleTree , pickleTree = \e -> [NodeElement e] @@ -711,7 +724,7 @@ -- | Helper for Elements that don't contain anything xpElemBlank :: Name -> PU [Node] () -xpElemBlank name = xpWrap (const () ) (const ((),())) $ +xpElemBlank name = ("xpElemBlank", "") xpWrap (const () ) (const ((),())) $ xpElem name xpUnit xpUnit -- | When pickling, creates an empty element iff parameter is True @@ -719,7 +732,8 @@ -- 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) +xpElemExists name = ("xpElemBlank", "") + xpWrap (\x -> case x of Nothing -> False; Just _ -> True) (\x -> if x then Just () else Nothing) $ xpOption (xpElemBlank name) @@ -928,6 +942,25 @@ mbToList Nothing = [] mbToList (Just r) = r +-- | Select a single element from the list and apply unpickler to it. +-- +-- Returns no value when no element matches the predicate +-- +-- Fails when the unpickler doesn't return a value +-- +-- When pickling, this is a noop +xpFindFirst :: (t -> Bool) -> PU [t] a -> PU [t] a +xpFindFirst p xp = ("xpFindFirst","") + PU { pickleTree = pickleTree xp + , unpickleTree = \xs -> case break p xs of + (_, []) -> NoResult "entity" + (xs,y:ys) -> do + leftover . remList $ xs ++ ys + child' xp [y] + } + + + xpConst :: a -> PU t () -> PU t a xpConst c xp = ("xpConst" ,"") xpWrap (const c) (const ()) xp @@ -1129,6 +1162,7 @@ xpSnd :: Monoid a => PU t (a, b) -> PU t b xpSnd = xpWrap snd (\y -> (mempty, y)) +-- | Instead of failing the pickler will return no result xpMayFail :: PU t a -> PU t a xpMayFail xp = PU { pickleTree = pickleTree xp , unpickleTree = \v -> case unpickleTree xp v of @@ -1136,7 +1170,7 @@ x -> x } --- | Discard any leftover elements +-- | Run unpickler and consume and discard remaining elements -- -- When pickling, this is a noop xpClean :: PU t a -> PU t a 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.0 +Version: 0.3.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