xml-picklers 0.3.4 → 0.3.5
raw patch · 5 files changed
+620/−191 lines, 5 filesdep +Cabaldep +QuickCheckdep +tastydep ~basedep ~textdep ~xml-types
Dependencies added: Cabal, QuickCheck, tasty, tasty-hunit, tasty-quickcheck, xml-picklers
Dependency ranges changed: base, text, xml-types
Files
- src/Data/XML/Pickle.hs +197/−172
- src/Data/XML/Pickle/Basic.hs +9/−8
- src/Data/XML/Pickle/Tuples.hs +7/−10
- tests/Tests.hs +389/−0
- xml-picklers.cabal +18/−1
src/Data/XML/Pickle.hs view
@@ -7,44 +7,47 @@ {-# LANGUAGE 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.+-- | 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'@+-- * 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+-- * Wrappers like 'xpWrap' are uncurried -- -- * There are no lazy unpicklers ----- * Most unpicklers will produce an error when their child unpicklers fail to consume all elements.--- Use 'xpClean' to discard those elements+-- * 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--- 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.+-- 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. -- -- 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 first element doesn't match. This is why the target type often is 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@.+-- 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+-- /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:+-- When unpickling, the following 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 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 --@@ -80,26 +83,33 @@ -- -- Program output would be an xml-value equivalent to: ----- > <people><person name="Dave" age="27">A fat thin man with long short hair</person>--- > <person name="Jane" age="21">Lives in a white house with green windows</person></people>+-- > <people>+-- > <person name="Dave" age="27">+-- > A fat thin man with long short hair+-- > </person>+-- > <person name="Jane" age="21">+-- > Lives in a white house with green windows+-- > </person>+-- > </people> ----- Functions 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 PU(..) , Attribute , UnpickleResult(..)- -- * Pickler Invocation+ -- * Pickler invocation , pickle , unpickle- -- * Primitive picklers+ -- * Primitive picklers , xpUnit , xpZero , xpThrow , xpIso , xpPartial- -- * Value-preserving picklers+ -- * Value-preserving picklers , xpId , xpFst , xpSnd@@ -120,7 +130,7 @@ , xpAttrImplied , xpAttrFixed , xpAddFixedAttr- -- ** Elements+ -- ** Elements , xpElem , xpElemWithName , xpElemByNamespace@@ -131,11 +141,11 @@ , xpElemBlank , xpElemExists , xpElems- -- ** Character Content+ -- ** Character Content , xpContent , xpBool- -- * Pickler combinators- -- ** choice+ -- * Pickler combinators+ -- ** Choice , xpOption , xpDefault , xpWithDefault@@ -144,22 +154,20 @@ , xpChoice , xpEither , xpTryCatch- -- ** sequencing- -- |- -- /NB/ The sequencing operations /do not/ enforce any order on the+ -- ** 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.+ -- 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'-+ -- 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+ -- | The List pickler combinators will pickle lists in the given order -- without any special treatment and unpickle as stated. , xpFindMatches , xpFindFirst@@ -182,7 +190,7 @@ , xp5Tuple , xp6Tuple -- ** Wrappers- -- *** value wrappers+ -- *** Value wrappers , xpWrap , xpConst , xpWrapEither@@ -191,16 +199,14 @@ , xpAssert , xpMayFail , xpUnliftElems- -- *** Book keeping+ -- *** Bookkeeping -- | 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+ -- | 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. , xpClean -- * Error handling , UnpickleError(..)@@ -210,7 +216,7 @@ , (<?>) , (<??>) , UnresolvedEntityException(..)- -- * helper functions+ -- * Helper functions , flattenContent , tErr , getRest@@ -233,24 +239,23 @@ import Data.XML.Pickle.Tuples import Data.XML.Pickle.Basic --- | pickle a Tree+-- | Pickle a tree. pickle :: PU t a -> a -> t pickle = pickleTree --- | unpickle a tree+-- | Unpickle a tree. unpickle :: PU t a -> t -> Either UnpickleError a 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 type Attribute = (Name,[Content]) --- | Isomorphic pickler+-- | Isomorphic pickler. xpIso :: (a -> b) -> (b -> a) -> PU a b xpIso f g = PU (\t -> Result (f t) Nothing) g @@ -264,7 +269,7 @@ Right r -> Result r Nothing } --- | Doesn't create or consume anything, always succeeds+-- | Doesn't create or consume anything, always succeeds. xpUnit :: PU [a] () xpUnit = PU (Result () . remList) (const []) @@ -273,19 +278,20 @@ xpId :: PU a a xpId = xpIso id id --- | 'xpId' (/compat/)+-- | 'xpId'. (/compat/) xpTrees :: PU a a xpTrees = xpId -- | Converts Booleans to XML boolean values ----- * true and 1 are read as True+-- * \"true\" and \"1\" are read as @True@ ----- * false and 0 are read as False+-- * \"false\" and \"0\" are read as @False@ ----- * all other values generate an unpickle error+-- * All other values generate an unpickle error ----- Will always generate true or false (not 0 or 1) when pickling+-- Will always generate \"true\" or \"false\" (not \"0\" or \"1\") when+-- pickling. xpBool :: PU Text Bool xpBool = ("xpBool" ,"") <?+> PU { unpickleTree =@@ -303,20 +309,21 @@ False -> "false" } --- | Apply a bijection before pickling / after unpickling+-- | 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.+-- | 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.+-- | 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@@ -329,11 +336,9 @@ , pickleTree = pickleTree pua . b2a } ---- | 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+-- | 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: --@@ -355,7 +360,7 @@ NoResult _e -> Result Nothing (remList t) UnpickleError e -> UnpickleError e --- | return one element, untouched+-- | Return one element, untouched. xpHead :: PU [a] a xpHead = PU {unpickleTree = \t' -> case t' of [] -> UnpickleError $ ("xpHead","")@@ -364,22 +369,22 @@ , pickleTree = return } --- | 'xpHead' (/compat/)+-- | 'xpHead'. (/compat/) xpTree :: PU [a] a xpTree = xpHead --- | specialised version of 'xpId' (/compat/)+-- | Specialised version of 'xpId'. (/compat/) xpText0 :: PU Text Text xpText0 = xpId --- | Convert text to/from String+-- | 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,+-- /NB/: 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 = ("xpAssert",err) <?+>@@ -396,9 +401,10 @@ xpText :: PU Text Text xpText = ("xpText","") <?> xpAssert "Input is empty" (not . Text.null) xpText0 --- | Transforms a pickler on Lists to a pickler on single elements.+-- | 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+-- /NB/: 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@@ -417,8 +423,7 @@ True -> Just (x,xs) False -> second (x:) <$> getFirst p xs ---- | pickle to/from attribute+-- | Pickle to/from attribute. xpAttribute :: Name -> PU Text a -> PU [Attribute] a xpAttribute name pu = ("xpAttr" , Text.pack $ ppName name) <?+> PU { unpickleTree = doUnpickle@@ -427,41 +432,51 @@ where doUnpickle attrs = case getFirst ((== name) . fst) attrs of Nothing -> NoResult $ Text.pack $ ppName name- 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')- _ -> UnpickleError $ upe ("Unresolved entities in " ++ ppName name ++ ".")+ Just ((_, c), rem')+ | all isContentText c -> case unpickleTree pu (contentToText c) of+ NoResult e -> missingE $ Text.unpack e+ UnpickleError e -> UnpickleError e+ Result _ (Just e) -> leftoverE $ show e+ Result r Nothing -> Result r (remList rem')+ -- Content entities are not supported.+ | otherwise -> UnpickleError $+ upe ("Unresolved entities in " ++ ppName name ++ ".")+ contentToText = Text.concat . map contentToText_+ contentToText_ (ContentText t) = t+ contentToText_ (ContentEntity t) = t+ isContentText (ContentText _) = True+ isContentText (ContentEntity _) = False --- | (/compat/)+-- | 'xpAttribute' (/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+-- | 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 = xpAttribute' --- | Pickle an attribute with the specified name and value, fail if the same attribute is--- not present on unpickle.+-- | Pickle an attribute with the specified name and value, fail if the same+-- attribute is not present on unpickle. 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 +-- | 'xpAttribute_' (/compat/) xpAttrFixed :: Name -> Text -> PU [Attribute] () xpAttrFixed = xpAttribute_ --- merge successive NodeCotents+-- | Merge successive @NodeContent@ values. flattenContent :: [Node] -> [Node] flattenContent xs = case foldr (\x (buf, res) -> case x of NodeContent (ContentText txt) -> (txt : buf, res)+ NodeComment _ -> (buf, res) e@(NodeElement _) -> ([] , e : addConcatText buf res) _ -> throw UnresolvedEntityException@@ -477,9 +492,9 @@ -- | 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+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 = tr <?+> PU { unpickleTree = doUnpickleTree@@ -503,9 +518,9 @@ -- | Handle all elements with a given name. The unpickler will fail when any of -- the elements fails to unpickle.-xpElems :: Name -- ^ Name of the elements- -> PU [Attribute] a -- ^ pickler for attributes- -> PU [Node] n -- ^ pickler for child nodes+xpElems :: Name -- ^ Name of the 'Element' values+ -> PU [Attribute] a -- ^ Pickler for attributes+ -> PU [Node] n -- ^ Pickler for child nodes -> PU [Node] [(a, n)] xpElems name attrs children = tr <?> xpSubsetAll isThisElem (xpElem name attrs children)@@ -515,8 +530,8 @@ tr = ("xpElems", Text.pack $ ppName name) --- | Tries to apply the pickler to all the remaining elements;--- fails if any of them don't match+-- | 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 = concatMap (pickleTree xp)@@ -524,11 +539,11 @@ doUnpickleTree = mapM (child' xp . return) -- | For unpickling, apply the given pickler to a subset of the elements--- determined by a given predicate+-- determined by a given predicate. ----- Pickles like 'xpAll'-xpSubsetAll :: (a -> Bool) -- ^ predicate to select the subset- -> PU [a] b -- ^ pickler to apply on the subset+-- Pickles like 'xpAll'.+xpSubsetAll :: (a -> Bool) -- ^ Predicate to select the subset+ -> PU [a] b -- ^ Pickler to apply on the subset -> PU [a] [b] xpSubsetAll p xp = ("xpSubsetAll","") <?+> PU { unpickleTree = \t -> let (targets, rest) = partition p t in@@ -552,10 +567,10 @@ 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+-- | Pickle 'Element' without a 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 = ("xpElemWithName", "") <?+> PU { unpickleTree = doUnpickleTree@@ -574,11 +589,11 @@ nodeElementHelper (NodeElement Element{}) = True nodeElementHelper _ = False --- | find element by name space, prefixes are ignored+-- | 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 [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@@ -610,9 +625,9 @@ nodeElementNSHelper ns' (NodeElement (Element n _ _)) = nameNamespace n == Just ns' nodeElementNSHelper _ns _ = False --- | Pickler Returns the first found Element untouched+-- | Pickler returns the first found 'Element' untouched. ----- Unpickler wraps element in 'NodeElement'+-- Unpickler wraps element in 'NodeElement'. xpElemVerbatim :: PU [Node] Element xpElemVerbatim = PU { unpickleTree = doUnpickleTree@@ -625,29 +640,32 @@ nodeElementHelper (NodeElement Element{}) = True nodeElementHelper _ = False --- | A helper variant of xpElem for elements that contain attributes but no child tags.+-- | 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.+-- | 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 --- | A helper variant of xpElem for elements that contain only character data+-- | 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+-- | Helper for 'Element' values that don't contain anything. xpElemBlank :: Name -> PU [Node] () xpElemBlank name = ("xpElemBlank", "") <?> xpWrap (const () ) (const ((),())) $ xpElem name xpUnit xpUnit --- | When pickling, creates an empty element iff parameter is True+-- | When pickling, creates an empty element iff parameter is @True@. -- -- When unpickling, checks whether element exists. Generates an error when the--- element is not empty+-- element is not empty. xpElemExists :: Name -> PU [Node] Bool xpElemExists name = ("xpElemBlank", "") <?> xpWrap (\x -> case x of Nothing -> False; Just _ -> True)@@ -655,13 +673,16 @@ xpOption (xpElemBlank name) --- | Get the first non-element NodeContent 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 -- flatten+ doUnpickle nodes = case getFirst nodeContentHelper+ (filter (\node -> case node of+ NodeComment _ -> False+ _ -> True) nodes) of -- flatten Just (NodeContent (ContentText t), _re) -> child xp t Just (NodeContent (ContentEntity t), _) -> UnpickleError . upe $ "Unresolved entity" ++ show t ++ "."@@ -671,8 +692,9 @@ nodeContentHelper _ = False --- | Unlift a pickler on Nodes to a Pickler on Elements. Nodes generated during--- pickling that are not Elements will be silently discarded+-- | Unlift a pickler on 'Node' values to a pickler on 'Element' values. Nodes+-- generated during pickling that are not 'Element' values will be silently+-- discarded. xpUnliftElems :: PU [Node] a -> PU [Element] a xpUnliftElems xp = ("xpUnliftElems","") <?+> PU { unpickleTree = doUnpickle@@ -692,11 +714,11 @@ NodeElement e -> e : es _ -> es) [] --- | Optional conversion with default value+-- | 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 doesn't--- returna a value+-- return a value. xpDefault :: (Eq a) => a -> PU [t] a -> PU [t] a xpDefault df = xpWrap (fromMaybe df)@@ -705,7 +727,7 @@ xpOption -- | Attempt to use a pickler. Return a default value when the pickler doesn't--- return anything (Doesn't touch on UnpickleError)+-- 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@@ -716,20 +738,20 @@ UnpickleError e -> UnpickleError e } --- | 'xp2Tuple' (/compat/)+-- | 'xp2Tuple'. (/compat/) xpPair :: PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2) xpPair l r = "xpPair" <??> xp2Tuple l r --- | 'xp2Tuple'+-- | 'xp2Tuple'. (<#>) :: PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2) (<#>) l r = "(<#>)" <??> xp2Tuple l r --- | 'xp3Tuple' (/compat/)+-- | '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 --- | When unpickling, don't consume the matched element(s), noop when pickling+-- | 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 ->@@ -738,9 +760,9 @@ x -> x } --- | Noop when pickling+-- | Noop when pickling. ----- When unpickling, only give access to the first element+-- When unpickling, only give access to the first element. xpIsolate :: PU [t] a -> PU [t] a xpIsolate xp = ("xpIsolate","") <?+> PU { pickleTree = pickleTree xp@@ -756,11 +778,11 @@ -- | Select a single element from the list and apply unpickler to it. ----- Returns no value when no element matches the predicate+-- Returns no value when no element matches the predicate. ----- Fails when the unpickler doesn't return a value+-- Fails when the unpickler doesn't return a value. ----- When pickling, this is a noop+-- When pickling, this is a noop. xpFindFirst :: (t -> Bool) -> PU [t] a -> PU [t] a xpFindFirst p xp = ("xpFindFirst","") <?+> PU { pickleTree = pickleTree xp@@ -771,12 +793,12 @@ child' xp [z] } --- | Ignore input/output and replace with constant values+-- | Ignore input/output and replace with constant values. xpConst :: a -> PU t () -> PU t a xpConst c xp = ("xpConst" ,"") <?> xpWrap (const c) (const ()) xp --- | Convert text to/from any type that implements 'Read' and 'Show'.--- Fails on unpickle if 'read' fails.+-- | 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 [] -> UnpickleError $ ("xpPrim","") <++>@@ -785,8 +807,8 @@ , pickleTree = Text.pack . show } --- | When unpickling, tries to apply the pickler to all elements--- returning and consuming only matched elements+-- | 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@@ -800,12 +822,12 @@ UnpickleError e -> Right $ UnpickleError e in leftover (remList ls) >> sequence rs --- | 'xpAll' (/compat/)+-- | 'xpAll'. (/compat/) xpList0 :: PU [a] b -> PU [a] [b] xpList0 = xpAll --- | Like xpList, but only succeed during unpickling if at least a--- minimum number of elements are unpickled.+-- | 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 where@@ -814,7 +836,7 @@ testLength as = Right as --- | When unpickling, sucessively applies pickler to single elements until it+-- | When unpickling, successively applies pickler to single elements until it -- doesn't return anything; returns all matched elements. xpSeqWhile :: PU [a] b -> PU [a] [b] xpSeqWhile pu = ("xpSeqWhile", "") <?+> PU {@@ -831,7 +853,7 @@ NoResult _ -> Result [] (Just es) UnpickleError e -> UnpickleError e --- | 'xpSeqWhile' (/compat/)+-- | 'xpSeqWhile'. (/compat/) xpList :: PU [a] b -> PU [a] [b] xpList = xpSeqWhile @@ -856,10 +878,10 @@ xpv --- | 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+-- | Like xpWrap, except it strips @Right@ (and treats @Left@ as a failure)+-- during unpickling. ----- not to be confuesd with 'xpEither'+-- Not to be confused with 'xpEither'. xpWrapEither :: Show e => (a -> Either e b) -> (b -> a) -> PU t a -> PU t b xpWrapEither a2b b2a pua = ("xpWrapEither","") <?+> PU {@@ -876,17 +898,18 @@ -- | 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).+-- 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.+-- 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+-- /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+-- @NoResult@. Use 'xpChoice' for a saner version of this function.+xpAlt :: (a -> Int) -- ^ Selector function+ -> [PU t a] -- ^ List of picklers -> PU t a xpAlt selector picklers = PU { unpickleTree = doUnpickle,@@ -906,17 +929,18 @@ -- | 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.+-- 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 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+-- 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)@@ -930,11 +954,10 @@ <++> 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+-- one. Wrapping the result in @Left@ or @Right@, respectively. ----- Not to be confued with 'xpWrapEither'+-- Not to be confused with 'xpWrapEither'. xpEither :: PU n t1 -> PU n t2 -> PU n (Either t1 t2) xpEither xpl xpr = PU { unpickleTree = doUnpickle,@@ -979,13 +1002,15 @@ , pickleTree = pickleTree pu1 } --- | The zero pickler+-- | The zero pickler. ----- Encodes nothing, always fails during unpickling. (Same as @'xpThrow' \"got xpZero\"@).+-- Encodes nothing, always fails during unpickling. (Same as @'xpThrow'+-- \"got xpZero\"@). xpZero :: PU [t] a xpZero = ("xpZero","") <?> xpThrow "got xpZero" --- | No output when pickling, always generates an error with the specified message on unpickling.+-- | No output when pickling, always generates an error with the specified+-- message on unpickling. xpThrow :: Monoid m => String -- ^ Error message -> PU m a@@ -1006,7 +1031,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+-- | 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@@ -1014,9 +1039,9 @@ x -> x } --- | Run unpickler and consume and discard remaining elements+-- | Run unpickler and consume and discard remaining elements. ----- When pickling, this is a noop+-- When pickling, this is a noop. xpClean :: PU t a -> PU t a xpClean xp = PU { unpickleTree = \x -> case unpickleTree xp x of Result r _ -> Result r Nothing
src/Data/XML/Pickle/Basic.hs view
@@ -21,13 +21,14 @@ 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.+ -- 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@+ -- /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@@ -115,7 +116,7 @@ (<++.>) s = mapUnpickleError (s <++>) infixr 0 <?>--- | Override the last backtrace level in the error report+-- | Override the last backtrace level in the error report. (<?>) :: (Text, Text) -> PU t a -> PU t a (<?>) tr = mapError (swapStack tr) where@@ -131,7 +132,7 @@ infixr 1 <?+>--- | Add a back trace level to the error report+-- | Add a back trace level to the error report. (<?+>) :: (Text, Text) -> PU t a -> PU t a (<?+>) tr = mapError (tr <++>)
src/Data/XML/Pickle/Tuples.hs view
@@ -10,14 +10,11 @@ ) 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+-- | 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@@ -27,7 +24,7 @@ tErr :: Text -> UnpickleResult t a -> UnpickleResult t a tErr tr = mapUnpickleError (("tuple", tr) <++>) --- | Combines 2 picklers+-- | Combines 2 picklers. xp2Tuple :: PU [a] b1 -> PU [a] b2 -> PU [a] (b1, b2) xp2Tuple xp1 xp2 = "xp2Tuple" <??> PU {pickleTree = \(t1, t2) ->@@ -35,12 +32,12 @@ , unpickleTree = doUnpickleTree } where doUnpickleTree r0 = do- -- The /Either String/ monad+ -- The @Either String@ monad. (x1 ,r1) <- tErr "1" . getRest $ unpickleTree xp1 r0 x2 <- tErr "2" $ unpickleTree xp2 r1 return (x1,x2) --- | Combines 3 picklers+-- | 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@@ -54,7 +51,7 @@ x3 <- tErr "3" $ unpickleTree xp3 r2 return (x1,x2,x3) --- | Combines 4 picklers+-- | 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@@ -73,7 +70,7 @@ x4 <- tErr "4" $ unpickleTree xp4 r3 return (x1,x2,x3,x4) --- | Combines 5 picklers+-- | 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@@ -94,7 +91,7 @@ x5 <- tErr "5" $ unpickleTree xp5 r4 return (x1,x2,x3,x4,x5) --- | You guessed it ... Combines 6 picklers+-- | 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)
+ tests/Tests.hs view
@@ -0,0 +1,389 @@+{-# Language NoMonomorphismRestriction #-}+{-# Language OverloadedStrings #-}++-- module Tests where++import Control.Monad+import Data.Either+import Data.List+import Data.Maybe+import Data.Text (Text)+import Data.XML.Pickle+import Data.XML.Types+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import Test.QuickCheck++import qualified Data.Text as Text++-- import Data.Monoid+-- import Test.QuickCheck+-- import Test.Framework+-- import Test.Framework.Providers.QuickCheck2++main =+ defaultMain $ testGroup "all"+ [ testProperty "prop_showXpPrim" prop_showXpPrim+ , testProperty "prop_xpUnit" prop_xpUnit+ , testProperty "prop_xpAttribute" prop_xpAttribute+ , testProperty "prop_xpElemVerbatimUnpickle" prop_xpElemVerbatimUnpickle+ , testProperty "prop_xpElemVerbatimPickle" prop_xpElemVerbatimPickle+ , testProperty "prop_xpElemTextPickle" prop_xpElemTextPickle+ , testProperty "prop_xpElemBlankUnpickleBlanks"+ prop_xpElemBlankUnpickleBlanks+ , testProperty "prop_xpElemBlankUnpickleNonBlanks"+ prop_xpElemBlankUnpickleNonBlanks+ , testProperty "prop_xpElemBlankPickle" prop_xpElemBlankPickle+ , testProperty "prop_xpElemExistsPickleTrue" prop_xpElemExistsPickleTrue+ , testProperty "prop_xpElemExistsPickleFalse" prop_xpElemExistsPickleFalse+ , testProperty "prop_xpElemExistsUnpickleBlanks"+ prop_xpElemExistsUnpickleBlanks+ , testProperty "prop_xpElemExistsUnpickleNonBlanks"+ prop_xpElemExistsUnpickleNonBlanks+ , testProperty "prop_xpBool" prop_xpBool+ , testProperty "prop_flattenContent" prop_flattenContent+ , testCase "xpBoolUnpickleTrue" $ assertBool "" xpBoolUnpickleTrue+ , testCase "xpBoolUnpickleFalse" $ assertBool "" xpBoolUnpickleFalse+ , testCase "xpBoolUnpickle1" $ assertBool "" xpBoolUnpickle1+ , testCase "xpBoolUnpickle0" $ assertBool "" xpBoolUnpickle0+ , testCase "xpBoolPickleTrue" $ assertBool "" xpBoolPickleTrue+ , testCase "xpBoolPickleFalse" $ assertBool "" xpBoolPickleFalse + ]++-- Generates an arbitrary XML name. Namespaces (not part of XML 1.0) are not+-- generated.+instance Arbitrary Name where+ arbitrary = do+ localName <- xmlString+ prefix <- oneof [return $ Nothing, xmlString >>= return . Just]+ return Name { nameLocalName = localName+ , nameNamespace = Nothing+ , namePrefix = prefix }+ where+ xmlString =+ -- We want to include a suitable set of non-ASCII characters here.+ let range = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_" in do+ char <- elements range+ string <- listOf $ elements $ "-." ++ range+ return . Text.pack $ char:string++-- We're using the printable ASCII characters. The commented list includes the+-- printable characters of the ISO 8859-1 extension.+instance Arbitrary Content where+ arbitrary = do+ string <- listOf $ elements ['\0032'..'\0126'] -- ['\0160'..'\0255']+ return $ ContentText $ Text.pack string++-- Generator for XML elements.+instance Arbitrary Element where+ arbitrary = do+ name <- arbitrary+ attributes <- arbitrary+ nodes <- arbitrary+ return Element { elementName = name+ , elementAttributes = attributes+ , elementNodes = nodes }++-- Generator for nodes. We resize child elements to avoid infinite structures.+instance Arbitrary Node where+ arbitrary = oneof [ sized (\n -> resize (n `div` 2) $ do+ element <- arbitrary+ return $ NodeElement element)+ , arbitrary >>= \content -> return $ NodeContent content+ , arbitrary >>= \comment -> return $ NodeComment comment+ ]++-- Our `Text' generator is simply a wrapper around the `String' generator.+instance Arbitrary Text where+ arbitrary = liftM Text.pack arbitrary++-- Generator for an XML element without attributes and with child nodes that+-- are considered empty (see `emptyNodeGen').+emptyElementGen :: Gen Element+emptyElementGen = do+ name <- arbitrary+ nodes <- listOf emptyNodeGen+ return Element { elementName = name+ , elementAttributes = []+ , elementNodes = nodes }++-- Generator for child nodes that are considered empty: "" strings and comments.+emptyNodeGen :: Gen Node+emptyNodeGen = oneof [ return $ NodeContent (ContentText "")+ , arbitrary >>= \comment -> return $ NodeComment comment ]++-- Generator for XML elements with only text.+elementWithTextGen :: Gen Element+elementWithTextGen = do+ name <- arbitrary+ nodes <- listOf nodeWithTextGen+ return Element { elementName = name+ , elementAttributes = []+ , elementNodes = nodes }++-- Generator for XML nodes with only text content and comments.+nodeWithTextGen :: Gen Node+nodeWithTextGen = do+ content0 <- arbitrary+ content1 <- arbitrary+ oneof [return $ NodeContent content0, return $ NodeComment content1]++-- Verify that the pickled show value is the same as the show value itself.+prop_showXpPrim :: Integer -> Bool+prop_showXpPrim a = Text.unpack (pickle xpPrim a) == show a++-- Verify that `xpUnit' never fails.+prop_xpUnit :: [Integer] -> Bool+prop_xpUnit as = (case unpickle xpUnit as of+ Right () -> True+ _ -> False) && null (pickle xpUnit ())++-- Given a list of attributes, every attribute should be present upon unpickle.+prop_xpAttribute :: [Attribute] -> Bool+prop_xpAttribute attributes =+ let result = map (\(n, c) -> let t = contentToText c+ in unpickle (xpAttribute_ n t) attributes)+ attributes+ in length result == length (rights (result))++-- Provided a list of Nodes containing at least one Element, we verify that+-- xpElemVerbatim always finds the first element.+prop_xpElemVerbatimUnpickle :: [Node] -> Property+prop_xpElemVerbatimUnpickle ns =+ let ne = find (\n -> case n of NodeElement _ -> True; _ -> False) ns+ in isJust ne ==> let NodeElement e = fromJust ne+ in case unpickle xpElemVerbatim ns of+ Right e_ -> e == e_+ Left _ -> False++-- Verify that xpElemVerbatim pickling an element returns only that element.+prop_xpElemVerbatimPickle :: Element -> Bool+prop_xpElemVerbatimPickle e = pickle xpElemVerbatim e == [NodeElement e]++-- Verify that xpElemText pickling text content returns that content properly.+prop_xpElemTextPickle :: Name -> Text -> Bool+prop_xpElemTextPickle n t =+ let nodes = pickle (xpElemText n) t+ in nodes == [ NodeElement+ Element { elementName = n+ , elementAttributes = []+ , elementNodes = [NodeContent (ContentText t)]+ } ]++-- Pickling of blanks should work.+prop_xpElemBlankUnpickleBlanks :: Property+prop_xpElemBlankUnpickleBlanks =+ forAll (listOf $ oneof [emptyNodeGen, arbitrary]) $ \nodes ->+ let blanks = filter (isEmpty . unwrapElement) (filterNodeElements nodes)+ in all (\e -> case unpickle (xpElemBlank (elementName e)) nodes of+ Right () -> True+ r -> False) (filterMapNodeElements blanks)++-- Pickling of non-blanks should not work.+prop_xpElemBlankUnpickleNonBlanks :: [Node] -> Bool+prop_xpElemBlankUnpickleNonBlanks nodes =+ let nonBlanks = filter (not . isEmpty . unwrapElement)+ (filterNodeElements nodes)+ in all (\e -> case unpickle (xpElemBlank (elementName e)) nodes of+ Right () -> False+ _ -> True) (filterMapNodeElements nonBlanks)++-- Return true if element has no attributes, and has no non-comment nodes.+isEmpty :: Element -> Bool+isEmpty Element { elementAttributes = [], elementNodes = [] } = True+isEmpty Element { elementAttributes = [], elementNodes = ns }+ | all (\n -> case n of+ NodeComment _ -> True+ NodeContent (ContentText "") -> True+ NodeContent (ContentEntity _) ->+ error "Content entities not supported!"+ _ -> False) ns = True+isEmpty _ = False++-- Verify that `xpElemText' pickling text content returns that content+-- properly.+prop_xpElemBlankPickle :: Name -> Bool+prop_xpElemBlankPickle n =+ let nodes = pickle (xpElemBlank n) ()+ in nodes == [ NodeElement+ Element { elementName = n+ , elementAttributes = []+ , elementNodes = []+ } ]++-- Verify that `xpElemExists' always generates an empty `NodeElement' with the+-- correct name when the provided parameter is `True'.+prop_xpElemExistsPickleTrue :: Name -> Bool+prop_xpElemExistsPickleTrue n =+ pickle (xpElemExists n) True == [NodeElement Element { elementName = n+ , elementAttributes = []+ , elementNodes = [] }]++-- Verify that xpElemExists always generates an empty list when the provided+-- parameter is `False'.+prop_xpElemExistsPickleFalse :: Name -> Bool+prop_xpElemExistsPickleFalse n = pickle (xpElemExists n) False == []++-- Pickling of empty elements should work.+-- Verifies that all generated elements are actually found, that no error is+-- generated if the element is empty, and that an error is generated if the+-- element is not empty.+prop_xpElemExistsUnpickleBlanks :: Property+prop_xpElemExistsUnpickleBlanks =+ forAll (listOf $ oneof [emptyNodeGen, arbitrary]) $ \nodes ->+ let blanks = filter (isEmpty . unwrapElement) (filterNodeElements nodes)+ in all (\e -> case unpickle (xpElemExists (elementName e)) nodes of+ Right True -> True+ _ -> False) (filterMapNodeElements blanks)++-- Pickling of non-empty elements should not work.+prop_xpElemExistsUnpickleNonBlanks :: [Node] -> Bool+prop_xpElemExistsUnpickleNonBlanks nodes =+ let nonBlanks = filter (not . isEmpty . unwrapElement)+ (filterNodeElements nodes)+ in all (\e -> case unpickle (xpElemExists (elementName e)) nodes of+ Right _ -> False+ _ -> True) (filterMapNodeElements nonBlanks)++-- Remove all Node values that are not NodeElement values, and convert the+-- remaining values to Element values.+filterMapNodeElements :: [Node] -> [Element]+filterMapNodeElements = map unwrapElement . filterNodeElements++-- Remove node children that are not elements.+filterNodeElements :: [Node] -> [Node]+filterNodeElements = filter (\n -> case n of NodeElement _ -> True; _ -> False)++-- Access inner `Element' values, and fail if something else is encountered.+unwrapElement :: Node -> Element+unwrapElement (NodeElement e) = e+unwrapElement _ = error "unwrapElement: Non-element Node value encountered."++-- xpBool should unpickle to `True' for "true".+xpBoolUnpickleTrue :: Bool+xpBoolUnpickleTrue = case unpickle xpBool "true" of+ Right True -> True+ _ -> False++-- xpBool should unpickle to `False' for "false".+xpBoolUnpickleFalse :: Bool+xpBoolUnpickleFalse = case unpickle xpBool "false" of+ Right False -> True+ _ -> False++-- xpBool should unpickle to `True' for "1".+xpBoolUnpickle1 :: Bool+xpBoolUnpickle1 = case unpickle xpBool "1" of+ Right True -> True+ _ -> False++-- xpBool should unpickle to `False' for "0".+xpBoolUnpickle0 :: Bool+xpBoolUnpickle0 = case unpickle xpBool "0" of+ Right False -> True+ _ -> False++-- xpBool should pickle to "true" for `True'.+xpBoolPickleTrue :: Bool+xpBoolPickleTrue = pickle xpBool True == "true"++-- `xpBool' should pickle to "false" for `False'.+xpBoolPickleFalse :: Bool+xpBoolPickleFalse = pickle xpBool False == "false"++-- `xpBool' should fail for any string that is not "true", "1", "false" or "0".+prop_xpBool :: Text -> Property+prop_xpBool t = and [ t /= "true"+ , t /= "1"+ , t /= "false"+ , t /= "0" ] ==> case unpickle xpBool t of+ Right _ -> False+ Left _ -> True++-- Verify that arbitrarily splitting up `ContentText' values does not change+-- the resulting list of nodes.+prop_flattenContent :: [(Node, Content)] -> Property+prop_flattenContent ncs =+ hasContent (map fst ncs) ==>+ let combined = map (\(n, c) -> case (n, c) of+ (NodeContent (ContentText t), ContentText t')->+ NodeContent (ContentText (Text.concat [t, t']))+ (NodeContent (ContentEntity _), _) ->+ error "Content entities not supported!"+ _ -> n) ncs+ split = concat $+ map (\(n, c) -> case (n, c) of+ (NodeContent (ContentText t), ContentText t') ->+ [ NodeContent (ContentText t)+ , NodeContent (ContentText t') ]+ (NodeContent _, _) ->+ error "Content entities not supported!"+ _ -> [n]) ncs+ in (flattenContent combined) == (flattenContent split)+ where+ hasContent :: [Node] -> Bool+ hasContent [] = False+ hasContent ((NodeContent _):_) = True+ hasContent (_:ns) = hasContent ns++-- Get the `Text' value based on a list of the `Content' values.+contentToText :: [Content] -> Text+contentToText = Text.concat . map contentToText_++-- Unwrap `ContentText' values. Fail on `ContentEntity' values, as they are+-- not supported.+contentToText_ :: Content -> Text+contentToText_ (ContentText t) = t+contentToText_ (ContentEntity _) = error "Content entities not supported!"++-- escape :: Text -> Text+-- escape = Text.replace "&" "&" . Text.replace "'" "'" .+-- Text.replace ">" ">" . Text.replace "<" "<" .+-- Text.replace "\"" """++-- Given a list of nodes which has elements containing only character data and+-- comments (yet has at least a CDATA length of 1), and verifies that the+-- content of those elements can be accessed properly.+-- prop_xpElemTextUnpickle :: [Element] -> Property+-- prop_xpElemTextUnpickle elems = undefined++-- main = flip defaultMainWithOpts (mempty {ropt_color_mode = Just ColorNever}) $+-- [ testGroup "xpUnit" [ testProperty "xpUnit1" testxpUnit1+-- , testProperty "xpUnit2" testxpUnit2+-- ]+-- , testGroup "xpId" [ testProperty "xpId" testxpId]+-- , testGroup "combinators" [ testProperty "xpIsolate" testxpIsolate+-- , testProperty "xpIsolatePair" testxpIsolatePair+-- , testProperty "pair leniency" testPairLenient+-- ]+-- ]++-- testxpUnit1 xs = pickle xpUnit () == ([] :: [Int])+-- where types = xs :: Int++-- testxpUnit2 xs = unpickle xpUnit xs == Right ()+-- where types = xs :: [Int]++-- testxpId xs = null xs .||. (unpickle xpId xs == Right xs)+-- where types = xs :: [Int]++-- testxpIsolate xs = null xs .||.+-- (unpickle (xpIsolate xpId) xs == Right (take 1 xs))+-- where types = xs :: [Int]++-- testxpIsolatePair xs = null xs .||.+-- (unpickle (xpPair (xpIsolate xpId)+-- (xpId)+-- ) xs == Right (take 1 xs, drop 1 xs))+-- where types = xs :: [Int]++-- testPairLenient xs = unpickle (xpId <++> xpUnit) xs == Right (xs, ())+-- where types = xs :: [Int]++-- el x = Element "foo" [("bar",(return . ContentText $ "blub" `Text.append` x))] []+-- el' xs = Element "parent" [] $ flip map xs (\x -> NodeElement $ el (Text.pack $ show x))++-- doc = el' [1..5]++-- testDoc = xpRoot $ xpElem "parent" xpUnit (xpAll $ xpElem "foo" xpId xpUnit)
xml-picklers.cabal view
@@ -1,6 +1,6 @@ Cabal-Version: >= 1.2 Name: xml-picklers-Version: 0.3.4+Version: 0.3.5 Synopsis: XML picklers based on xml-types, ported from hexpat-pickle Description: A library of combinators that allows Haskell data structures to be pickled@@ -34,6 +34,23 @@ Other-Modules: Data.XML.Pickle.Basic , Data.XML.Pickle.Tuples GHC-Options: -Wall++Test-Suite tests+ Main-Is: Tests.hs+ Type: exitcode-stdio-1.0+ Build-Depends: base >= 4 && < 5+ , Cabal+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , QuickCheck+ , text+ , xml-types+ -- , test-framework-quickcheck2+ -- , test-framework+ , xml-picklers+ HS-Source-Dirs: tests+ GHC-Options: -fhpc Source-Repository head type: git