diff --git a/examples/arrows/pickle/Makefile b/examples/arrows/pickle/Makefile --- a/examples/arrows/pickle/Makefile +++ b/examples/arrows/pickle/Makefile @@ -10,7 +10,7 @@ DIST = $(HXT_HOME)/dist/examples/arrows DIST_DIR = $(DIST)/pickle -PROG = ./pickleTest +PROG = ./pickleTest ./pickleTestWithNamespaces all : $(PROG) @@ -23,6 +23,11 @@ @echo "the program p2 as XML document" @sleep 3 cat pickle.xml + ./pickleTestWithNamespaces + @sleep 1 + @echo "the program p2 as XML document" + @sleep 3 + cat pickle.xml dist : [ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR) @@ -37,4 +42,7 @@ .PHONY : all test dist clean distclean force pickleTest : PickleTest.hs + $(GHC) --make -o $@ $< + +pickleTestWithNamespaces : PickleTestWithNamespaces.hs $(GHC) --make -o $@ $< diff --git a/hxt.cabal b/hxt.cabal --- a/hxt.cabal +++ b/hxt.cabal @@ -1,6 +1,6 @@ -- arch-tag: Haskell XML Toolbox main description file Name: hxt -Version: 9.1.6 +Version: 9.2.0 Synopsis: A collection of tools for processing XML with Haskell. Description: The Haskell XML Toolbox bases on the ideas of HaXml and HXML, but introduces a more general approach for processing XML with Haskell. @@ -171,6 +171,7 @@ filepath >= 1 && < 2, parsec >= 2.1 && < 4, HUnit >= 1.2 && < 2, + mtl >= 2 && < 3, network >= 2.1 && < 3, deepseq >= 1.1 && < 2, bytestring >= 0.9 && < 1, diff --git a/src/Text/XML/HXT/Arrow/Pickle.hs b/src/Text/XML/HXT/Arrow/Pickle.hs --- a/src/Text/XML/HXT/Arrow/Pickle.hs +++ b/src/Text/XML/HXT/Arrow/Pickle.hs @@ -49,6 +49,7 @@ -- from Text.XML.HXT.Arrow.Pickle.Xml , pickleDoc , unpickleDoc + , unpickleDoc' , showPickled , PU(..) @@ -77,18 +78,25 @@ , xp24Tuple , xpAddFixedAttr + , xpAddNSDecl , xpAlt , xpAttr - , xpTextAttr , xpAttrFixed , xpAttrImplied + , xpAttrNS + , xpCheckEmpty + , xpCheckEmptyAttributes + , xpCheckEmptyContents + , xpTextAttr , xpChoice - , xpCondSeq , xpDefault , xpElem + , xpElemNS , xpElemWithAttrValue , xpickle + , xpInt , xpLift + , xpLiftEither , xpLiftMaybe , xpList , xpList1 @@ -96,7 +104,6 @@ , xpOption , xpPair , xpPrim - , xpInt , xpSeq , xpText , xpText0 @@ -107,6 +114,7 @@ , xpTriple , xpUnit , xpWrap + , xpWrapEither , xpWrapMaybe , xpXmlText , xpZero @@ -118,8 +126,6 @@ ) where -import Data.Maybe - import Control.Arrow.ListArrows import Text.XML.HXT.DOM.Interface @@ -233,13 +239,7 @@ >>> readFromString [withValidate True] >>> - ( xunpickleVal xp - `orElse` - ( issueErr "unpickling the document failed" - >>> - none - ) - ) + xunpickleVal xp ) &&& this @@ -257,6 +257,7 @@ -- | The arrow version of the unpickler function +{- old version, runs outside IO xunpickleVal :: ArrowXml a => PU b -> a XmlTree b xunpickleVal xp = ( processChildren (none `whenNot` isElem) -- remove all stuff surrounding the root element `when` @@ -264,6 +265,23 @@ ) >>> arrL (maybeToList . unpickleDoc xp) +-- -} + +xunpickleVal :: PU b -> IOStateArrow s XmlTree b +xunpickleVal xp = ( processChildren (none `whenNot` isElem) -- remove all stuff surrounding the root element + `when` + isRoot + ) + >>> + arr (unpickleDoc' xp) + >>> + ( ( (issueFatal $< arr ("document unpickling failed\n" ++)) + >>> + none + ) + ||| + this + ) -- | Compute the associated DTD of a pickler diff --git a/src/Text/XML/HXT/Arrow/Pickle/Xml.hs b/src/Text/XML/HXT/Arrow/Pickle/Xml.hs --- a/src/Text/XML/HXT/Arrow/Pickle/Xml.hs +++ b/src/Text/XML/HXT/Arrow/Pickle/Xml.hs @@ -1,951 +1,1382 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} - --- ------------------------------------------------------------ - -{- | - Module : Text.XML.HXT.Arrow.Pickle.Xml - Copyright : Copyright (C) 2005-2008 Uwe Schmidt - License : MIT - - Maintainer : Uwe Schmidt (uwe@fh-wedel.de) - Stability : experimental - Portability: portable - - Pickler functions for converting between user defined data types - and XmlTree data. Usefull for persistent storage and retreival - of arbitray data as XML documents - - This module is an adaptation of the pickler combinators - developed by Andrew Kennedy - ( http:\/\/research.microsoft.com\/~akenn\/fun\/picklercombinators.pdf ) - - The difference to Kennedys approach is that the target is not - a list of Chars but a list of XmlTrees. The basic picklers will - convert data into XML text nodes. New are the picklers for - creating elements and attributes. - - One extension was neccessary: The unpickling may fail. - Therefore the unpickler has a Maybe result type. - Failure is used to unpickle optional elements - (Maybe data) and lists of arbitray length - - There is an example program demonstrating the use - of the picklers for a none trivial data structure. - (see \"examples\/arrows\/pickle\" directory) - --} - --- ------------------------------------------------------------ - -module Text.XML.HXT.Arrow.Pickle.Xml -where - -import Control.Arrow.ListArrows - -import Data.Char (isDigit) -import Data.List (foldl') -import Data.Maybe -import Data.Map (Map) -import qualified Data.Map as M - -import Text.XML.HXT.DOM.Interface -import qualified Text.XML.HXT.DOM.XmlNode as XN - -import Text.XML.HXT.Arrow.Edit (xshowEscapeXml) -import Text.XML.HXT.Arrow.Pickle.Schema -import Text.XML.HXT.Arrow.ReadDocument (xread) -import Text.XML.HXT.Arrow.WriteDocument (writeDocumentToString) -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlState - --- ------------------------------------------------------------ - -data St = St { attributes :: [XmlTree] - , contents :: [XmlTree] - } - -data PU a = PU { appPickle :: (a, St) -> St - , appUnPickle :: St -> (Maybe a, St) - , theSchema :: Schema - } - -emptySt :: St -emptySt = St { attributes = [] - , contents = [] - } - -addAtt :: XmlTree -> St -> St -addAtt x s = s {attributes = x : attributes s} - -addCont :: XmlTree -> St -> St -addCont x s = s {contents = x : contents s} - -dropCont :: St -> St -dropCont s = s { contents = drop 1 (contents s) } - -getAtt :: QName -> St -> Maybe XmlTree -getAtt qn s - = listToMaybe $ - runLA ( arrL attributes - >>> - isAttr >>> hasQName qn - ) s - -getCont :: St -> Maybe XmlTree -getCont s = listToMaybe . contents $ s - --- ------------------------------------------------------------ - --- | conversion of an arbitrary value into an XML document tree. --- --- The pickler, first parameter, controls the conversion process. --- Result is a complete document tree including a root node - -pickleDoc :: PU a -> a -> XmlTree -pickleDoc p v - = XN.mkRoot (attributes st) (contents st) - where - st = appPickle p (v, emptySt) - --- | Conversion of an XML document tree into an arbitrary data type --- --- The inverse of 'pickleDoc'. --- This law should hold for all picklers: @ unpickle px . pickle px $ v == Just v @. --- Not every possible combination of picklers make sense. --- For reconverting a value from an XML tree, is becomes neccessary, --- to introduce \"enough\" markup for unpickling the value - -unpickleDoc :: PU a -> XmlTree -> Maybe a -unpickleDoc p t - | XN.isRoot t - = fst . appUnPickle p $ St { attributes = fromJust . XN.getAttrl $ t - , contents = XN.getChildren t - } - | otherwise - = unpickleDoc p (XN.mkRoot [] [t]) - --- ------------------------------------------------------------ - --- | Pickles a value, then writes the document to a string. - -showPickled :: (XmlPickler a) => SysConfigList -> a -> String -showPickled a = concat . (pickleDoc xpickle >>> runLA (writeDocumentToString a)) - --- ------------------------------------------------------------ - --- | The zero pickler --- --- Encodes nothing, fails always during unpickling - -xpZero :: PU a -xpZero = PU { appPickle = snd - , appUnPickle = \ s -> (Nothing, s) - , theSchema = scNull - } - --- unit pickler - -xpUnit :: PU () -xpUnit = xpLift () - --- | Lift a value to a pickler --- --- When pickling, nothing is encoded, when unpickling, the given value is inserted. --- This pickler always succeeds. - -xpLift :: a -> PU a -xpLift x = PU { appPickle = snd - , appUnPickle = \ s -> (Just x, s) - , theSchema = scEmpty - } - --- | Lift a Maybe value to a pickler. --- --- @Nothing@ is mapped to the zero pickler, @Just x@ is pickled with @xpLift x@. - -xpLiftMaybe :: Maybe a -> PU a -xpLiftMaybe v = (xpLiftMaybe' v) { theSchema = scOption scEmpty } - where - xpLiftMaybe' Nothing = xpZero - xpLiftMaybe' (Just x) = xpLift x - - --- | pickle\/unpickle combinator for sequence and choice. --- --- When the first unpickler fails, --- the second one is taken, else the third one configured with the result from the first --- is taken. This pickler is a generalisation for 'xpSeq' and 'xpChoice' . --- --- The schema must be attached later, e.g. in xpPair or other higher level combinators - -xpCondSeq :: PU b -> (b -> a) -> PU a -> (a -> PU b) -> PU b -xpCondSeq pd f pa k - = PU { appPickle = ( \ (b, s) -> - let - a = f b - pb = k a - in - appPickle pa (a, (appPickle pb (b, s))) - ) - , appUnPickle = ( \ s -> - let - (a, s') = appUnPickle pa s - in - case a of - Nothing -> appUnPickle pd s - Just a' -> appUnPickle (k a') s' - ) - , theSchema = undefined - } - - --- | Combine two picklers sequentially. --- --- If the first fails during --- unpickling, the whole unpickler fails - -xpSeq :: (b -> a) -> PU a -> (a -> PU b) -> PU b -xpSeq = xpCondSeq xpZero - - --- | combine tow picklers with a choice --- --- Run two picklers in sequence like with xpSeq. --- When during unpickling the first one fails, --- an alternative pickler (first argument) is applied. --- This pickler is only used as combinator for unpickling. - -xpChoice :: PU b -> PU a -> (a -> PU b) -> PU b -xpChoice pb = xpCondSeq pb undefined - - --- | map value into another domain and apply pickler there --- --- One of the most often used picklers. - -xpWrap :: (a -> b, b -> a) -> PU a -> PU b -xpWrap (i, j) pa = (xpSeq j pa (xpLift . i)) { theSchema = theSchema pa } - --- | like 'xpWrap', but if the inverse mapping is undefined, the unpickler fails --- --- Map a value into another domain. If the inverse mapping is --- undefined (Nothing), the unpickler fails - -xpWrapMaybe :: (a -> Maybe b, b -> a) -> PU a -> PU b -xpWrapMaybe (i, j) pa = (xpSeq j pa (xpLiftMaybe . i)) { theSchema = theSchema pa } - --- ------------------------------------------------------------ - --- | pickle a pair of values sequentially --- --- Used for pairs or together with wrap for pickling --- algebraic data types with two components - -xpPair :: PU a -> PU b -> PU (a, b) -xpPair pa pb - = ( xpSeq fst pa (\ a -> - xpSeq snd pb (\ b -> - xpLift (a,b))) - ) { theSchema = scSeq (theSchema pa) (theSchema pb) } - --- | Like 'xpPair' but for triples - -xpTriple :: PU a -> PU b -> PU c -> PU (a, b, c) -xpTriple pa pb pc - = xpWrap (toTriple, fromTriple) (xpPair pa (xpPair pb pc)) - where - toTriple ~(a, ~(b, c)) = (a, b, c ) - fromTriple ~(a, b, c ) = (a, (b, c)) - --- | Like 'xpPair' and 'xpTriple' but for 4-tuples - -xp4Tuple :: PU a -> PU b -> PU c -> PU d -> PU (a, b, c, d) -xp4Tuple pa pb pc pd - = xpWrap (toQuad, fromQuad) (xpPair pa (xpPair pb (xpPair pc pd))) - where - toQuad ~(a, ~(b, ~(c, d))) = (a, b, c, d ) - fromQuad ~(a, b, c, d ) = (a, (b, (c, d))) - --- | Like 'xpPair' and 'xpTriple' but for 5-tuples - -xp5Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU (a, b, c, d, e) -xp5Tuple pa pb pc pd pe - = xpWrap (toQuint, fromQuint) (xpPair pa (xpPair pb (xpPair pc (xpPair pd pe)))) - where - toQuint ~(a, ~(b, ~(c, ~(d, e)))) = (a, b, c, d, e ) - fromQuint ~(a, b, c, d, e ) = (a, (b, (c, (d, e)))) - --- | Like 'xpPair' and 'xpTriple' but for 6-tuples - -xp6Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU f -> PU (a, b, c, d, e, f) -xp6Tuple pa pb pc pd pe pf - = xpWrap (toSix, fromSix) (xpPair pa (xpPair pb (xpPair pc (xpPair pd (xpPair pe pf))))) - where - toSix ~(a, ~(b, ~(c, ~(d, ~(e, f))))) = (a, b, c, d, e, f ) - fromSix ~(a, b, c, d, e, f) = (a, (b, (c, (d, (e, f))))) - --- ------------------------------------------------------------ - --- | Like 'xpPair' and 'xpTriple' but for 7-tuples --- --- Thanks to Tony Morris for doing xp7Tuple, ..., xp24Tuple. - -xp7Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU (a, b, c, d, e, f, g) -xp7Tuple a b c d e f g - = xpWrap ( \ (a, (b, c, d, e, f, g)) -> (a, b, c, d, e, f, g) - , \ (a, b, c, d, e, f, g) -> (a, (b, c, d, e, f, g)) - ) - (xpPair a (xp6Tuple b c d e f g)) - -xp8Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU (a, b, c, d, e, f, g, h) -xp8Tuple a b c d e f g h - = xpWrap ( \ ((a, b), (c, d, e, f, g, h)) -> (a, b, c, d, e, f, g, h) - , \ (a, b, c, d, e, f, g, h) -> ((a, b), (c, d, e, f, g, h)) - ) - (xpPair (xpPair a b) (xp6Tuple c d e f g h)) - -xp9Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU (a, b, c, d, e, f, g, h, i) -xp9Tuple a b c d e f g h i - = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i)) -> (a, b, c, d, e, f, g, h, i) - , \ (a, b, c, d, e, f, g, h, i) -> ((a, b, c), (d, e, f, g, h, i)) - ) - (xpPair (xpTriple a b c) (xp6Tuple d e f g h i)) - -xp10Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU j -> - PU (a, b, c, d, e, f, g, h, i, j) -xp10Tuple a b c d e f g h i j - = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j)) -> (a, b, c, d, e, f, g, h, i, j) - , \ (a, b, c, d, e, f, g, h, i, j) -> ((a, b, c, d), (e, f, g, h, i, j)) - ) - (xpPair (xp4Tuple a b c d) (xp6Tuple e f g h i j)) - -xp11Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU j -> - PU k -> PU (a, b, c, d, e, f, g, h, i, j, k) -xp11Tuple a b c d e f g h i j k - = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k)) -> (a, b, c, d, e, f, g, h, i, j, k) - , \ (a, b, c, d, e, f, g, h, i, j, k) -> ((a, b, c, d, e), (f, g, h, i, j, k)) - ) - (xpPair (xp5Tuple a b c d e) (xp6Tuple f g h i j k)) - -xp12Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU j -> - PU k -> PU l -> PU (a, b, c, d, e, f, g, h, i, j, k, l) -xp12Tuple a b c d e f g h i j k l - = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l)) -> (a, b, c, d, e, f, g, h, i, j, k, l) - , \ (a, b, c, d, e, f, g, h, i, j, k, l) -> ((a, b, c, d, e, f), (g, h, i, j, k, l)) - ) - (xpPair (xp6Tuple a b c d e f) (xp6Tuple g h i j k l)) - -xp13Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU j -> - PU k -> PU l -> PU m -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m) -xp13Tuple a b c d e f g h i j k l m - = xpWrap ( \ (a, (b, c, d, e, f, g), (h, i, j, k, l, m)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m) - , \ (a, b, c, d, e, f, g, h, i, j, k, l, m) -> (a, (b, c, d, e, f, g), (h, i, j, k, l, m)) - ) - (xpTriple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m)) - -xp14Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU j -> - PU k -> PU l -> PU m -> PU n -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -xp14Tuple a b c d e f g h i j k l m n - = xpWrap ( \ ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n) - , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n)) - ) - (xpTriple (xpPair a b) (xp6Tuple c d e f g h) (xp6Tuple i j k l m n)) - -xp15Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU j -> - PU k -> PU l -> PU m -> PU n -> PU o -> - PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -xp15Tuple a b c d e f g h i j k l m n o - = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) - , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o)) - ) - (xpTriple (xpTriple a b c) (xp6Tuple d e f g h i) (xp6Tuple j k l m n o)) - -xp16Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU j -> - PU k -> PU l -> PU m -> PU n -> PU o -> - PU p -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) -xp16Tuple a b c d e f g h i j k l m n o p - = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) - , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) -> ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p)) - ) - (xpTriple (xp4Tuple a b c d) (xp6Tuple e f g h i j) (xp6Tuple k l m n o p)) - -xp17Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU j -> - PU k -> PU l -> PU m -> PU n -> PU o -> - PU p -> PU q -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) -xp17Tuple a b c d e f g h i j k l m n o p q - = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) - , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) -> ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q)) - ) - (xpTriple (xp5Tuple a b c d e) (xp6Tuple f g h i j k) (xp6Tuple l m n o p q)) - -xp18Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU j -> - PU k -> PU l -> PU m -> PU n -> PU o -> - PU p -> PU q -> PU r -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) -xp18Tuple a b c d e f g h i j k l m n o p q r - = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) - , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) -> ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r)) - ) - (xpTriple (xp6Tuple a b c d e f) (xp6Tuple g h i j k l) (xp6Tuple m n o p q r)) - -xp19Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU j -> - PU k -> PU l -> PU m -> PU n -> PU o -> - PU p -> PU q -> PU r -> PU s -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) -xp19Tuple a b c d e f g h i j k l m n o p q r s - = xpWrap ( \ (a, (b, c, d, e, f, g), (h, i, j, k, l, m), (n, o, p, q, r, s)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) - , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) -> (a, (b, c, d, e, f, g), (h, i, j, k, l, m), (n, o, p, q, r, s)) - ) - (xp4Tuple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m) (xp6Tuple n o p q r s)) - -xp20Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU j -> - PU k -> PU l -> PU m -> PU n -> PU o -> - PU p -> PU q -> PU r -> PU s -> PU t -> - PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) -xp20Tuple a b c d e f g h i j k l m n o p q r s t - = xpWrap ( \ ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n), (o, p, q, r, s, t)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) - , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) -> ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n), (o, p, q, r, s, t)) - ) - (xp4Tuple (xpPair a b) (xp6Tuple c d e f g h) (xp6Tuple i j k l m n) (xp6Tuple o p q r s t)) - -xp21Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU j -> - PU k -> PU l -> PU m -> PU n -> PU o -> - PU p -> PU q -> PU r -> PU s -> PU t -> - PU u -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) -xp21Tuple a b c d e f g h i j k l m n o p q r s t u - = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o), (p, q, r, s, t, u)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) - , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) -> ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o), (p, q, r, s, t, u)) - ) - (xp4Tuple (xpTriple a b c) (xp6Tuple d e f g h i) (xp6Tuple j k l m n o) (xp6Tuple p q r s t u)) - -xp22Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU j -> - PU k -> PU l -> PU m -> PU n -> PU o -> - PU p -> PU q -> PU r -> PU s -> PU t -> - PU u -> PU v -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) -xp22Tuple a b c d e f g h i j k l m n o p q r s t u v - = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p), (q, r, s, t, u, v)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) - , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) -> ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p), (q, r, s, t, u, v)) - ) - (xp4Tuple (xp4Tuple a b c d) (xp6Tuple e f g h i j) (xp6Tuple k l m n o p) (xp6Tuple q r s t u v)) - -xp23Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU j -> - PU k -> PU l -> PU m -> PU n -> PU o -> - PU p -> PU q -> PU r -> PU s -> PU t -> - PU u -> PU v -> PU w -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) -xp23Tuple a b c d e f g h i j k l m n o p q r s t u v w - = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q), (r, s, t, u, v, w)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) - , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) -> ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q), (r, s, t, u, v, w)) - ) - (xp4Tuple (xp5Tuple a b c d e) (xp6Tuple f g h i j k) (xp6Tuple l m n o p q) (xp6Tuple r s t u v w)) - --- | Hopefully no one needs a xp25Tuple - -xp24Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> - PU f -> PU g -> PU h -> PU i -> PU j -> - PU k -> PU l -> PU m -> PU n -> PU o -> - PU p -> PU q -> PU r -> PU s -> PU t -> - PU u -> PU v -> PU w -> PU x -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) -xp24Tuple a b c d e f g h i j k l m n o p q r s t u v w x - = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r), (s, t, u, v, w, x)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) - , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) -> ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r), (s, t, u, v, w, x)) - ) - (xp4Tuple (xp6Tuple a b c d e f) (xp6Tuple g h i j k l) (xp6Tuple m n o p q r) (xp6Tuple s t u v w x)) - --- ------------------------------------------------------------ - - --- | Pickle a string into an XML text node --- --- One of the most often used primitive picklers. Attention: --- For pickling empty strings use 'xpText0'. If the text has a more --- specific datatype than xsd:string, use 'xpTextDT' - -xpText :: PU String -xpText = xpTextDT scString1 -{-# INLINE xpText #-} - --- | Pickle a string into an XML text node --- --- Text pickler with a description of the structure of the text --- by a schema. A schema for a data type can be defined by 'Text.XML.HXT.Arrow.Pickle.Schema.scDT'. --- In 'Text.XML.HXT.Arrow.Pickle.Schema' there are some more functions for creating --- simple datatype descriptions. - -xpTextDT :: Schema -> PU String -xpTextDT sc - = PU { appPickle = \ (s, st) -> addCont (XN.mkText s) st - , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleString st) - , theSchema = sc - } - where - unpickleString st - = do - t <- getCont st - s <- XN.getText t - return (Just s, dropCont st) - --- | Pickle a possibly empty string into an XML node. --- --- Must be used in all places, where empty strings are legal values. --- If the content of an element can be an empty string, this string disapears --- during storing the DOM into a document and reparse the document. --- So the empty text node becomes nothing, and the pickler must deliver an empty string, --- if there is no text node in the document. - -xpText0 :: PU String -xpText0 = xpText0DT scString1 -{-# INLINE xpText0 #-} - --- | Pickle a possibly empty string with a datatype description into an XML node. --- --- Like 'xpText0' but with extra Parameter for datatype description as in 'xpTextDT'. - -xpText0DT :: Schema -> PU String -xpText0DT sc - = xpWrap (fromMaybe "", emptyToNothing) $ xpOption $ xpTextDT sc - where - emptyToNothing "" = Nothing - emptyToNothing x = Just x - --- | Pickle an arbitrary value by applyling show during pickling --- and read during unpickling. --- --- Real pickling is then done with 'xpText'. --- One of the most often used pimitive picklers. Applicable for all --- types which are instances of @Read@ and @Show@ - -xpPrim :: (Read a, Show a) => PU a -xpPrim - = xpWrapMaybe (readMaybe, show) xpText - where - readMaybe :: Read a => String -> Maybe a - readMaybe str - = val (reads str) - where - val [(x,"")] = Just x - val _ = Nothing - --- | Pickle an unsigned -xpInt :: PU Int -xpInt - = xpWrapMaybe (readMaybe, show) xpText - where - readMaybe xs - | all isDigit xs = Just . foldl' (\ r c -> 10 * r + (fromEnum c - fromEnum '0')) 0 $ xs - readMaybe ('-' : xs) = fmap (0 -) . readMaybe $ xs - readMaybe ('+' : xs) = readMaybe $ xs - readMaybe _ = Nothing - --- ------------------------------------------------------------ - --- | Pickle an XmlTree by just adding it --- --- Usefull for components of type XmlTree in other data structures - -xpTree :: PU XmlTree -xpTree = PU { appPickle = \ (s, st) -> addCont s st - , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleTree st) - , theSchema = Any - } - where - unpickleTree st - = do - t <- getCont st - return (Just t, dropCont st) - --- | Pickle a whole list of XmlTrees by just adding the list, unpickle is done by taking all element contents. --- --- This pickler should always be combined with 'xpElem' for taking the whole contents of an element. - -xpTrees :: PU [XmlTree] -xpTrees = (xpList xpTree) { theSchema = Any } - --- | Pickle a string representing XML contents by inserting the tree representation into the XML document. --- --- Unpickling is done by converting the contents with --- 'Text.XML.HXT.Arrow.Edit.xshowEscapeXml' into a string, --- this function will escape all XML special chars, such that pickling the value back becomes save. --- Pickling is done with 'Text.XML.HXT.Arrow.ReadDocument.xread' - -xpXmlText :: PU String -xpXmlText - = xpWrap ( showXML, readXML ) $ xpTrees - where - showXML = concat . runLA ( xshowEscapeXml unlistA ) - readXML = runLA xread - --- ------------------------------------------------------------ - --- | Encoding of optional data by ignoring the Nothing case during pickling --- and relying on failure during unpickling to recompute the Nothing case --- --- The default pickler for Maybe types - -xpOption :: PU a -> PU (Maybe a) -xpOption pa - = PU { appPickle = ( \ (a, st) -> - case a of - Nothing -> st - Just x -> appPickle pa (x, st) - ) - - , appUnPickle = appUnPickle $ - xpChoice (xpLift Nothing) pa (xpLift . Just) - - , theSchema = scOption (theSchema pa) - } - --- | Optional conversion with default value --- --- The default value is not encoded in the XML document, --- during unpickling the default value is inserted if the pickler fails - -xpDefault :: (Eq a) => a -> PU a -> PU a -xpDefault df - = xpWrap ( fromMaybe df - , \ x -> if x == df then Nothing else Just x - ) . - xpOption - --- ------------------------------------------------------------ - --- | Encoding of list values by pickling all list elements sequentially. --- --- Unpickler relies on failure for detecting the end of the list. --- The standard pickler for lists. Can also be used in combination with 'xpWrap' --- for constructing set and map picklers - -xpList :: PU a -> PU [a] -xpList pa - = PU { appPickle = ( \ (a, st) -> - case a of - [] -> st - _:_ -> appPickle pc (a, st) - ) - , appUnPickle = appUnPickle $ - xpChoice (xpLift []) pa - (\ x -> xpSeq id (xpList pa) (\xs -> xpLift (x:xs))) - - , theSchema = scList (theSchema pa) - } - where - pc = xpSeq head pa (\ x -> - xpSeq tail (xpList pa) (\ xs -> - xpLift (x:xs))) - --- | Encoding of a none empty list of values --- --- Attention: when calling this pickler with an empty list, --- an internal error \"head of empty list is raised\". - -xpList1 :: PU a -> PU [a] -xpList1 pa - = ( xpWrap (\ (x, xs) -> x : xs - ,\ x -> (head x, tail x) - ) $ - xpPair pa (xpList pa) - ) { theSchema = scList1 (theSchema pa) } - --- ------------------------------------------------------------ - --- | Standard pickler for maps --- --- This pickler converts a map into a list of pairs. --- All key value pairs are mapped to an element with name (1.arg), --- the key is encoded as an attribute named by the 2. argument, --- the 3. arg is the pickler for the keys, the last one for the values - -xpMap :: Ord k => String -> String -> PU k -> PU v -> PU (Map k v) -xpMap en an xpk xpv - = xpWrap ( M.fromList - , M.toList - ) $ - xpList $ - xpElem en $ - xpPair ( xpAttr an $ xpk ) xpv - - --- ------------------------------------------------------------ - --- | Pickler for sum data types. --- --- Every constructor is mapped to an index into the list of picklers. --- The index is used only during pickling, not during unpickling, there the 1. match is taken - -xpAlt :: (a -> Int) -> [PU a] -> PU a -xpAlt tag ps - = PU { appPickle = ( \ (a, st) -> - let - pa = ps !! (tag a) - in - appPickle pa (a, st) - ) - , appUnPickle = appUnPickle $ - ( case ps of - [] -> xpZero - pa:ps1 -> xpChoice (xpAlt tag ps1) pa xpLift - ) - , theSchema = scAlts (map theSchema ps) - } - --- ------------------------------------------------------------ - --- | Pickler for wrapping\/unwrapping data into an XML element --- --- Extra parameter is the element name given as a QName. THE pickler for constructing --- nested structures --- --- Example: --- --- > xpElemQN (mkName "number") $ xpickle --- --- will map an (42::Int) onto --- --- > 42 - -xpElemQN :: QName -> PU a -> PU a -xpElemQN qn pa - = PU { appPickle = ( \ (a, st) -> - let - st' = appPickle pa (a, emptySt) - in - addCont (XN.mkElement qn (attributes st') (contents st')) st - ) - , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st) - , theSchema = scElem (qualifiedName qn) (theSchema pa) - } - where - unpickleElement st - = do - t <- getCont st - n <- XN.getElemName t - if n /= qn - then fail ("element name " ++ show n ++ " does not match" ++ show qn) - else do - let cs = XN.getChildren t - al <- XN.getAttrl t - res <- fst . appUnPickle pa $ St {attributes = al, contents = cs} - return (Just res, dropCont st) - --- | convenient Pickler for xpElemQN --- --- > xpElem n = xpElemQN (mkName n) - -xpElem :: String -> PU a -> PU a -xpElem = xpElemQN . mkName - --- ------------------------------------------------------------ - --- | Pickler for wrapping\/unwrapping data into an XML element with an attribute with given value --- --- To make XML structures flexible but limit the number of different elements, it's sometimes --- useful to use a kind of generic element with a key value structure --- --- Example: --- --- > value1 --- > value2 --- > value3 --- --- the Haskell datatype may look like this --- --- > type T = T { key1 :: Int ; key2 :: String ; key3 :: Double } --- --- Then the picker for that type looks like this --- --- > xpT :: PU T --- > xpT = xpWrap ( uncurry3 T, \ t -> (key1 t, key2 t, key3 t) ) $ --- > xpTriple (xpElemWithAttrValue "attr" "name" "key1" $ xpickle) --- > (xpElemWithAttrValue "attr" "name" "key2" $ xpText0) --- > (xpElemWithAttrValue "attr" "name" "key3" $ xpickle) - -xpElemWithAttrValue :: String -> String -> String -> PU a -> PU a -xpElemWithAttrValue name an av pa - = PU { appPickle = ( \ (a, st) -> - let - st' = appPickle pa' (a, emptySt) - in - addCont (XN.mkElement (mkName name) (attributes st') (contents st')) st - ) - , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st) - , theSchema = scElem name (theSchema pa') - } - where - pa' = xpAddFixedAttr an av $ pa - noMatch = null . runLA ( isElem - >>> - hasName name - >>> - hasAttrValue an (==av) - ) - unpickleElement st - = do - t <- getCont st - if noMatch t - then fail "element name or attr value does not match" - else do - let cs = XN.getChildren t - al <- XN.getAttrl t - res <- fst . appUnPickle pa $ St {attributes = al, contents = cs} - return (Just res, dropCont st) - --- ------------------------------------------------------------ - --- | Pickler for storing\/retreiving data into\/from an attribute value --- --- The attribute is inserted in the surrounding element constructed by the 'xpElem' pickler - -xpAttrQN :: QName -> PU a -> PU a -xpAttrQN qn pa - = PU { appPickle = ( \ (a, st) -> - let - st' = appPickle pa (a, emptySt) - in - addAtt (XN.mkAttr qn (contents st')) st - ) - , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleAttr st) - , theSchema = scAttr (qualifiedName qn) (theSchema pa) - } - where - unpickleAttr st - = do - a <- getAtt qn st - let av = XN.getChildren a - res <- fst . appUnPickle pa $ St {attributes = [], contents = av} - return (Just res, st) -- attribute is not removed from attribute list, - -- attributes are selected by name - --- | convenient Pickler for xpAttrQN --- --- > xpAttr n = xpAttrQN (mkName n) - -xpAttr :: String -> PU a -> PU a -xpAttr = xpAttrQN . mkName - --- | A text attribute. -xpTextAttr :: String -> PU String -xpTextAttr = flip xpAttr xpText - --- | Add an optional attribute for an optional value (Maybe a). - -xpAttrImplied :: String -> PU a -> PU (Maybe a) -xpAttrImplied name pa - = xpOption $ xpAttr name pa - -xpAttrFixed :: String -> String -> PU () -xpAttrFixed name val - = ( xpWrapMaybe ( \ v -> if v == val then Just () else Nothing - , const val - ) $ - xpAttr name xpText - ) { theSchema = scAttr name (scFixed val) } - --- | Add an attribute with a fixed value. --- --- Useful e.g. to declare namespaces. Is implemented by 'xpAttrFixed' - -xpAddFixedAttr :: String -> String -> PU a -> PU a -xpAddFixedAttr name val pa - = xpWrap ( snd - , (,) () - ) $ - xpPair (xpAttrFixed name val) pa - --- ------------------------------------------------------------ - --- | The class for overloading 'xpickle', the default pickler - -class XmlPickler a where - xpickle :: PU a - -instance XmlPickler Int where - xpickle = xpPrim - -instance XmlPickler Integer where - xpickle = xpPrim - -{- - no instance of XmlPickler Char - because then every text would be encoded - char by char, because of the instance for lists - -instance XmlPickler Char where - xpickle = xpPrim --} - -instance XmlPickler () where - xpickle = xpUnit - -instance (XmlPickler a, XmlPickler b) => XmlPickler (a,b) where - xpickle = xpPair xpickle xpickle - -instance (XmlPickler a, XmlPickler b, XmlPickler c) => XmlPickler (a,b,c) where - xpickle = xpTriple xpickle xpickle xpickle - -instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d) => XmlPickler (a,b,c,d) where - xpickle = xp4Tuple xpickle xpickle xpickle xpickle - -instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e) => XmlPickler (a,b,c,d,e) where - xpickle = xp5Tuple xpickle xpickle xpickle xpickle xpickle - -instance XmlPickler a => XmlPickler [a] where - xpickle = xpList xpickle - -instance XmlPickler a => XmlPickler (Maybe a) where - xpickle = xpOption xpickle - --- ------------------------------------------------------------ - --- ------------------------------------------------------------ -{- --- | Extra library functions for HXT. -module Text.XML.HXT.Extras( - showPickled, - textAttr, - xp7Tuple, - xp8Tuple, - xp9Tuple, - xp10Tuple, - xp11Tuple, - xp12Tuple, - xp13Tuple, - xp14Tuple, - xp15Tuple, - xp16Tuple, - xp17Tuple, - xp18Tuple, - xp19Tuple, - xp20Tuple, - xp21Tuple, - xp22Tuple, - xp23Tuple, - xp24Tuple - ) where - -import Text.XML.HXT.Arrow - --- | Pickles a value then writes the document to a string. -showPickled :: (XmlPickler a) => Attributes -> a -> String -showPickled a = concat . (pickleDoc xpickle >>> runLA (writeDocumentToString a)) - --- | A text attribute. -textAttr :: String -> PU String -textAttr = flip xpAttr xpText --} --- ------------------------------------------------------------ - +{-# OPTIONS -XMultiParamTypeClasses -XTypeSynonymInstances #-} + +-- ------------------------------------------------------------ + +{- | + Module : Text.XML.HXT.Arrow.Pickle.Xml + Copyright : Copyright (C) 2005-2012 Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + Stability : stable + Portability: portable + + Pickler functions for converting between user defined data types + and XmlTree data. Usefull for persistent storage and retreival + of arbitray data as XML documents. + + This module is an adaptation of the pickler combinators + developed by Andrew Kennedy + ( http:\/\/research.microsoft.com\/~akenn\/fun\/picklercombinators.pdf ). + + The difference to Kennedys approach is that the target is not + a list of Chars but a list of XmlTrees. The basic picklers will + convert data into XML text nodes. New are the picklers for + creating elements and attributes. + + One extension was neccessary: The unpickling may fail. + + Old: Therefore the unpickler has a Maybe result type. + Failure is used to unpickle optional elements + (Maybe data) and lists of arbitray length. + + Since hxt-9.2.0: The unpicklers are implemented as + a parser monad with an Either err val result type. + This enables appropriate error messages , when unpickling + XML stuff, that is not generated with the picklers and which contains + some elements and/or attributes that are not handled when unpickling. + + There is an example program demonstrating the use + of the picklers for a none trivial data structure. + (see \"examples\/arrows\/pickle\" directory in the hxt distribution) + +-} + +-- ------------------------------------------------------------ + +module Text.XML.HXT.Arrow.Pickle.Xml +where + +import Control.Arrow.ArrowList +import Control.Arrow.ListArrows +import Control.Monad +import Control.Monad.Error +import Control.Monad.State + +import Data.Char (isDigit) +import Data.List (foldl') +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as M + +import Text.XML.HXT.DOM.Interface +import qualified Text.XML.HXT.DOM.XmlNode as XN +import qualified Text.XML.HXT.DOM.ShowXml as XN +import Text.XML.HXT.Arrow.Edit (xshowEscapeXml) +import Text.XML.HXT.Arrow.Pickle.Schema +import Text.XML.HXT.Arrow.ReadDocument (xread) +import Text.XML.HXT.Arrow.WriteDocument (writeDocumentToString) +import Text.XML.HXT.Arrow.XmlState + +{- just for embedded test cases +import Text.XML.HXT.Arrow.XmlArrow +import qualified Control.Arrow.ListArrows as X +-- -} + +-- ------------------------------------------------------------ + +data St = St { attributes :: [XmlTree] + , contents :: [XmlTree] + , nesting :: Int -- the remaining 3 fields are used only for unpickling + , pname :: QName -- to generate appropriate error messages + , pelem :: Bool + } deriving (Show) + +data PU a = PU { appPickle :: Pickler a -- (a, St) -> St + , appUnPickle :: Unpickler a + , theSchema :: Schema + } + +-- -------------------- +-- +-- The pickler + +type Pickler a = a -> St -> St + +-- -------------------- +-- +-- The unpickler monad, a combination of state and error monad + +newtype Unpickler a = UP { runUP :: St -> (UnpickleVal a, St) } + +type UnpickleVal a = Either UnpickleErr a + +type UnpickleErr = (String, St) + +instance Monad Unpickler where + return x = UP $ \ st -> (Right x, st) + u >>= f = UP $ \ st -> + let (r, st') = runUP u st in + case r of + Left err -> (Left err, st') + Right v -> runUP (f v) st' + fail = throwMsg -- don't use fail, use throwError + + +instance MonadState St Unpickler where + get = UP $ \ st -> (Right st, st) + put st = UP $ \ _ -> (Right (), st) + +instance MonadError UnpickleErr Unpickler where + throwError err + = UP $ \ st -> (Left err, st) + + -- redundant, not (yet) used + catchError u handler + = UP $ \ st -> + let (r, st') = runUP u st in + case r of + Left err -> runUP (handler err) st -- not st', state will be reset in error case + _ -> (r, st') + +throwMsg :: String -> Unpickler a +throwMsg msg = UP $ \ st -> (Left (msg, st), st) + +-- | Choice combinator for unpickling +-- +-- first 2 arguments are applied sequentially, but if the 1. one fails the +-- 3. arg is applied + +mchoice :: Unpickler a -> (a -> Unpickler b) -> Unpickler b -> Unpickler b +mchoice u f v = UP $ \ st -> + let (r, st') = runUP u st in + case r of + Right x + -> runUP (f x) st' -- success + Left e@(_msg, st'') + -> if nesting st'' == nesting st -- true: failure in parsing curr contents + then runUP v st -- try the alternative unpickler + else (Left e, st') -- false: failure in unpickling a subtree of + -- the current contents, so the whole unpickler + -- must fail + +-- | Lift a Maybe value into the Unpickler monad. +-- +-- The 1. arg is the attached error message + +liftMaybe :: String -> Maybe a -> Unpickler a +liftMaybe e v = case v of + Nothing -> throwMsg e + Just x -> return x + +-- | Lift an Either value into the Unpickler monad + +liftUnpickleVal :: UnpickleVal a -> Unpickler a +liftUnpickleVal v = UP $ \ st -> (v, st) + +-- -------------------- + +getCont :: Unpickler XmlTree +getCont = do cs <- gets contents + case cs of + [] -> throwMsg "no more contents to be read" + (x : xs) -> do modify (\ s -> s {contents = xs}) + return x + +getAtt :: QName -> Unpickler XmlTree +getAtt qn = do as <- gets attributes + case findAtt as of + Nothing -> throwMsg $ "no attribute value found for " ++ show qn + Just (a, as') -> do modify (\ s -> s {attributes = as'}) + return a + where + findAtt = findElem (maybe False (== qn) . XN.getAttrName) + +getNSAtt :: String -> Unpickler () +getNSAtt ns = do as <- gets attributes + case findNS as of + Nothing -> throwMsg $ + "no namespace declaration found for namespace " ++ show ns + Just (_a, as') -> do modify (\ s -> s {attributes = as'}) + return () + where + isNS t = (fromMaybe False . fmap isNameSpaceName . XN.getAttrName $ t) + && + XN.xshow (XN.getChildren t) == ns + findNS = findElem isNS + +-- -------------------- + +emptySt :: St +emptySt = St { attributes = [] + , contents = [] + , nesting = 0 + , pname = mkName "/" + , pelem = True + } + +putAtt :: QName -> [XmlTree] -> St -> St +putAtt qn v s = s {attributes = x : attributes s} + where + x = XN.mkAttr qn v +{-# INLINE putAtt #-} + +putCont :: XmlTree -> St -> St +putCont x s = s {contents = x : contents s} +{-# INLINE putCont #-} + +-- -------------------- +-- +-- generally useful function for splitting a value from a list + +findElem :: (a -> Bool) -> [a] -> Maybe (a, [a]) +findElem p = find' id + where + find' _ [] = Nothing + find' prefix (x : xs) + | p x = Just (x, prefix xs) + | otherwise = find' (prefix . (x:)) xs + +-- ------------------------------------------------------------ +-- +-- | Format the context of an error message. + +formatSt :: St -> String +formatSt st = fcx ++ + fa (attributes st) ++ + fc (contents st) + where + fcx = "\n" ++ "context: " ++ + ( if pelem st + then "element" + else "attribute" + ) ++ + " " ++ show (pname st) + fc [] = "" + fc cs = "\n" ++ "contents: " ++ formatXML cs + fa [] = "" + fa as = "\n" ++ "attributes: " ++ formatXML as + formatXML = format 80 . showXML + showXML = concat . runLA ( xshowEscapeXml unlistA ) + format n s = let s' = take (n + 1) s in + if length s' <= n then s' else take n s ++ "..." + +-- ------------------------------------------------------------ + +-- | conversion of an arbitrary value into an XML document tree. +-- +-- The pickler, first parameter, controls the conversion process. +-- Result is a complete document tree including a root node + +pickleDoc :: PU a -> a -> XmlTree +pickleDoc p v = XN.mkRoot (attributes st) (contents st) + where + st = appPickle p v emptySt + +-- | Conversion of an XML document tree into an arbitrary data type +-- +-- The inverse of 'pickleDoc'. +-- This law should hold for all picklers: @ unpickle px . pickle px $ v == Just v @. +-- Not every possible combination of picklers does make sense. +-- For reconverting a value from an XML tree, is becomes neccessary, +-- to introduce \"enough\" markup for unpickling the value + +unpickleDoc :: PU a -> XmlTree -> Maybe a +unpickleDoc p = either (const Nothing) Just + . unpickleDoc' p + +-- | Like unpickleDoc but with a (sometimes) useful error message, when unpickling failed. + +unpickleDoc' :: PU a -> XmlTree -> Either String a +unpickleDoc' p t + | XN.isRoot t = mapErr $ + unpickleElem' p 0 t + | otherwise = unpickleDoc' p (XN.mkRoot [] [t]) + where + mapErr = either ( Left . + \ (msg, st) -> msg ++ formatSt st + ) Right + +-- | The main entry for unpickling, called by unpickleDoc + +unpickleElem' :: PU a -> Int -> XmlTree -> UnpickleVal a +unpickleElem' p l t + = fst + . runUP (appUnPickle p) + $ St { attributes = fromMaybe [] . + XN.getAttrl $ t + , contents = XN.getChildren t + , nesting = l + , pname = fromJust . + XN.getName $ t + , pelem = XN.isElem t + } + +-- ------------------------------------------------------------ + +-- | Pickles a value, then writes the document to a string. + +showPickled :: (XmlPickler a) => SysConfigList -> a -> String +showPickled a = concat . (pickleDoc xpickle >>> runLA (writeDocumentToString a)) + +-- ------------------------------------------------------------ + +-- | The zero pickler +-- +-- Encodes nothing, fails always during unpickling + +xpZero :: String -> PU a +xpZero err = PU { appPickle = const id + , appUnPickle = throwMsg err + , theSchema = scNull + } + +-- | unit pickler + +xpUnit :: PU () +xpUnit = xpLift () + +-- | Check EOF pickler. +-- +-- When pickling, this behaves like the unit pickler. +-- The unpickler fails, when there is some unprocessed XML contents left. + +xpCheckEmptyContents :: PU a -> PU a +xpCheckEmptyContents pa = PU { appPickle = appPickle pa + , appUnPickle = do res <- appUnPickle pa + cs <- gets contents + if null cs + then return res + else contentsLeft + , theSchema = scNull + } + where + contentsLeft = throwMsg + "xpCheckEmptyContents: unprocessed XML content detected" + +-- | Like xpCheckEmptyContents, but checks the attribute list + +xpCheckEmptyAttributes :: PU a -> PU a +xpCheckEmptyAttributes pa + = PU { appPickle = appPickle pa + , appUnPickle = do res <- appUnPickle pa + as <- gets attributes + if null as + then return res + else attributesLeft + , theSchema = scNull + } + where + attributesLeft = throwMsg + "xpCheckEmptyAttributes: unprocessed XML attribute(s) detected" + +-- | Composition of xpCheckEmptyContents and xpCheckAttributes + +xpCheckEmpty :: PU a -> PU a +xpCheckEmpty = xpCheckEmptyAttributes . xpCheckEmptyContents + +xpLift :: a -> PU a +xpLift x = PU { appPickle = const id + , appUnPickle = return x + , theSchema = scEmpty + } + +-- | Lift a Maybe value to a pickler. +-- +-- @Nothing@ is mapped to the zero pickler, @Just x@ is pickled with @xpLift x@. + +xpLiftMaybe :: Maybe a -> PU a +xpLiftMaybe v = (xpLiftMaybe'' v) { theSchema = scOption scEmpty } + where + xpLiftMaybe'' Nothing = xpZero "xpLiftMaybe: got Nothing" + xpLiftMaybe'' (Just x) = xpLift x + +xpLiftEither :: Either String a -> PU a +xpLiftEither v = (xpLiftEither'' v) { theSchema = scOption scEmpty } + where + xpLiftEither'' (Left err) = xpZero err + xpLiftEither'' (Right x) = xpLift x + +-- | Combine two picklers sequentially. +-- +-- If the first fails during +-- unpickling, the whole unpickler fails + +xpSeq :: (b -> a) -> PU a -> (a -> PU b) -> PU b +xpSeq f pa k + = PU { appPickle = ( \ b -> + let a = f b in + appPickle pa a . appPickle (k a) b + ) + , appUnPickle = appUnPickle pa >>= (appUnPickle . k) + , theSchema = undefined + } + +-- | First apply a fixed pickler/unpickler, then a 2. one +-- +-- If the first fails during unpickling, the whole pickler fails. +-- This can be used to check some properties of the input, e.g. whether +-- a given fixed attribute or a namespace declaration exists ('xpAddFixedAttr', 'xpAddNSDecl') +-- or to filter the input, e.g. to ignore some elements or attributes ('xpFilterCont', 'xpFilterAttr'). +-- +-- When pickling, this can be used to insert some fixed XML pieces, e.g. namespace declarations, +-- class attributes or other stuff. + +xpSeq' :: PU () -> PU a -> PU a +xpSeq' pa = xpWrap ( snd + , \ y -> ((), y) + ) . + xpPair pa + +-- | combine tow picklers with a choice +-- +-- Run two picklers in sequence like with xpSeq. +-- When during unpickling the first one fails, +-- an alternative pickler (first argument) is applied. +-- This pickler is only used as combinator for unpickling. + +xpChoice :: PU b -> PU a -> (a -> PU b) -> Unpickler b +xpChoice pb pa k = mchoice (appUnPickle pa) (appUnPickle . k) (appUnPickle pb) + + +-- | map value into another domain and apply pickler there +-- +-- One of the most often used picklers. + +xpWrap :: (a -> b, b -> a) -> PU a -> PU b +xpWrap (i, j) pa = (xpSeq j pa (xpLift . i)) { theSchema = theSchema pa } + +-- | like 'xpWrap', but if the inverse mapping is undefined, the unpickler fails +-- +-- Map a value into another domain. If the inverse mapping is +-- undefined (Nothing), the unpickler fails +-- +-- Deprecated: Use xpWrapEither, this gives better error messages + +xpWrapMaybe :: (a -> Maybe b, b -> a) -> PU a -> PU b +xpWrapMaybe (i, j) pa = (xpSeq j pa (xpLiftMaybe . i)) { theSchema = theSchema pa } + +-- | like 'xpWrap', but if the inverse mapping is undefined, the unpickler fails +-- +-- Map a value into another domain. If the inverse mapping is +-- undefined, the unpickler fails with an error message in the Left component + +xpWrapEither :: (a -> Either String b, b -> a) -> PU a -> PU b +xpWrapEither (i, j) pa = (xpSeq j pa (xpLiftEither . i)) { theSchema = theSchema pa } + +-- ------------------------------------------------------------ + +-- | pickle a pair of values sequentially +-- +-- Used for pairs or together with wrap for pickling +-- algebraic data types with two components + +xpPair :: PU a -> PU b -> PU (a, b) +xpPair pa pb + = ( xpSeq fst pa (\ a -> + xpSeq snd pb (\ b -> + xpLift (a,b))) + ) { theSchema = scSeq (theSchema pa) (theSchema pb) } + +-- | Like 'xpPair' but for triples + +xpTriple :: PU a -> PU b -> PU c -> PU (a, b, c) +xpTriple pa pb pc + = xpWrap (toTriple, fromTriple) (xpPair pa (xpPair pb pc)) + where + toTriple ~(a, ~(b, c)) = (a, b, c ) + fromTriple ~(a, b, c ) = (a, (b, c)) + +-- | Like 'xpPair' and 'xpTriple' but for 4-tuples + +xp4Tuple :: PU a -> PU b -> PU c -> PU d -> PU (a, b, c, d) +xp4Tuple pa pb pc pd + = xpWrap (toQuad, fromQuad) (xpPair pa (xpPair pb (xpPair pc pd))) + where + toQuad ~(a, ~(b, ~(c, d))) = (a, b, c, d ) + fromQuad ~(a, b, c, d ) = (a, (b, (c, d))) + +-- | Like 'xpPair' and 'xpTriple' but for 5-tuples + +xp5Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU (a, b, c, d, e) +xp5Tuple pa pb pc pd pe + = xpWrap (toQuint, fromQuint) (xpPair pa (xpPair pb (xpPair pc (xpPair pd pe)))) + where + toQuint ~(a, ~(b, ~(c, ~(d, e)))) = (a, b, c, d, e ) + fromQuint ~(a, b, c, d, e ) = (a, (b, (c, (d, e)))) + +-- | Like 'xpPair' and 'xpTriple' but for 6-tuples + +xp6Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU f -> PU (a, b, c, d, e, f) +xp6Tuple pa pb pc pd pe pf + = xpWrap (toSix, fromSix) (xpPair pa (xpPair pb (xpPair pc (xpPair pd (xpPair pe pf))))) + where + toSix ~(a, ~(b, ~(c, ~(d, ~(e, f))))) = (a, b, c, d, e, f ) + fromSix ~(a, b, c, d, e, f) = (a, (b, (c, (d, (e, f))))) + +-- ------------------------------------------------------------ + +-- | Like 'xpPair' and 'xpTriple' but for 7-tuples +-- +-- Thanks to Tony Morris for doing xp7Tuple, ..., xp24Tuple. + +xp7Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU (a, b, c, d, e, f, g) +xp7Tuple a b c d e f g + = xpWrap ( \ (a, (b, c, d, e, f, g)) -> (a, b, c, d, e, f, g) + , \ (a, b, c, d, e, f, g) -> (a, (b, c, d, e, f, g)) + ) + (xpPair a (xp6Tuple b c d e f g)) + +xp8Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU (a, b, c, d, e, f, g, h) +xp8Tuple a b c d e f g h + = xpWrap ( \ ((a, b), (c, d, e, f, g, h)) -> (a, b, c, d, e, f, g, h) + , \ (a, b, c, d, e, f, g, h) -> ((a, b), (c, d, e, f, g, h)) + ) + (xpPair (xpPair a b) (xp6Tuple c d e f g h)) + +xp9Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU (a, b, c, d, e, f, g, h, i) +xp9Tuple a b c d e f g h i + = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i)) -> (a, b, c, d, e, f, g, h, i) + , \ (a, b, c, d, e, f, g, h, i) -> ((a, b, c), (d, e, f, g, h, i)) + ) + (xpPair (xpTriple a b c) (xp6Tuple d e f g h i)) + +xp10Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU (a, b, c, d, e, f, g, h, i, j) +xp10Tuple a b c d e f g h i j + = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j)) -> (a, b, c, d, e, f, g, h, i, j) + , \ (a, b, c, d, e, f, g, h, i, j) -> ((a, b, c, d), (e, f, g, h, i, j)) + ) + (xpPair (xp4Tuple a b c d) (xp6Tuple e f g h i j)) + +xp11Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU (a, b, c, d, e, f, g, h, i, j, k) +xp11Tuple a b c d e f g h i j k + = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k)) -> (a, b, c, d, e, f, g, h, i, j, k) + , \ (a, b, c, d, e, f, g, h, i, j, k) -> ((a, b, c, d, e), (f, g, h, i, j, k)) + ) + (xpPair (xp5Tuple a b c d e) (xp6Tuple f g h i j k)) + +xp12Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU (a, b, c, d, e, f, g, h, i, j, k, l) +xp12Tuple a b c d e f g h i j k l + = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l)) -> (a, b, c, d, e, f, g, h, i, j, k, l) + , \ (a, b, c, d, e, f, g, h, i, j, k, l) -> ((a, b, c, d, e, f), (g, h, i, j, k, l)) + ) + (xpPair (xp6Tuple a b c d e f) (xp6Tuple g h i j k l)) + +xp13Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m) +xp13Tuple a b c d e f g h i j k l m + = xpWrap ( \ (a, (b, c, d, e, f, g), (h, i, j, k, l, m)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m) -> (a, (b, c, d, e, f, g), (h, i, j, k, l, m)) + ) + (xpTriple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m)) + +xp14Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n) +xp14Tuple a b c d e f g h i j k l m n + = xpWrap ( \ ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n)) + ) + (xpTriple (xpPair a b) (xp6Tuple c d e f g h) (xp6Tuple i j k l m n)) + +xp15Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) +xp15Tuple a b c d e f g h i j k l m n o + = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o)) + ) + (xpTriple (xpTriple a b c) (xp6Tuple d e f g h i) (xp6Tuple j k l m n o)) + +xp16Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) +xp16Tuple a b c d e f g h i j k l m n o p + = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) -> ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p)) + ) + (xpTriple (xp4Tuple a b c d) (xp6Tuple e f g h i j) (xp6Tuple k l m n o p)) + +xp17Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) +xp17Tuple a b c d e f g h i j k l m n o p q + = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) -> ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q)) + ) + (xpTriple (xp5Tuple a b c d e) (xp6Tuple f g h i j k) (xp6Tuple l m n o p q)) + +xp18Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU r -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) +xp18Tuple a b c d e f g h i j k l m n o p q r + = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) -> ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r)) + ) + (xpTriple (xp6Tuple a b c d e f) (xp6Tuple g h i j k l) (xp6Tuple m n o p q r)) + +xp19Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU r -> PU s -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) +xp19Tuple a b c d e f g h i j k l m n o p q r s + = xpWrap ( \ (a, (b, c, d, e, f, g), (h, i, j, k, l, m), (n, o, p, q, r, s)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) -> (a, (b, c, d, e, f, g), (h, i, j, k, l, m), (n, o, p, q, r, s)) + ) + (xp4Tuple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m) (xp6Tuple n o p q r s)) + +xp20Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU r -> PU s -> PU t -> + PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) +xp20Tuple a b c d e f g h i j k l m n o p q r s t + = xpWrap ( \ ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n), (o, p, q, r, s, t)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) -> ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n), (o, p, q, r, s, t)) + ) + (xp4Tuple (xpPair a b) (xp6Tuple c d e f g h) (xp6Tuple i j k l m n) (xp6Tuple o p q r s t)) + +xp21Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU r -> PU s -> PU t -> + PU u -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) +xp21Tuple a b c d e f g h i j k l m n o p q r s t u + = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o), (p, q, r, s, t, u)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) -> ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o), (p, q, r, s, t, u)) + ) + (xp4Tuple (xpTriple a b c) (xp6Tuple d e f g h i) (xp6Tuple j k l m n o) (xp6Tuple p q r s t u)) + +xp22Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU r -> PU s -> PU t -> + PU u -> PU v -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) +xp22Tuple a b c d e f g h i j k l m n o p q r s t u v + = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p), (q, r, s, t, u, v)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) -> ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p), (q, r, s, t, u, v)) + ) + (xp4Tuple (xp4Tuple a b c d) (xp6Tuple e f g h i j) (xp6Tuple k l m n o p) (xp6Tuple q r s t u v)) + +xp23Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU r -> PU s -> PU t -> + PU u -> PU v -> PU w -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) +xp23Tuple a b c d e f g h i j k l m n o p q r s t u v w + = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q), (r, s, t, u, v, w)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) -> ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q), (r, s, t, u, v, w)) + ) + (xp4Tuple (xp5Tuple a b c d e) (xp6Tuple f g h i j k) (xp6Tuple l m n o p q) (xp6Tuple r s t u v w)) + +-- | Hopefully no one needs a xp25Tuple + +xp24Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> + PU f -> PU g -> PU h -> PU i -> PU j -> + PU k -> PU l -> PU m -> PU n -> PU o -> + PU p -> PU q -> PU r -> PU s -> PU t -> + PU u -> PU v -> PU w -> PU x -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) +xp24Tuple a b c d e f g h i j k l m n o p q r s t u v w x + = xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r), (s, t, u, v, w, x)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) + , \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) -> ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r), (s, t, u, v, w, x)) + ) + (xp4Tuple (xp6Tuple a b c d e f) (xp6Tuple g h i j k l) (xp6Tuple m n o p q r) (xp6Tuple s t u v w x)) + +-- ------------------------------------------------------------ + + +-- | Pickle a string into an XML text node +-- +-- One of the most often used primitive picklers. Attention: +-- For pickling empty strings use 'xpText0'. If the text has a more +-- specific datatype than xsd:string, use 'xpTextDT' + +xpText :: PU String +xpText = xpTextDT scString1 +{-# INLINE xpText #-} + +-- | Pickle a string into an XML text node +-- +-- Text pickler with a description of the structure of the text +-- by a schema. A schema for a data type can be defined by 'Text.XML.HXT.Arrow.Pickle.Schema.scDT'. +-- In 'Text.XML.HXT.Arrow.Pickle.Schema' there are some more functions for creating +-- simple datatype descriptions. + +xpTextDT :: Schema -> PU String +xpTextDT sc = PU { appPickle = putCont . XN.mkText + , appUnPickle = do t <- getCont + liftMaybe "xpText: XML text expected" $ XN.getText t + , theSchema = sc + } + +-- | Pickle a possibly empty string into an XML node. +-- +-- Must be used in all places, where empty strings are legal values. +-- If the content of an element can be an empty string, this string disapears +-- during storing the DOM into a document and reparse the document. +-- So the empty text node becomes nothing, and the pickler must deliver an empty string, +-- if there is no text node in the document. + +xpText0 :: PU String +xpText0 = xpText0DT scString1 +{-# INLINE xpText0 #-} + +-- | Pickle a possibly empty string with a datatype description into an XML node. +-- +-- Like 'xpText0' but with extra Parameter for datatype description as in 'xpTextDT'. + +xpText0DT :: Schema -> PU String +xpText0DT sc = xpWrap (fromMaybe "", emptyToNothing) $ + xpOption $ + xpTextDT sc + where + emptyToNothing "" = Nothing + emptyToNothing x = Just x + +-- | Pickle an arbitrary value by applyling show during pickling +-- and read during unpickling. +-- +-- Real pickling is then done with 'xpText'. +-- One of the most often used pimitive picklers. Applicable for all +-- types which are instances of @Read@ and @Show@ + +xpPrim :: (Read a, Show a) => PU a +xpPrim = xpWrapEither (readMaybe, show) xpText + where + readMaybe :: Read a => String -> Either String a + readMaybe str = val (reads str) + where + val [(x,"")] = Right x + val _ = Left $ "xpPrim: reading string " ++ show str ++ " failed" + +-- | Pickle an Int +xpInt :: PU Int +xpInt = xpWrapEither (readMaybe, show) xpText + where + readMaybe xs + | all isDigit xs = Right . foldl' (\ r c -> 10 * r + (fromEnum c - fromEnum '0')) 0 $ xs + readMaybe ('-' : xs) = fmap (0 -) . readMaybe $ xs + readMaybe ('+' : xs) = readMaybe $ xs + readMaybe xs = Left $ "xpInt: reading an Int from string " ++ show xs ++ " failed" + +-- ------------------------------------------------------------ + +-- | Pickle an XmlTree by just adding it +-- +-- Usefull for components of type XmlTree in other data structures + +xpTree :: PU XmlTree +xpTree = PU { appPickle = putCont + , appUnPickle = getCont + , theSchema = Any + } + +-- | Pickle a whole list of XmlTrees by just adding the list, unpickle is done by taking all element contents. +-- +-- This pickler should always be combined with 'xpElem' for taking the whole contents of an element. + +xpTrees :: PU [XmlTree] +xpTrees = (xpList xpTree) { theSchema = Any } + +-- | Pickle a string representing XML contents by inserting the tree representation into the XML document. +-- +-- Unpickling is done by converting the contents with +-- 'Text.XML.HXT.Arrow.Edit.xshowEscapeXml' into a string, +-- this function will escape all XML special chars, such that pickling the value back becomes save. +-- Pickling is done with 'Text.XML.HXT.Arrow.ReadDocument.xread' + +xpXmlText :: PU String +xpXmlText = xpWrap ( showXML, readXML ) $ xpTrees + where + showXML = concat . runLA ( xshowEscapeXml unlistA ) + readXML = runLA xread + +-- ------------------------------------------------------------ + +-- | Encoding of optional data by ignoring the Nothing case during pickling +-- and relying on failure during unpickling to recompute the Nothing case +-- +-- The default pickler for Maybe types + +xpOption :: PU a -> PU (Maybe a) +xpOption pa = PU { appPickle = ( \ a -> + case a of + Nothing -> id + Just x -> appPickle pa x + ) + + , appUnPickle = xpChoice (xpLift Nothing) pa (xpLift . Just) + + , theSchema = scOption (theSchema pa) + } + +-- | Optional conversion with default value +-- +-- The default value is not encoded in the XML document, +-- during unpickling the default value is inserted if the pickler fails + +xpDefault :: (Eq a) => a -> PU a -> PU a +xpDefault df = xpWrap ( fromMaybe df + , \ x -> if x == df then Nothing else Just x + ) . + xpOption + +-- ------------------------------------------------------------ + +-- | Encoding of list values by pickling all list elements sequentially. +-- +-- Unpickler relies on failure for detecting the end of the list. +-- The standard pickler for lists. Can also be used in combination with 'xpWrap' +-- for constructing set and map picklers + +xpList :: PU a -> PU [a] +xpList pa = PU { appPickle = ( \ a -> + case a of + [] -> id + _:_ -> appPickle pc a + ) + , appUnPickle = xpChoice + (xpLift []) + pa + (\ x -> xpSeq id (xpList pa) (\xs -> xpLift (x:xs))) + + , theSchema = scList (theSchema pa) + } + where + pc = xpSeq head pa (\ x -> + xpSeq tail (xpList pa) (\ xs -> + xpLift (x:xs) )) + +-- | Encoding of a none empty list of values +-- +-- Attention: when calling this pickler with an empty list, +-- an internal error \"head of empty list is raised\". + +xpList1 :: PU a -> PU [a] +xpList1 pa = ( xpWrap (\ (x, xs) -> x : xs + ,\ x -> (head x, tail x) + ) $ + xpPair pa (xpList pa) + ) { theSchema = scList1 (theSchema pa) } + +-- ------------------------------------------------------------ + +-- | Standard pickler for maps +-- +-- This pickler converts a map into a list of pairs. +-- All key value pairs are mapped to an element with name (1.arg), +-- the key is encoded as an attribute named by the 2. argument, +-- the 3. arg is the pickler for the keys, the last one for the values + +xpMap :: Ord k => String -> String -> PU k -> PU v -> PU (Map k v) +xpMap en an xpk xpv + = xpWrap ( M.fromList + , M.toList + ) $ + xpList $ + xpElem en $ + xpPair ( xpAttr an $ xpk ) xpv + +-- ------------------------------------------------------------ + +-- | Pickler for sum data types. +-- +-- Every constructor is mapped to an index into the list of picklers. +-- The index is used only during pickling, not during unpickling, there the 1. match is taken + +xpAlt :: (a -> Int) -> [PU a] -> PU a +xpAlt tag ps = PU { appPickle = \ a -> + appPickle (ps !! tag a) a + + , appUnPickle = case ps of + [] -> throwMsg "xpAlt: no matching unpickler found for a sum datatype" + pa:ps1 -> xpChoice (xpAlt tag ps1) pa xpLift + + , theSchema = scAlts (map theSchema ps) + } + +-- ------------------------------------------------------------ + +-- | Pickler for wrapping\/unwrapping data into an XML element +-- +-- Extra parameter is the element name given as a QName. THE pickler for constructing +-- nested structures +-- +-- Example: +-- +-- > xpElemQN (mkName "number") $ xpickle +-- +-- will map an (42::Int) onto +-- +-- > 42 + +xpElemQN :: QName -> PU a -> PU a +xpElemQN qn pa = PU { appPickle = ( \ a -> + let st' = appPickle pa a emptySt in + putCont (XN.mkElement qn (attributes st') (contents st')) + ) + , appUnPickle = upElem + , theSchema = scElem (qualifiedName qn) (theSchema pa) + } + where + upElem = do t <- getCont + n <- liftMaybe "xpElem: XML element expected" $ XN.getElemName t + if n /= qn + then throwMsg ("xpElem: got element name " ++ show n ++ ", but expected " ++ show qn) + else do l <- gets nesting + liftUnpickleVal $ unpickleElem' (xpCheckEmpty pa) (l + 1) t + +-- | convenient Pickler for xpElemQN +-- +-- > xpElem n = xpElemQN (mkName n) + +xpElem :: String -> PU a -> PU a +xpElem = xpElemQN . mkName + +-- | convenient Pickler for xpElemQN +-- for pickling elements with respect to namespaces +-- +-- > xpElemNS ns px lp = xpElemQN (mkQName px lp ns) + +xpElemNS :: String -> String -> String -> PU a -> PU a +xpElemNS ns px lp + = xpElemQN $ mkQName px lp ns + +-- ------------------------------------------------------------ + +-- | Pickler for wrapping\/unwrapping data into an XML element with an attribute with given value +-- +-- To make XML structures flexible but limit the number of different elements, it's sometimes +-- useful to use a kind of generic element with a key value structure +-- +-- Example: +-- +-- > value1 +-- > value2 +-- > value3 +-- +-- the Haskell datatype may look like this +-- +-- > type T = T { key1 :: Int ; key2 :: String ; key3 :: Double } +-- +-- Then the picker for that type looks like this +-- +-- > xpT :: PU T +-- > xpT = xpWrap ( uncurry3 T, \ t -> (key1 t, key2 t, key3 t) ) $ +-- > xpTriple (xpElemWithAttrValue "attr" "name" "key1" $ xpickle) +-- > (xpElemWithAttrValue "attr" "name" "key2" $ xpText0) +-- > (xpElemWithAttrValue "attr" "name" "key3" $ xpickle) + +xpElemWithAttrValue :: String -> String -> String -> PU a -> PU a +xpElemWithAttrValue name an av pa + = xpElem name $ + xpAddFixedAttr an av $ + pa + +-- ------------------------------------------------------------ + +-- | Pickler for storing\/retreiving data into\/from an attribute value +-- +-- The attribute is inserted in the surrounding element constructed by the 'xpElem' pickler + +xpAttrQN :: QName -> PU a -> PU a +xpAttrQN qn pa = PU { appPickle = ( \ a -> + let st' = appPickle pa a emptySt in + putAtt qn (contents st') + ) + , appUnPickle = upAttr + , theSchema = scAttr (qualifiedName qn) (theSchema pa) + } + where + upAttr = do a <- getAtt qn + l <- gets nesting + liftUnpickleVal $ unpickleElem' (xpCheckEmptyContents pa) l a + +-- | convenient Pickler for xpAttrQN +-- +-- > xpAttr n = xpAttrQN (mkName n) + +xpAttr :: String -> PU a -> PU a +xpAttr = xpAttrQN . mkName + +-- | convenient Pickler for xpAttrQN +-- +-- > xpAttr ns px lp = xpAttrQN (mkQName px lp ns) + +xpAttrNS :: String -> String -> String -> PU a -> PU a +xpAttrNS ns px lp + = xpAttrQN (mkQName px lp ns) + +-- | A text attribute. +xpTextAttr :: String -> PU String +xpTextAttr = flip xpAttr xpText + +-- | Add an optional attribute for an optional value (Maybe a). + +xpAttrImplied :: String -> PU a -> PU (Maybe a) +xpAttrImplied name pa + = xpOption $ xpAttr name pa + +xpAttrFixed :: String -> String -> PU () +xpAttrFixed name val + = ( xpWrapEither ( \ v -> + if v == val + then Right () + else Left ( "xpAttrFixed: value " + ++ show val + ++ " expected, but got " + ++ show v + ) + , const val + ) $ + xpAttr name xpText + ) { theSchema = scAttr name (scFixed val) } + +-- | Add/Check an attribute with a fixed value. +-- + +xpAddFixedAttr :: String -> String -> PU a -> PU a +xpAddFixedAttr name val + = xpSeq' $ xpAttrFixed name val + +-- | Add a namespace declaration. +-- +-- When generating XML the namespace decl is added, +-- when reading a document, the unpickler checks +-- whether there is a namespace declaration for the given +-- namespace URI (2. arg) + +xpAddNSDecl :: String -> String -> PU a -> PU a +xpAddNSDecl name val + = xpSeq' $ xpAttrNSDecl name' val + where + name' + | null name = "xmlns" + | otherwise = "xmlns:" ++ name + +xpAttrNSDecl :: String -> String -> PU () +xpAttrNSDecl name ns + = PU { appPickle = const $ putAtt (mkName name) [XN.mkText ns] + , appUnPickle = getNSAtt ns + , theSchema = scAttr name (scFixed ns) + } + +-- ------------------------------------------------------------ + +xpIgnoreCont :: LA XmlTree XmlTree -> PU () +xpIgnoreCont = xpIgnoreInput $ \ mf s -> s {contents = mf $ contents s} + +xpIgnoreAttr :: LA XmlTree XmlTree -> PU () +xpIgnoreAttr = xpIgnoreInput $ \ mf s -> s {attributes = mf $ attributes s} + +-- | When unpickling, filter the contents of the element currently processed, +-- before applying the pickler argument +-- +-- Maybe useful to ignore some stuff in the input, or to do some cleanup before unpickling. + +xpFilterCont :: LA XmlTree XmlTree -> PU a -> PU a +xpFilterCont f = xpSeq' $ xpIgnoreCont f + +-- | Same as 'xpFilterCont' but for the attribute list of the element currently processed. +-- +-- Maybe useful to ignore some stuff in the input, e.g. class attributes, or to do some cleanup before unpickling. + +xpFilterAttr :: LA XmlTree XmlTree -> PU a -> PU a +xpFilterAttr f = xpSeq' $ xpIgnoreAttr f + +xpIgnoreInput :: (([XmlTree] -> [XmlTree]) -> St -> St) -> LA XmlTree XmlTree -> PU () +xpIgnoreInput m f + = PU { appPickle = const id + , appUnPickle = do modify (m filterCont) + return () + , theSchema = scNull + } + where + filterCont = runLA (unlistA >>> f) + +-- ------------------------------------------------------------ + +-- | The class for overloading 'xpickle', the default pickler + +class XmlPickler a where + xpickle :: PU a + +instance XmlPickler Int where + xpickle = xpPrim + +instance XmlPickler Integer where + xpickle = xpPrim + +{- + no instance of XmlPickler Char + because then every text would be encoded + char by char, because of the instance for lists + +instance XmlPickler Char where + xpickle = xpPrim +-} + +instance XmlPickler () where + xpickle = xpUnit + +instance (XmlPickler a, XmlPickler b) => XmlPickler (a,b) where + xpickle = xpPair xpickle xpickle + +instance (XmlPickler a, XmlPickler b, XmlPickler c) => XmlPickler (a,b,c) where + xpickle = xpTriple xpickle xpickle xpickle + +instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d) => XmlPickler (a,b,c,d) where + xpickle = xp4Tuple xpickle xpickle xpickle xpickle + +instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e) => XmlPickler (a,b,c,d,e) where + xpickle = xp5Tuple xpickle xpickle xpickle xpickle xpickle + +instance XmlPickler a => XmlPickler [a] where + xpickle = xpList xpickle + +instance XmlPickler a => XmlPickler (Maybe a) where + xpickle = xpOption xpickle + +-- ------------------------------------------------------------ + +{- begin embeded test cases + +-- ------------------------------------------------------------ +-- +-- a somewhat complex data structure +-- for representing programs of a simple +-- imperative language + +type Program = Stmt + +type StmtList = [Stmt] + +data Stmt + = Assign Ident Expr + | Stmts StmtList + | If Expr Stmt (Maybe Stmt) + | While Expr Stmt + deriving (Eq, Show) + +type Ident = String + +data Expr + = IntConst Int + | BoolConst Bool + | Var Ident + | UnExpr UnOp Expr + | BinExpr Op Expr Expr + deriving (Eq, Show) + +data Op + = Add | Sub | Mul | Div | Mod | Eq | Neq + deriving (Eq, Ord, Enum, Show) + +data UnOp + = UPlus | UMinus | Neg + deriving (Eq, Ord, Read, Show) + +-- ------------------------------------------------------------ +-- +-- the pickler definition for the data types + +-- the main pickler + +xpProgram :: PU Program +xpProgram = xpElem "program" $ + xpAddNSDecl "" "program42" $ + xpickle + +xpMissingRootElement :: PU Program +xpMissingRootElement = xpickle + +instance XmlPickler UnOp where + xpickle = xpPrim + +instance XmlPickler Op where + xpickle = xpWrap (toEnum, fromEnum) xpPrim + +instance XmlPickler Expr where + xpickle = xpAlt tag ps + where + tag (IntConst _ ) = 0 + tag (BoolConst _ ) = 1 + tag (Var _ ) = 2 + tag (UnExpr _ _ ) = 3 + tag (BinExpr _ _ _ ) = 4 + ps = [ xpWrap ( IntConst + , \ (IntConst i ) -> i + ) $ + ( xpElem "int" $ + xpAttr "value" $ + xpickle + ) + + , xpWrap ( BoolConst + , \ (BoolConst b) -> b + ) $ + ( xpElem "bool" $ + xpAttr "value" $ + xpWrap (toEnum, fromEnum) xpickle + ) + + , xpWrap ( Var + , \ (Var n) -> n + ) $ + ( xpElem "var" $ + xpAttr "name" $ + xpText + ) + + , xpWrap ( uncurry UnExpr + , \ (UnExpr op e) -> (op, e) + ) $ + ( xpElem "unex" $ + xpPair (xpAttr "op" xpickle) + xpickle + ) + + , xpWrap ( uncurry3 $ BinExpr + , \ (BinExpr op e1 e2) -> (op, e1, e2) + ) $ + ( xpElem "binex" $ + xpTriple (xpAttr "op" xpickle) + xpickle + xpickle + ) + ] + +instance XmlPickler Stmt where + xpickle = xpAlt tag ps + where + tag ( Assign _ _ ) = 0 + tag ( Stmts _ ) = 1 + tag ( If _ _ _ ) = 2 + tag ( While _ _ ) = 3 + ps = [ xpWrap ( uncurry Assign + , \ (Assign n v) -> (n, v) + ) $ + ( xpElem "assign" $ + xpPair (xpAttr "name" xpText) + xpickle + ) + , xpWrap ( Stmts + , \ (Stmts sl) -> sl + ) $ + ( xpElem "block" $ + xpList xpickle + ) + , xpWrap ( uncurry3 If + , \ (If c t e) -> (c, t, e) + ) $ + ( xpElem "if" $ + xpTriple xpickle + xpickle + xpickle + ) + , xpWrap ( uncurry While + , \ (While c b) -> (c, b) + ) $ + ( xpElem "while" $ + xpPair xpickle + xpickle + ) + ] + +-- ------------------------------------------------------------ +-- +-- example programs + +progs :: [Program] +progs = [p0, p1, p2] + +p0, p1, p2 :: Program + +p0 = Stmts [] -- the empty program + +p1 = Stmts + [ Assign i ( UnExpr UMinus ( IntConst (-22) ) ) + , Assign j ( IntConst 20 ) + , While + ( BinExpr Neq ( Var i ) ( IntConst 0 ) ) + ( Stmts + [ Assign i ( BinExpr Sub ( Var i ) ( IntConst 1 ) ) + , Assign j ( BinExpr Add ( Var j ) ( IntConst 1 ) ) + , If ( IntConst 0 ) (Stmts []) Nothing + ] + ) + ] + where + i = "i" + j = "j" + +p2 = Stmts + [ Assign x (IntConst 6) + , Assign y (IntConst 7) + , Assign p (IntConst 0) + , While + ( BinExpr Neq (Var x) (IntConst 0) ) + ( If ( BinExpr Neq ( BinExpr Mod (Var x) (IntConst 2) ) (IntConst 0) ) + ( Stmts + [ Assign x ( BinExpr Sub (Var x) (IntConst 1) ) + , Assign p ( BinExpr Add (Var p) (Var y) ) + ] + ) + ( Just ( Stmts + [ Assign x ( BinExpr Div (Var x) (IntConst 2) ) + , Assign y ( BinExpr Mul (Var y) (IntConst 2) ) + ] + ) + ) + ) + ] + where + x = "x" + y = "y" + p = "p" + +-- ------------------------------------------------------------ + +test0 = putStrLn . head . runLA + ( xshow (arr (pickleDoc xpProgram) + >>> getChildren + ) + ) + +test0' f = runLA + ( xshow (arr (pickleDoc xpProgram) + >>> getChildren + ) + >>> + root [] [xread] + >>> + f + ) + +test1' f = runLA + ( xshow (arr (pickleDoc xpProgram) + >>> getChildren + ) + >>> + root [] [xread] + >>> + f + >>> + arr (unpickleDoc' xpProgram) + ) + +test1 = test0' (processTopDown (setQName (mkName "real") `X.when` hasName "int")) +test2 = test1' this +test3 = test1' (processTopDown (setQName (mkName "real") `X.when` hasName "int")) +test4 = test1' (processTopDown (setQName (mkName "xxx") `X.when` hasName "program")) +test5 = test1' (processTopDown (setQName (mkName "xxx") `X.when` hasName "assign")) +test6 = test1' (processTopDownWithAttrl (txt "xxx" `X.when` hasText (== "UMinus"))) + +-- ------------------------------------------------------------ + +-- end embeded test cases -}