diff --git a/Text/XML/Expat/Pickle.hs b/Text/XML/Expat/Pickle.hs --- a/Text/XML/Expat/Pickle.hs +++ b/Text/XML/Expat/Pickle.hs @@ -31,18 +31,18 @@ -- most general types, and your picklers should not use any other types for @t@. -- Here they are, assuming we are using the /String/ type for our strings: -- --- * @'PU' ('Nodes' String String) a@ /(for working with an XML element)/ +-- * @'PU' ['Node' String String] a@ /(for working with an XML element)/ -- -- * @'PU' String a@ /(for working with text content)/ -- -- * @'PU' ('Attributes' String String) a@ /(for working with attributes)/ -- --- The reason why you need 'Nodes' in the plural when working with a single +-- The reason why you a list of 'Node' 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. -- -- 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 'Nodes' for your +-- '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@. -- @@ -62,7 +62,7 @@ -- 'GenericXMLString'. We select the type for XML /tag/ and /text/ separately -- in our four \"tree part\" types as follows: -- --- * @'PU' (Nodes tag text) a@ /(for working with an XML element)/ +-- * @'PU' [Node tag text] a@ /(for working with an XML element)/ -- -- * @'PU' text a@ /(for working with text content)/ -- @@ -72,9 +72,9 @@ -- the 'Text.XML.Expat.Qualified' module. (Or you can extend it any way you like.) -- -- The /Text.XML.Expat.Tree/ and /Text.XML.Expat.Qualified/ provide the follow --- useful shortcuts for common cases of 'Node', 'Nodes' and 'Attributes': +-- useful shortcuts for common cases of 'Node' and 'Attributes': -- --- * 'UNode', 'UNodes', 'UAttributes', 'QNode', 'QNodes', 'QAttributes'. +-- * 'UNode', 'UAttributes', 'QNode', 'QAttributes'. -- -- The type class 'XmlPickler' is used to extend a polymorphic 'xpickle' function -- to provide a pickler for a new type, in a similar way to 'Read' and 'Show'. @@ -88,7 +88,7 @@ -- > -- Person name, age and description -- > data Person = Person String Int String -- > --- > xpPerson :: PU (UNodes String) Person +-- > xpPerson :: PU [UNode String] Person -- > xpPerson = -- > -- How to wrap and unwrap a Person -- > xpWrap (\((name, age), descr) -> Person name age descr, @@ -127,14 +127,12 @@ UNode, QNode, NNode, - Nodes, - UNodes, - QNodes, - NNodes, Attributes, UAttributes, QAttributes, NAttributes, + ParserOptions(..), + defaultParserOptions, -- * Pickler adapters xpRoot, xpContent, @@ -243,22 +241,22 @@ -- XML document - lazy version. In the event of an error, it throws either -- 'Text.XML.Expat.Tree.XMLParseException' or 'UnpickleException'. unpickleXML :: (GenericXMLString tag, GenericXMLString text) => - Maybe Encoding + ParserOptions tag text -> PU (Node tag text) a -> BL.ByteString -> a -unpickleXML mEnc pu = - unpickleTree pu . parseTreeThrowing mEnc +unpickleXML options pu = + unpickleTree pu . parseThrowing options -- | A helper that combines 'parseXML' with 'unpickleTree' to unpickle from an -- XML document - strict version. unpickleXML' :: (GenericXMLString tag, GenericXMLString text) => - Maybe Encoding + ParserOptions tag text -> PU (Node tag text) a -> B.ByteString -> Either String a -unpickleXML' mEnc pu xml = - case parseTree' mEnc xml of +unpickleXML' options pu xml = + case parse' options xml of Right tree -> unpickleTree' pu tree Left err -> Left $ show err @@ -272,7 +270,7 @@ -- | Adapts a list of nodes to a single node. Generally used at the top level of -- an XML document. -xpRoot ::PU (Nodes tag text) a -> PU (Node tag text) a +xpRoot ::PU [Node tag text] a -> PU (Node tag text) a xpRoot pa = PU { unpickleTree = \t -> unpickleTree pa [t], unpickleTree' = \t -> unpickleTree' pa [t], @@ -284,7 +282,7 @@ -- | If you have a pickler that works with /text/, and you want to use it as -- text content of an XML element, you need to wrap it with /xpContent/. See the -- example at the top. -xpContent :: GenericXMLString text => PU text a -> PU (Nodes tag text) a +xpContent :: GenericXMLString text => PU text a -> PU [Node tag text] a xpContent tp = PU { unpickleTree = \t -> unpickleTree tp $ mconcat $ map extract t, unpickleTree' = \t -> unpickleTree' tp $ mconcat $ map extract t, @@ -374,8 +372,8 @@ xpElem :: (Eq tag, Show tag) => tag -- ^ Element name -> PU [(tag, text)] a -- ^ Pickler for attributes - -> PU (Nodes tag text) b -- ^ Pickler for child nodes - -> PU (Nodes tag text) (a,b) + -> PU [Node tag text] b -- ^ Pickler for child nodes + -> PU [Node tag text] (a,b) xpElem name puAttrs puChildren = PU { unpickleTree = \t -> let doElem elt@(Element eName attrs children) | eName == name = @@ -404,14 +402,14 @@ xpElemAttrs :: (Eq tag, Show tag) => tag -- ^ Element name -> PU (Attributes tag text) a -- ^ Pickler for attributes - -> PU (Nodes tag text) a + -> PU [Node tag text] a xpElemAttrs name puAttrs = xpWrap (fst,\a -> (a,())) $ xpElem name puAttrs xpUnit -- | A helper variant of xpElem for elements that contain child nodes but no attributes. xpElemNodes :: (Eq tag, Show tag) => tag -- ^ Element name - -> PU (Nodes tag text) a -- ^ Pickler for child nodes - -> PU (Nodes tag text) a + -> PU [Node tag text] a -- ^ Pickler for child nodes + -> PU [Node tag text] a xpElemNodes name puChildren = xpWrap (snd,\a -> ((),a)) $ xpElem name xpUnit puChildren -- | Create/parse an XML attribute of the specified name. Fails if the attribute @@ -612,7 +610,7 @@ -- Note on lazy unpickle: Because we're using a failure to pickle a child as -- the end condition it means we're only lazy at the top-level xpList. Children -- of xpList are evaluated strictly. Use 'xpList0' to fix this. -xpList :: Show tag => PU (Nodes tag text) a -> PU (Nodes tag text) [a] +xpList :: Show tag => PU [Node tag text] a -> PU [Node tag text] [a] xpList pu = PU { unpickleTree = doUnpickle, unpickleTree' = Right . doUnpickle, @@ -631,7 +629,7 @@ -- evaluate its children lazily. -- -- Any error in a child will cause an error to be reported. -xpList0 :: Show tag => PU (Nodes tag text) a -> PU (Nodes tag text) [a] +xpList0 :: Show tag => PU [Node tag text] a -> PU [Node tag text] [a] xpList0 pu = PU { unpickleTree = \nodes -> let munge [] = [] @@ -659,7 +657,7 @@ rights x = [a | Right a <- x] -- In Data.Either in base 4.x, but doesn't exist in base 3.x -- | Like xpList, but only succeed during deserialization if at least a minimum number of elements are unpickled. -xpListMinLen :: Show tag => Int -> PU (Nodes tag text) a -> PU (Nodes tag text) [a] +xpListMinLen :: Show tag => Int -> PU [Node tag text] a -> PU [Node tag text] [a] xpListMinLen ml = xpWrapEither (testLength, id) . xpList where testLength as | length as < ml = Left $ "Expecting at least " ++ show ml ++ " elements" @@ -674,8 +672,8 @@ tag -- ^ Element name (elt) -> tag -- ^ Attribute name (attr) -> PU text k -- ^ Pickler for keys (key) - -> PU (Nodes tag text) v -- ^ Pickler for values (value) - -> PU (Nodes tag text) (M.Map k v) + -> PU [Node tag text] v -- ^ Pickler for values (value) + -> PU [Node tag text] (M.Map k v) xpMap en an xpk xpv = xpWrap ( M.fromList , M.toList @@ -820,7 +818,7 @@ } -- | Insert/extract a tree node literally in the xml stream. -xpTree :: PU (Nodes tag text) (Node tag text) +xpTree :: PU [Node tag text] (Node tag text) xpTree = PU { unpickleTree = \t -> case t of [elt] -> elt diff --git a/hexpat-pickle.cabal b/hexpat-pickle.cabal --- a/hexpat-pickle.cabal +++ b/hexpat-pickle.cabal @@ -1,6 +1,6 @@ Cabal-Version: >= 1.2 Name: hexpat-pickle -Version: 0.3.1 +Version: 0.4 Synopsis: XML picklers based on hexpat, source-code-similar to those of the HXT package Description: A library of combinators that allows Haskell data structures to be pickled @@ -36,7 +36,7 @@ Library Build-Depends: base >= 3 && < 5, - hexpat >= 0.5, + hexpat >= 0.11, utf8-string >= 0.3.3, bytestring >= 0.9, text >= 0.1, diff --git a/test/example.hs b/test/example.hs --- a/test/example.hs +++ b/test/example.hs @@ -5,7 +5,7 @@ -- Person name, age and description data Person = Person String Int String -xpPerson :: PU (UNodes String) Person +xpPerson :: PU [UNode String] Person xpPerson = -- How to wrap and unwrap a Person xpWrap (\((name, age), descr) -> Person name age descr, diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -124,12 +124,12 @@ main_tree doc = do start <- getCurrentTime let pickler = xpRoot $ xpElemNodes "mnemonics" $ xpList xpMnemonic - case unpickleXML' Nothing pickler doc of + case unpickleXML' defaultParserOptions pickler doc of Right mnems -> do let xml = mconcat . L.toChunks $ pickleXML pickler mnems `mappend` L.pack (map c2w "\n") if xml == doc then do - let mnems = unpickleXML Nothing pickler $ L.fromChunks [doc] + let mnems = unpickleXML defaultParserOptions pickler $ L.fromChunks [doc] xml = mconcat . L.toChunks $ pickleXML pickler mnems `mappend` L.pack (map c2w "\n") if xml == doc then do diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -11,9 +11,9 @@ import Control.Arrow -- | Tests where input and XML output differ -u2 :: (NFData a, Eq a, Show a) => String -> String -> String -> Either String a -> PU (UNodes String) a -> IO () +u2 :: (NFData a, Eq a, Show a) => String -> String -> String -> Either String a -> PU [UNode String] a -> IO () u2 title inXML chkXML inEVal inPU = do - let inTree = parseTreeThrowing (Just UTF8) (L.pack $ map c2w inXML) + let inTree = parseThrowing (defaultParserOptions { parserEncoding = Just UTF8 }) (L.pack $ map c2w inXML) inTreeXML = formatTree' inTree eVal = unpickleTree' (xpRoot inPU) inTree assertEqual (title++" - strict unpickle") inEVal eVal @@ -21,7 +21,7 @@ Right val -> do -- Make sure that the lazy unpickler gives the same result assertEqual (title++" - lazy unpickle") val (unpickleTree (xpRoot inPU) inTree) - let chkTree = parseTreeThrowing (Just UTF8) (L.pack $ map c2w chkXML) :: UNode String + let chkTree = parseThrowing (defaultParserOptions { parserEncoding = Just UTF8 }) (L.pack $ map c2w chkXML) :: UNode String chkTreeXML = formatTree' chkTree outXML = pickleXML' (xpRoot inPU) val assertEqual (title++" - pickle") chkTreeXML outXML