1{-# OPTIONS_GHC -fno-warn-name-shadowing #-} 2{-# LANGUAGE CPP #-} 3{-# LANGUAGE MultiParamTypeClasses #-} 4{-# LANGUAGE TypeSynonymInstances #-} 5 6-- ------------------------------------------------------------ 7 8{- | 9 Module : Text.XML.HXT.Arrow.Pickle.Xml 10 Copyright : Copyright (C) 2005-2012 Uwe Schmidt 11 License : MIT 12 13 Maintainer : Uwe Schmidt (uwe@fh-wedel.de) 14 Stability : stable 15 Portability: portable 16 17 Pickler functions for converting between user defined data types 18 and XmlTree data. Usefull for persistent storage and retreival 19 of arbitray data as XML documents. 20 21 This module is an adaptation of the pickler combinators 22 developed by Andrew Kennedy 23 ( https:\/\/www.microsoft.com\/en-us\/research\/wp-content\/uploads\/2004\/01\/picklercombinators.pdf ) 24 25 The difference to Kennedys approach is that the target is not 26 a list of Chars but a list of XmlTrees. The basic picklers will 27 convert data into XML text nodes. New are the picklers for 28 creating elements and attributes. 29 30 One extension was neccessary: The unpickling may fail. 31 32 Old: Therefore the unpickler has a Maybe result type. 33 Failure is used to unpickle optional elements 34 (Maybe data) and lists of arbitray length. 35 36 Since hxt-9.2.0: The unpicklers are implemented as 37 a parser monad with an Either err val result type. 38 This enables appropriate error messages , when unpickling 39 XML stuff, that is not generated with the picklers and which contains 40 some elements and/or attributes that are not handled when unpickling. 41 42 There is an example program demonstrating the use 43 of the picklers for a none trivial data structure. 44 (see \"examples\/arrows\/pickle\" directory in the hxt distribution) 45 46-} 47 48-- ------------------------------------------------------------ 49 50module Text.XML.HXT.Arrow.Pickle.Xml 51where 52 53#if MIN_VERSION_base(4,8,0) 54#else 55import Control.Applicative (Applicative (..)) 56#endif 57 58import Control.Arrow.ArrowList 59import Control.Arrow.ListArrows 60import Control.Monad () 61 62#if MIN_VERSION_mtl(2,2,0) 63import Control.Monad.Except (MonadError (..)) 64#else 65import Control.Monad.Error (MonadError (..)) 66#endif 67 68import Control.Monad.State (MonadState (..), gets, 69 modify) 70 71import Data.Char (isDigit) 72import Data.List (foldl') 73import Data.Map (Map) 74import qualified Data.Map as M 75import Data.Maybe (fromJust, fromMaybe) 76 77import Text.XML.HXT.Arrow.Edit (xshowEscapeXml) 78import Text.XML.HXT.Arrow.Pickle.Schema 79import Text.XML.HXT.Arrow.ReadDocument (xread) 80import Text.XML.HXT.Arrow.WriteDocument (writeDocumentToString) 81import Text.XML.HXT.Arrow.XmlState 82import Text.XML.HXT.DOM.Interface 83import qualified Text.XML.HXT.DOM.ShowXml as XN 84import qualified Text.XML.HXT.DOM.XmlNode as XN 85 86{- just for embedded test cases, prefix with -- to activate 87import Text.XML.HXT.Arrow.XmlArrow 88import qualified Control.Arrow.ListArrows as X 89-- -} 90 91{- debug code 92import qualified Debug.Trace as T 93-- -} 94 95-- ------------------------------------------------------------ 96 97data St = St { attributes :: [XmlTree] 98 , contents :: [XmlTree] 99 , nesting :: Int -- the remaining 3 fields are used only for unpickling 100 , pname :: QName -- to generate appropriate error messages 101 , pelem :: Bool 102 } deriving (Show) 103 104data PU a = PU { appPickle :: Pickler a -- (a, St) -> St 105 , appUnPickle :: Unpickler a 106 , theSchema :: Schema 107 } 108 109-- -------------------- 110-- 111-- The pickler 112 113type Pickler a = a -> St -> St 114 115-- -------------------- 116-- 117-- The unpickler monad, a combination of state and error monad 118 119newtype Unpickler a = UP { runUP :: St -> (UnpickleVal a, St) } 120 121type UnpickleVal a = Either UnpickleErr a 122 123type UnpickleErr = (String, St) 124 125instance Functor Unpickler where 126 fmap f u = UP $ \ st -> 127 let (r, st') = runUP u st in (fmap f r, st') 128 129instance Applicative Unpickler where 130 pure a = UP $ \ st -> (Right a, st) 131 uf <*> ua = UP $ \ st -> 132 let (f, st') = runUP uf st in 133 case f of 134 Left err -> (Left err, st') 135 Right f' -> runUP (fmap f' ua) st' 136 137instance Monad Unpickler where 138 return = pure 139 u >>= f = UP $ \ st -> 140 let (r, st') = runUP u st in 141 case r of 142 Left err -> (Left err, st') 143 Right v -> runUP (f v) st' 144 145instance MonadState St Unpickler where 146 get = UP $ \ st -> (Right st, st) 147 put st = UP $ \ _ -> (Right (), st) 148 149instance MonadError UnpickleErr Unpickler where 150 throwError err 151 = UP $ \ st -> (Left err, st) 152 153 -- redundant, not (yet) used 154 catchError u handler 155 = UP $ \ st -> 156 let (r, st') = runUP u st in 157 case r of 158 Left err -> runUP (handler err) st -- not st', state will be reset in error case 159 _ -> (r, st') 160 161throwMsg :: String -> Unpickler a 162throwMsg msg = UP $ \ st -> (Left (msg, st), st) 163 164-- | Choice combinator for unpickling 165-- 166-- first 2 arguments are applied sequentially, but if the 1. one fails the 167-- 3. arg is applied 168 169mchoice :: Unpickler a -> (a -> Unpickler b) -> Unpickler b -> Unpickler b 170mchoice u f v = UP $ \ st -> 171 let (r, st') = runUP u st in 172 case r of 173 Right x 174 -> runUP (f x) st' -- success 175 Left e@(_msg, st'') 176 -> if nesting st'' == nesting st -- true: failure in parsing curr contents 177 then runUP v st -- try the alternative unpickler 178 else (Left e, st') -- false: failure in unpickling a subtree of 179 -- the current contents, so the whole unpickler 180 -- must fail 181 182-- | Lift a Maybe value into the Unpickler monad. 183-- 184-- The 1. arg is the attached error message 185 186liftMaybe :: String -> Maybe a -> Unpickler a 187liftMaybe e v = case v of 188 Nothing -> throwMsg e 189 Just x -> return x 190 191-- | Lift an Either value into the Unpickler monad 192 193liftUnpickleVal :: UnpickleVal a -> Unpickler a 194liftUnpickleVal v = UP $ \ st -> (v, st) 195 196-- -------------------- 197 198getCont :: Unpickler XmlTree 199getCont = do cs <- gets contents 200 case cs of 201 [] -> throwMsg "no more contents to be read" 202 (x : xs) -> do modify (\ s -> s {contents = xs}) 203 return x 204 205getAtt :: QName -> Unpickler XmlTree 206getAtt qn = do as <- gets attributes 207 case findAtt as of 208 Nothing -> throwMsg $ "no attribute value found for " ++ show qn 209 Just (a, as') -> do modify (\ s -> s {attributes = as'}) 210 return $ nonEmptyVal a 211 where 212 findAtt = findElem (maybe False (== qn) . XN.getAttrName) 213 nonEmptyVal a' 214 | null (XN.getChildren a') = XN.setChildren [et] a' 215 | otherwise = a' 216 where 217 et = XN.mkText "" 218 219getNSAtt :: String -> Unpickler () 220getNSAtt ns = do as <- gets attributes 221 case findNS as of 222 Nothing -> throwMsg $ 223 "no namespace declaration found for namespace " ++ show ns 224 Just (_a, as') -> do modify (\ s -> s {attributes = as'}) 225 return () 226 where 227 isNS t = (fromMaybe False . fmap isNameSpaceName . XN.getAttrName $ t) 228 && 229 XN.xshow (XN.getChildren t) == ns 230 findNS = findElem isNS 231 232-- -------------------- 233 234emptySt :: St 235emptySt = St { attributes = [] 236 , contents = [] 237 , nesting = 0 238 , pname = mkName "/" 239 , pelem = True 240 } 241 242putAtt :: QName -> [XmlTree] -> St -> St 243putAtt qn v s = s {attributes = x : attributes s} 244 where 245 x = XN.mkAttr qn v 246{-# INLINE putAtt #-} 247 248putCont :: XmlTree -> St -> St 249putCont x s = s {contents = x : contents s} 250{-# INLINE putCont #-} 251 252-- -------------------- 253-- 254-- generally useful function for splitting a value from a list 255 256findElem :: (a -> Bool) -> [a] -> Maybe (a, [a]) 257findElem p = find' id 258 where 259 find' _ [] = Nothing 260 find' prefix (x : xs) 261 | p x = Just (x, prefix xs) 262 | otherwise = find' (prefix . (x:)) xs 263 264-- ------------------------------------------------------------ 265-- 266-- | Format the context of an error message. 267 268formatSt :: St -> String 269formatSt st = fcx ++ 270 fa (attributes st) ++ 271 fc (contents st) 272 where 273 fcx = "\n" ++ "context: " ++ 274 ( if pelem st 275 then "element" 276 else "attribute" 277 ) ++ 278 " " ++ show (pname st) 279 fc [] = "" 280 fc cs = "\n" ++ "contents: " ++ formatXML cs 281 fa [] = "" 282 fa as = "\n" ++ "attributes: " ++ formatXML as 283 formatXML = format 80 . showXML 284 showXML = concat . runLA ( xshowEscapeXml unlistA ) 285 format n s = let s' = take (n + 1) s in 286 if length s' <= n then s' else take n s ++ "..." 287 288-- ------------------------------------------------------------ 289 290-- | conversion of an arbitrary value into an XML document tree. 291-- 292-- The pickler, first parameter, controls the conversion process. 293-- Result is a complete document tree including a root node 294 295pickleDoc :: PU a -> a -> XmlTree 296pickleDoc p v = XN.mkRoot (attributes st) (contents st) 297 where 298 st = appPickle p v emptySt 299 300-- | Conversion of an XML document tree into an arbitrary data type 301-- 302-- The inverse of 'pickleDoc'. 303-- This law should hold for all picklers: @ unpickle px . pickle px $ v == Just v @. 304-- Not every possible combination of picklers does make sense. 305-- For reconverting a value from an XML tree, is becomes neccessary, 306-- to introduce \"enough\" markup for unpickling the value 307 308unpickleDoc :: PU a -> XmlTree -> Maybe a 309unpickleDoc p = either (const Nothing) Just 310 . unpickleDoc' p 311 312-- | Like unpickleDoc but with a (sometimes) useful error message, when unpickling failed. 313 314unpickleDoc' :: PU a -> XmlTree -> Either String a 315unpickleDoc' p t 316 | XN.isRoot t = mapErr $ 317 unpickleElem' p 0 t 318 | otherwise = unpickleDoc' p (XN.mkRoot [] [t]) 319 where 320 mapErr = either ( Left . 321 \ (msg, st) -> msg ++ formatSt st 322 ) Right 323 324-- | The main entry for unpickling, called by unpickleDoc 325 326unpickleElem' :: PU a -> Int -> XmlTree -> UnpickleVal a 327unpickleElem' p l t 328 = -- T.trace ("unpickleElem': " ++ show t) $ 329 ( fst . runUP (appUnPickle p) ) 330 $ St { attributes = fromMaybe [] . 331 XN.getAttrl $ t 332 , contents = XN.getChildren t 333 , nesting = l 334 , pname = fromJust . 335 XN.getName $ t 336 , pelem = XN.isElem t 337 } 338 339-- ------------------------------------------------------------ 340 341-- | Pickles a value, then writes the document to a string. 342 343showPickled :: (XmlPickler a) => SysConfigList -> a -> String 344showPickled a = concat . (pickleDoc xpickle >>> runLA (writeDocumentToString a)) 345 346-- ------------------------------------------------------------ 347 348-- | The zero pickler 349-- 350-- Encodes nothing, fails always during unpickling 351 352xpZero :: String -> PU a 353xpZero err = PU { appPickle = const id 354 , appUnPickle = throwMsg err 355 , theSchema = scNull 356 } 357 358-- | unit pickler 359 360xpUnit :: PU () 361xpUnit = xpLift () 362 363-- | Check EOF pickler. 364-- 365-- When pickling, this behaves like the unit pickler. 366-- The unpickler fails, when there is some unprocessed XML contents left. 367 368xpCheckEmptyContents :: PU a -> PU a 369xpCheckEmptyContents pa = PU { appPickle = appPickle pa 370 , appUnPickle = do res <- appUnPickle pa 371 cs <- gets contents 372 if null cs 373 then return res 374 else contentsLeft 375 , theSchema = scNull 376 } 377 where 378 contentsLeft = throwMsg 379 "xpCheckEmptyContents: unprocessed XML content detected" 380 381-- | Like xpCheckEmptyContents, but checks the attribute list 382 383xpCheckEmptyAttributes :: PU a -> PU a 384xpCheckEmptyAttributes pa 385 = PU { appPickle = appPickle pa 386 , appUnPickle = do res <- appUnPickle pa 387 as <- gets attributes 388 if null as 389 then return res 390 else attributesLeft 391 , theSchema = scNull 392 } 393 where 394 attributesLeft = throwMsg 395 "xpCheckEmptyAttributes: unprocessed XML attribute(s) detected" 396 397-- | Composition of xpCheckEmptyContents and xpCheckAttributes 398 399xpCheckEmpty :: PU a -> PU a 400xpCheckEmpty = xpCheckEmptyAttributes . xpCheckEmptyContents 401 402xpLift :: a -> PU a 403xpLift x = PU { appPickle = const id 404 , appUnPickle = return x 405 , theSchema = scEmpty 406 } 407 408-- | Lift a Maybe value to a pickler. 409-- 410-- @Nothing@ is mapped to the zero pickler, @Just x@ is pickled with @xpLift x@. 411 412xpLiftMaybe :: Maybe a -> PU a 413xpLiftMaybe v = (xpLiftMaybe'' v) { theSchema = scOption scEmpty } 414 where 415 xpLiftMaybe'' Nothing = xpZero "xpLiftMaybe: got Nothing" 416 xpLiftMaybe'' (Just x) = xpLift x 417 418xpLiftEither :: Either String a -> PU a 419xpLiftEither v = (xpLiftEither'' v) { theSchema = scOption scEmpty } 420 where 421 xpLiftEither'' (Left err) = xpZero err 422 xpLiftEither'' (Right x) = xpLift x 423 424-- | Combine two picklers sequentially. 425-- 426-- If the first fails during 427-- unpickling, the whole unpickler fails 428 429xpSeq :: (b -> a) -> PU a -> (a -> PU b) -> PU b 430xpSeq f pa k 431 = PU { appPickle = ( \ b -> 432 let a = f b in 433 appPickle pa a . appPickle (k a) b 434 ) 435 , appUnPickle = appUnPickle pa >>= (appUnPickle . k) 436 , theSchema = undefined 437 } 438 439-- | First apply a fixed pickler/unpickler, then a 2. one 440-- 441-- If the first fails during unpickling, the whole pickler fails. 442-- This can be used to check some properties of the input, e.g. whether 443-- a given fixed attribute or a namespace declaration exists ('xpAddFixedAttr', 'xpAddNSDecl') 444-- or to filter the input, e.g. to ignore some elements or attributes ('xpFilterCont', 'xpFilterAttr'). 445-- 446-- When pickling, this can be used to insert some fixed XML pieces, e.g. namespace declarations, 447-- class attributes or other stuff. 448 449xpSeq' :: PU () -> PU a -> PU a 450xpSeq' pa = xpWrap ( snd 451 , \ y -> ((), y) 452 ) . 453 xpPair pa 454 455-- | combine two picklers with a choice 456-- 457-- Run two picklers in sequence like with xpSeq. 458-- If during unpickling the first one fails, 459-- an alternative pickler (first argument) is applied. 460-- This pickler is only used as combinator for unpickling. 461 462xpChoice :: PU b -> PU a -> (a -> PU b) -> Unpickler b 463xpChoice pb pa k = mchoice (appUnPickle pa) (appUnPickle . k) (appUnPickle pb) 464 465 466-- | map value into another domain and apply pickler there 467-- 468-- One of the most often used picklers. 469 470xpWrap :: (a -> b, b -> a) -> PU a -> PU b 471xpWrap (i, j) pa = (xpSeq j pa (xpLift . i)) { theSchema = theSchema pa } 472 473-- | like 'xpWrap', but if the inverse mapping is undefined, the unpickler fails 474-- 475-- Map a value into another domain. If the inverse mapping is 476-- undefined (Nothing), the unpickler fails 477-- 478-- Deprecated: Use xpWrapEither, this gives better error messages 479 480xpWrapMaybe :: (a -> Maybe b, b -> a) -> PU a -> PU b 481xpWrapMaybe (i, j) pa = (xpSeq j pa (xpLiftMaybe . i)) { theSchema = theSchema pa } 482 483-- | like 'xpWrap', but if the inverse mapping is undefined, the unpickler fails 484-- 485-- Map a value into another domain. If the inverse mapping is 486-- undefined, the unpickler fails with an error message in the Left component 487 488xpWrapEither :: (a -> Either String b, b -> a) -> PU a -> PU b 489xpWrapEither (i, j) pa = (xpSeq j pa (xpLiftEither . i)) { theSchema = theSchema pa } 490 491-- ------------------------------------------------------------ 492 493-- | pickle a pair of values sequentially 494-- 495-- Used for pairs or together with wrap for pickling 496-- algebraic data types with two components 497 498xpPair :: PU a -> PU b -> PU (a, b) 499xpPair pa pb 500 = ( xpSeq fst pa (\ a -> 501 xpSeq snd pb (\ b -> 502 xpLift (a,b))) 503 ) { theSchema = scSeq (theSchema pa) (theSchema pb) } 504 505-- | Like 'xpPair' but for triples 506 507xpTriple :: PU a -> PU b -> PU c -> PU (a, b, c) 508xpTriple pa pb pc 509 = xpWrap (toTriple, fromTriple) (xpPair pa (xpPair pb pc)) 510 where 511 toTriple ~(a, ~(b, c)) = (a, b, c ) 512 fromTriple ~(a, b, c ) = (a, (b, c)) 513 514-- | Like 'xpPair' and 'xpTriple' but for 4-tuples 515 516xp4Tuple :: PU a -> PU b -> PU c -> PU d -> PU (a, b, c, d) 517xp4Tuple pa pb pc pd 518 = xpWrap (toQuad, fromQuad) (xpPair pa (xpPair pb (xpPair pc pd))) 519 where 520 toQuad ~(a, ~(b, ~(c, d))) = (a, b, c, d ) 521 fromQuad ~(a, b, c, d ) = (a, (b, (c, d))) 522 523-- | Like 'xpPair' and 'xpTriple' but for 5-tuples 524 525xp5Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU (a, b, c, d, e) 526xp5Tuple pa pb pc pd pe 527 = xpWrap (toQuint, fromQuint) (xpPair pa (xpPair pb (xpPair pc (xpPair pd pe)))) 528 where 529 toQuint ~(a, ~(b, ~(c, ~(d, e)))) = (a, b, c, d, e ) 530 fromQuint ~(a, b, c, d, e ) = (a, (b, (c, (d, e)))) 531 532-- | Like 'xpPair' and 'xpTriple' but for 6-tuples 533 534xp6Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU f -> PU (a, b, c, d, e, f) 535xp6Tuple pa pb pc pd pe pf 536 = xpWrap (toSix, fromSix) (xpPair pa (xpPair pb (xpPair pc (xpPair pd (xpPair pe pf))))) 537 where 538 toSix ~(a, ~(b, ~(c, ~(d, ~(e, f))))) = (a, b, c, d, e, f ) 539 fromSix ~(a, b, c, d, e, f) = (a, (b, (c, (d, (e, f))))) 540 541-- ------------------------------------------------------------ 542 543-- | Like 'xpPair' and 'xpTriple' but for 7-tuples 544-- 545-- Thanks to Tony Morris for doing xp7Tuple, ..., xp24Tuple. 546 547xp7Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 548 PU f -> PU g -> PU (a, b, c, d, e, f, g) 549xp7Tuple a b c d e f g 550 = xpWrap ( \ (a, (b, c, d, e, f, g)) -> (a, b, c, d, e, f, g) 551 , \ (a, b, c, d, e, f, g) -> (a, (b, c, d, e, f, g)) 552 ) 553 (xpPair a (xp6Tuple b c d e f g)) 554 555xp8Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 556 PU f -> PU g -> PU h -> PU (a, b, c, d, e, f, g, h) 557xp8Tuple a b c d e f g h 558 = xpWrap ( \ ((a, b), (c, d, e, f, g, h)) -> (a, b, c, d, e, f, g, h) 559 , \ (a, b, c, d, e, f, g, h) -> ((a, b), (c, d, e, f, g, h)) 560 ) 561 (xpPair (xpPair a b) (xp6Tuple c d e f g h)) 562 563xp9Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 564 PU f -> PU g -> PU h -> PU i -> PU (a, b, c, d, e, f, g, h, i) 565xp9Tuple a b c d e f g h i 566 = xpWrap ( \ ((a, b, c), (d, e, f, g, h, i)) -> (a, b, c, d, e, f, g, h, i) 567 , \ (a, b, c, d, e, f, g, h, i) -> ((a, b, c), (d, e, f, g, h, i)) 568 ) 569 (xpPair (xpTriple a b c) (xp6Tuple d e f g h i)) 570 571xp10Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 572 PU f -> PU g -> PU h -> PU i -> PU j -> 573 PU (a, b, c, d, e, f, g, h, i, j) 574xp10Tuple a b c d e f g h i j 575 = xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j)) -> (a, b, c, d, e, f, g, h, i, j) 576 , \ (a, b, c, d, e, f, g, h, i, j) -> ((a, b, c, d), (e, f, g, h, i, j)) 577 ) 578 (xpPair (xp4Tuple a b c d) (xp6Tuple e f g h i j)) 579 580xp11Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 581 PU f -> PU g -> PU h -> PU i -> PU j -> 582 PU k -> PU (a, b, c, d, e, f, g, h, i, j, k) 583xp11Tuple a b c d e f g h i j k 584 = xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k)) -> (a, b, c, d, e, f, g, h, i, j, k) 585 , \ (a, b, c, d, e, f, g, h, i, j, k) -> ((a, b, c, d, e), (f, g, h, i, j, k)) 586 ) 587 (xpPair (xp5Tuple a b c d e) (xp6Tuple f g h i j k)) 588 589xp12Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 590 PU f -> PU g -> PU h -> PU i -> PU j -> 591 PU k -> PU l -> PU (a, b, c, d, e, f, g, h, i, j, k, l) 592xp12Tuple a b c d e f g h i j k l 593 = 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) 594 , \ (a, b, c, d, e, f, g, h, i, j, k, l) -> ((a, b, c, d, e, f), (g, h, i, j, k, l)) 595 ) 596 (xpPair (xp6Tuple a b c d e f) (xp6Tuple g h i j k l)) 597 598xp13Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 599 PU f -> PU g -> PU h -> PU i -> PU j -> 600 PU k -> PU l -> PU m -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m) 601xp13Tuple a b c d e f g h i j k l m 602 = 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) 603 , \ (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)) 604 ) 605 (xpTriple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m)) 606 607xp14Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 608 PU f -> PU g -> PU h -> PU i -> PU j -> 609 PU k -> PU l -> PU m -> PU n -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n) 610xp14Tuple a b c d e f g h i j k l m n 611 = 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) 612 , \ (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)) 613 ) 614 (xpTriple (xpPair a b) (xp6Tuple c d e f g h) (xp6Tuple i j k l m n)) 615 616xp15Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 617 PU f -> PU g -> PU h -> PU i -> PU j -> 618 PU k -> PU l -> PU m -> PU n -> PU o -> 619 PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) 620xp15Tuple a b c d e f g h i j k l m n o 621 = 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) 622 , \ (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)) 623 ) 624 (xpTriple (xpTriple a b c) (xp6Tuple d e f g h i) (xp6Tuple j k l m n o)) 625 626xp16Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 627 PU f -> PU g -> PU h -> PU i -> PU j -> 628 PU k -> PU l -> PU m -> PU n -> PU o -> 629 PU p -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) 630xp16Tuple a b c d e f g h i j k l m n o p 631 = 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) 632 , \ (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)) 633 ) 634 (xpTriple (xp4Tuple a b c d) (xp6Tuple e f g h i j) (xp6Tuple k l m n o p)) 635 636xp17Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 637 PU f -> PU g -> PU h -> PU i -> PU j -> 638 PU k -> PU l -> PU m -> PU n -> PU o -> 639 PU p -> PU q -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) 640xp17Tuple a b c d e f g h i j k l m n o p q 641 = 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) 642 , \ (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)) 643 ) 644 (xpTriple (xp5Tuple a b c d e) (xp6Tuple f g h i j k) (xp6Tuple l m n o p q)) 645 646xp18Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 647 PU f -> PU g -> PU h -> PU i -> PU j -> 648 PU k -> PU l -> PU m -> PU n -> PU o -> 649 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) 650xp18Tuple a b c d e f g h i j k l m n o p q r 651 = 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) 652 , \ (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)) 653 ) 654 (xpTriple (xp6Tuple a b c d e f) (xp6Tuple g h i j k l) (xp6Tuple m n o p q r)) 655 656xp19Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 657 PU f -> PU g -> PU h -> PU i -> PU j -> 658 PU k -> PU l -> PU m -> PU n -> PU o -> 659 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) 660xp19Tuple a b c d e f g h i j k l m n o p q r s 661 = 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) 662 , \ (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)) 663 ) 664 (xp4Tuple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m) (xp6Tuple n o p q r s)) 665 666xp20Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 667 PU f -> PU g -> PU h -> PU i -> PU j -> 668 PU k -> PU l -> PU m -> PU n -> PU o -> 669 PU p -> PU q -> PU r -> PU s -> PU t -> 670 PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) 671xp20Tuple a b c d e f g h i j k l m n o p q r s t 672 = 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) 673 , \ (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)) 674 ) 675 (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)) 676 677xp21Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 678 PU f -> PU g -> PU h -> PU i -> PU j -> 679 PU k -> PU l -> PU m -> PU n -> PU o -> 680 PU p -> PU q -> PU r -> PU s -> PU t -> 681 PU u -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) 682xp21Tuple a b c d e f g h i j k l m n o p q r s t u 683 = 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) 684 , \ (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)) 685 ) 686 (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)) 687 688xp22Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 689 PU f -> PU g -> PU h -> PU i -> PU j -> 690 PU k -> PU l -> PU m -> PU n -> PU o -> 691 PU p -> PU q -> PU r -> PU s -> PU t -> 692 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) 693xp22Tuple a b c d e f g h i j k l m n o p q r s t u v 694 = 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) 695 , \ (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)) 696 ) 697 (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)) 698 699xp23Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 700 PU f -> PU g -> PU h -> PU i -> PU j -> 701 PU k -> PU l -> PU m -> PU n -> PU o -> 702 PU p -> PU q -> PU r -> PU s -> PU t -> 703 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) 704xp23Tuple a b c d e f g h i j k l m n o p q r s t u v w 705 = 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) 706 , \ (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)) 707 ) 708 (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)) 709 710-- | Hopefully no one needs a xp25Tuple 711 712xp24Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> 713 PU f -> PU g -> PU h -> PU i -> PU j -> 714 PU k -> PU l -> PU m -> PU n -> PU o -> 715 PU p -> PU q -> PU r -> PU s -> PU t -> 716 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) 717xp24Tuple a b c d e f g h i j k l m n o p q r s t u v w x 718 = 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) 719 , \ (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)) 720 ) 721 (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)) 722 723-- ------------------------------------------------------------ 724 725 726-- | Pickle a string into an XML text node 727-- 728-- One of the most often used primitive picklers. Attention: 729-- For pickling empty strings use 'xpText0'. If the text has a more 730-- specific datatype than xsd:string, use 'xpTextDT' 731 732xpText :: PU String 733xpText = xpTextDT scString1 734{-# INLINE xpText #-} 735 736-- | Pickle a string into an XML text node 737-- 738-- Text pickler with a description of the structure of the text 739-- by a schema. A schema for a data type can be defined by 'Text.XML.HXT.Arrow.Pickle.Schema.scDT'. 740-- In 'Text.XML.HXT.Arrow.Pickle.Schema' there are some more functions for creating 741-- simple datatype descriptions. 742 743xpTextDT :: Schema -> PU String 744xpTextDT sc = PU { appPickle = putCont . XN.mkText 745 , appUnPickle = do t <- getCont 746 liftMaybe "xpText: XML text expected" $ XN.getText t 747 , theSchema = sc 748 } 749 750-- | Pickle a possibly empty string into an XML node. 751-- 752-- Must be used in all places, where empty strings are legal values. 753-- If the content of an element can be an empty string, this string disapears 754-- during storing the DOM into a document and reparse the document. 755-- So the empty text node becomes nothing, and the pickler must deliver an empty string, 756-- if there is no text node in the document. 757 758xpText0 :: PU String 759xpText0 = xpText0DT scString1 760{-# INLINE xpText0 #-} 761 762-- | Pickle a possibly empty string with a datatype description into an XML node. 763-- 764-- Like 'xpText0' but with extra Parameter for datatype description as in 'xpTextDT'. 765 766xpText0DT :: Schema -> PU String 767xpText0DT sc = xpWrap (fromMaybe "", emptyToNothing) $ 768 xpOption $ 769 xpTextDT sc 770 where 771 emptyToNothing "" = Nothing 772 emptyToNothing x = Just x 773 774-- | Pickle an arbitrary value by applyling show during pickling 775-- and read during unpickling. 776-- 777-- Real pickling is then done with 'xpText'. 778-- One of the most often used pimitive picklers. Applicable for all 779-- types which are instances of @Read@ and @Show@ 780 781xpPrim :: (Read a, Show a) => PU a 782xpPrim = xpWrapEither (readMaybe, show) xpText 783 where 784 readMaybe :: Read a => String -> Either String a 785 readMaybe str = val (reads str) 786 where 787 val [(x,"")] = Right x 788 val _ = Left $ "xpPrim: reading string " ++ show str ++ " failed" 789 790-- | Pickle an Int 791xpInt :: PU Int 792xpInt = xpWrapEither (readMaybe, show) xpText 793 where 794 readMaybe xs@(_:_) 795 | all isDigit xs = Right . foldl' (\ r c -> 10 * r + (fromEnum c - fromEnum '0')) 0 $ xs 796 readMaybe ('-' : xs) = fmap (0 -) . readMaybe $ xs 797 readMaybe ('+' : xs) = readMaybe $ xs 798 readMaybe xs = Left $ "xpInt: reading an Int from string " ++ show xs ++ " failed" 799 800-- ------------------------------------------------------------ 801 802-- | Pickle an XmlTree by just adding it 803-- 804-- Usefull for components of type XmlTree in other data structures 805 806xpTree :: PU XmlTree 807xpTree = PU { appPickle = putCont 808 , appUnPickle = getCont 809 , theSchema = Any 810 } 811 812-- | Pickle a whole list of XmlTrees by just adding the list, unpickle is done by taking all element contents. 813-- 814-- This pickler should always be combined with 'xpElem' for taking the whole contents of an element. 815 816xpTrees :: PU [XmlTree] 817xpTrees = (xpList xpTree) { theSchema = Any } 818 819-- | Pickle a string representing XML contents by inserting the tree representation into the XML document. 820-- 821-- Unpickling is done by converting the contents with 822-- 'Text.XML.HXT.Arrow.Edit.xshowEscapeXml' into a string, 823-- this function will escape all XML special chars, such that pickling the value back becomes save. 824-- Pickling is done with 'Text.XML.HXT.Arrow.ReadDocument.xread' 825 826xpXmlText :: PU String 827xpXmlText = xpWrap ( showXML, readXML ) $ xpTrees 828 where 829 showXML = concat . runLA ( xshowEscapeXml unlistA ) 830 readXML = runLA xread 831 832-- ------------------------------------------------------------ 833 834-- | Encoding of optional data by ignoring the Nothing case during pickling 835-- and relying on failure during unpickling to recompute the Nothing case 836-- 837-- The default pickler for Maybe types 838 839xpOption :: PU a -> PU (Maybe a) 840xpOption pa = PU { appPickle = ( \ a -> 841 case a of 842 Nothing -> id 843 Just x -> appPickle pa x 844 ) 845 846 , appUnPickle = xpChoice (xpLift Nothing) pa (xpLift . Just) 847 848 , theSchema = scOption (theSchema pa) 849 } 850 851-- | Optional conversion with default value 852-- 853-- The default value is not encoded in the XML document, 854-- during unpickling the default value is inserted if the pickler fails 855 856xpDefault :: (Eq a) => a -> PU a -> PU a 857xpDefault df = xpWrap ( fromMaybe df 858 , \ x -> if x == df then Nothing else Just x 859 ) . 860 xpOption 861 862-- ------------------------------------------------------------ 863 864-- | Encoding of list values by pickling all list elements sequentially. 865-- 866-- Unpickler relies on failure for detecting the end of the list. 867-- The standard pickler for lists. Can also be used in combination with 'xpWrap' 868-- for constructing set and map picklers 869 870xpList :: PU a -> PU [a] 871xpList pa = PU { appPickle = ( \ a -> 872 case a of 873 [] -> id 874 _:_ -> appPickle pc a 875 ) 876 , appUnPickle = xpChoice 877 (xpLift []) 878 pa 879 (\ x -> xpSeq id (xpList pa) (\xs -> xpLift (x:xs))) 880 881 , theSchema = scList (theSchema pa) 882 } 883 where 884 pc = xpSeq head pa (\ x -> 885 xpSeq tail (xpList pa) (\ xs -> 886 xpLift (x:xs) )) 887 888-- | Encoding of a none empty list of values 889-- 890-- Attention: when calling this pickler with an empty list, 891-- an internal error \"head of empty list is raised\". 892 893xpList1 :: PU a -> PU [a] 894xpList1 pa = ( xpWrap (\ (x, xs) -> x : xs 895 ,\ x -> (head x, tail x) 896 ) $ 897 xpPair pa (xpList pa) 898 ) { theSchema = scList1 (theSchema pa) } 899 900-- ------------------------------------------------------------ 901 902-- | Standard pickler for maps 903-- 904-- This pickler converts a map into a list of pairs. 905-- All key value pairs are mapped to an element with name (1.arg), 906-- the key is encoded as an attribute named by the 2. argument, 907-- the 3. arg is the pickler for the keys, the last one for the values 908 909xpMap :: Ord k => String -> String -> PU k -> PU v -> PU (Map k v) 910xpMap en an xpk xpv 911 = xpWrap ( M.fromList 912 , M.toList 913 ) $ 914 xpList $ 915 xpElem en $ 916 xpPair ( xpAttr an $ xpk ) xpv 917 918-- ------------------------------------------------------------ 919 920-- | Pickler for sum data types. 921-- 922-- Every constructor is mapped to an index into the list of picklers. 923-- The index is used only during pickling, not during unpickling, there the 1. match is taken 924 925xpAlt :: (a -> Int) -> [PU a] -> PU a 926xpAlt tag ps = PU { appPickle = \ a -> 927 appPickle (ps !! tag a) a 928 929 , appUnPickle = case ps of 930 [] -> throwMsg "xpAlt: no matching unpickler found for a sum datatype" 931 pa:ps1 -> xpChoice (xpAlt tag ps1) pa xpLift 932 933 , theSchema = scAlts (map theSchema ps) 934 } 935 936-- ------------------------------------------------------------ 937 938-- | Pickler for wrapping\/unwrapping data into an XML element 939-- 940-- Extra parameter is the element name given as a QName. THE pickler for constructing 941-- nested structures 942-- 943-- Example: 944-- 945-- > xpElemQN (mkName "number") $ xpickle 946-- 947-- will map an (42::Int) onto 948-- 949-- > <number>42</number> 950 951xpElemQN :: QName -> PU a -> PU a 952xpElemQN qn pa = PU { appPickle = ( \ a -> 953 let st' = appPickle pa a emptySt in 954 putCont (XN.mkElement qn (attributes st') (contents st')) 955 ) 956 , appUnPickle = upElem 957 , theSchema = scElem (qualifiedName qn) (theSchema pa) 958 } 959 where 960 upElem = do t <- getCont 961 n <- liftMaybe "xpElem: XML element expected" $ XN.getElemName t 962 if n /= qn 963 then throwMsg ("xpElem: got element name " ++ show n ++ ", but expected " ++ show qn) 964 else do l <- gets nesting 965 liftUnpickleVal $ unpickleElem' (xpCheckEmpty pa) (l + 1) t 966 967-- | convenient Pickler for xpElemQN 968-- 969-- > xpElem n = xpElemQN (mkName n) 970 971xpElem :: String -> PU a -> PU a 972xpElem = xpElemQN . mkName 973 974-- | convenient Pickler for xpElemQN 975-- for pickling elements with respect to namespaces 976-- 977-- > xpElemNS ns px lp = xpElemQN (mkQName px lp ns) 978 979xpElemNS :: String -> String -> String -> PU a -> PU a 980xpElemNS ns px lp 981 = xpElemQN $ mkQName px lp ns 982 983-- ------------------------------------------------------------ 984 985-- | Pickler for wrapping\/unwrapping data into an XML element with an attribute with given value 986-- 987-- To make XML structures flexible but limit the number of different elements, it's sometimes 988-- useful to use a kind of generic element with a key value structure 989-- 990-- Example: 991-- 992-- > <attr name="key1">value1</attr> 993-- > <attr name="key2">value2</attr> 994-- > <attr name="key3">value3</attr> 995-- 996-- the Haskell datatype may look like this 997-- 998-- > type T = T { key1 :: Int ; key2 :: String ; key3 :: Double } 999-- 1000-- Then the picker for that type looks like this 1001-- 1002-- > xpT :: PU T 1003-- > xpT = xpWrap ( uncurry3 T, \ t -> (key1 t, key2 t, key3 t) ) $ 1004-- > xpTriple (xpElemWithAttrValue "attr" "name" "key1" $ xpickle) 1005-- > (xpElemWithAttrValue "attr" "name" "key2" $ xpText0) 1006-- > (xpElemWithAttrValue "attr" "name" "key3" $ xpickle) 1007 1008xpElemWithAttrValue :: String -> String -> String -> PU a -> PU a 1009xpElemWithAttrValue name an av pa 1010 = xpElem name $ 1011 xpAddFixedAttr an av $ 1012 pa 1013 1014-- ------------------------------------------------------------ 1015 1016-- | Pickler for storing\/retreiving data into\/from an attribute value 1017-- 1018-- The attribute is inserted in the surrounding element constructed by the 'xpElem' pickler 1019 1020xpAttrQN :: QName -> PU a -> PU a 1021xpAttrQN qn pa = PU { appPickle = ( \ a -> 1022 let st' = appPickle pa a emptySt in 1023 putAtt qn (contents st') 1024 ) 1025 , appUnPickle = upAttr 1026 , theSchema = scAttr (qualifiedName qn) (theSchema pa) 1027 } 1028 where 1029 upAttr = do a <- getAtt qn 1030 l <- gets nesting 1031 liftUnpickleVal $ unpickleElem' (xpCheckEmptyContents pa) l a 1032 1033-- | convenient Pickler for xpAttrQN 1034-- 1035-- > xpAttr n = xpAttrQN (mkName n) 1036 1037xpAttr :: String -> PU a -> PU a 1038xpAttr = xpAttrQN . mkName 1039 1040-- | convenient Pickler for xpAttrQN 1041-- 1042-- > xpAttr ns px lp = xpAttrQN (mkQName px lp ns) 1043 1044xpAttrNS :: String -> String -> String -> PU a -> PU a 1045xpAttrNS ns px lp 1046 = xpAttrQN (mkQName px lp ns) 1047 1048-- | A text attribute. 1049xpTextAttr :: String -> PU String 1050xpTextAttr = flip xpAttr xpText 1051 1052-- | Add an optional attribute for an optional value (Maybe a). 1053 1054xpAttrImplied :: String -> PU a -> PU (Maybe a) 1055xpAttrImplied name pa 1056 = xpOption $ xpAttr name pa 1057 1058xpAttrFixed :: String -> String -> PU () 1059xpAttrFixed name val 1060 = ( xpWrapEither ( \ v -> 1061 if v == val 1062 then Right () 1063 else Left ( "xpAttrFixed: value " 1064 ++ show val 1065 ++ " expected, but got " 1066 ++ show v 1067 ) 1068 , const val 1069 ) $ 1070 xpAttr name xpText 1071 ) { theSchema = scAttr name (scFixed val) } 1072 1073-- | Add/Check an attribute with a fixed value. 1074-- 1075 1076xpAddFixedAttr :: String -> String -> PU a -> PU a 1077xpAddFixedAttr name val 1078 = xpSeq' $ xpAttrFixed name val 1079 1080-- | Add a namespace declaration. 1081-- 1082-- When generating XML the namespace decl is added, 1083-- when reading a document, the unpickler checks 1084-- whether there is a namespace declaration for the given 1085-- namespace URI (2. arg) 1086 1087xpAddNSDecl :: String -> String -> PU a -> PU a 1088xpAddNSDecl name val 1089 = xpSeq' $ xpAttrNSDecl name' val 1090 where 1091 name' 1092 | null name = "xmlns" 1093 | otherwise = "xmlns:" ++ name 1094 1095xpAttrNSDecl :: String -> String -> PU () 1096xpAttrNSDecl name ns 1097 = PU { appPickle = const $ putAtt (mkName name) [XN.mkText ns] 1098 , appUnPickle = getNSAtt ns 1099 , theSchema = scAttr name (scFixed ns) 1100 } 1101 1102-- ------------------------------------------------------------ 1103 1104xpIgnoreCont :: LA XmlTree XmlTree -> PU () 1105xpIgnoreCont = xpIgnoreInput $ \ mf s -> s {contents = mf $ contents s} 1106 1107xpIgnoreAttr :: LA XmlTree XmlTree -> PU () 1108xpIgnoreAttr = xpIgnoreInput $ \ mf s -> s {attributes = mf $ attributes s} 1109 1110-- | When unpickling, filter the contents of the element currently processed, 1111-- before applying the pickler argument 1112-- 1113-- Maybe useful to ignore some stuff in the input, or to do some cleanup before unpickling. 1114 1115xpFilterCont :: LA XmlTree XmlTree -> PU a -> PU a 1116xpFilterCont f = xpSeq' $ xpIgnoreCont f 1117 1118-- | Same as 'xpFilterCont' but for the attribute list of the element currently processed. 1119-- 1120-- Maybe useful to ignore some stuff in the input, e.g. class attributes, or to do some cleanup before unpickling. 1121 1122xpFilterAttr :: LA XmlTree XmlTree -> PU a -> PU a 1123xpFilterAttr f = xpSeq' $ xpIgnoreAttr f 1124 1125xpIgnoreInput :: (([XmlTree] -> [XmlTree]) -> St -> St) -> LA XmlTree XmlTree -> PU () 1126xpIgnoreInput m f 1127 = PU { appPickle = const id 1128 , appUnPickle = do modify (m filterCont) 1129 return () 1130 , theSchema = scNull 1131 } 1132 where 1133 filterCont = runLA (unlistA >>> f) 1134 1135-- ------------------------------------------------------------ 1136 1137-- | The class for overloading 'xpickle', the default pickler 1138 1139class XmlPickler a where 1140 xpickle :: PU a 1141 1142instance XmlPickler Int where 1143 xpickle = xpPrim 1144 1145instance XmlPickler Integer where 1146 xpickle = xpPrim 1147 1148{- 1149 no instance of XmlPickler Char 1150 because then every text would be encoded 1151 char by char, because of the instance for lists 1152 1153instance XmlPickler Char where 1154 xpickle = xpPrim 1155-} 1156 1157instance XmlPickler () where 1158 xpickle = xpUnit 1159 1160instance (XmlPickler a, XmlPickler b) => XmlPickler (a,b) where 1161 xpickle = xpPair xpickle xpickle 1162 1163instance (XmlPickler a, XmlPickler b, XmlPickler c) => XmlPickler (a,b,c) where 1164 xpickle = xpTriple xpickle xpickle xpickle 1165 1166instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d) => XmlPickler (a,b,c,d) where 1167 xpickle = xp4Tuple xpickle xpickle xpickle xpickle 1168 1169instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e) => XmlPickler (a,b,c,d,e) where 1170 xpickle = xp5Tuple xpickle xpickle xpickle xpickle xpickle 1171 1172instance XmlPickler a => XmlPickler [a] where 1173 xpickle = xpList xpickle 1174 1175instance XmlPickler a => XmlPickler (Maybe a) where 1176 xpickle = xpOption xpickle 1177 1178-- ------------------------------------------------------------ 1179 1180{- begin embeded test cases 1181 1182-- ------------------------------------------------------------ 1183-- 1184-- a somewhat complex data structure 1185-- for representing programs of a simple 1186-- imperative language 1187 1188type Program = Stmt 1189 1190type StmtList = [Stmt] 1191 1192data Stmt 1193 = Assign Ident Expr 1194 | Stmts StmtList 1195 | If Expr Stmt (Maybe Stmt) 1196 | While Expr Stmt 1197 deriving (Eq, Show) 1198 1199type Ident = String 1200 1201data Expr 1202 = IntConst Int 1203 | BoolConst Bool 1204 | Var Ident 1205 | UnExpr UnOp Expr 1206 | BinExpr Op Expr Expr 1207 deriving (Eq, Show) 1208 1209data Op 1210 = Add | Sub | Mul | Div | Mod | Eq | Neq 1211 deriving (Eq, Ord, Enum, Show) 1212 1213data UnOp 1214 = UPlus | UMinus | Neg 1215 deriving (Eq, Ord, Read, Show) 1216 1217-- ------------------------------------------------------------ 1218-- 1219-- the pickler definition for the data types 1220 1221-- the main pickler 1222 1223xpProgram :: PU Program 1224xpProgram = xpElem "program" $ 1225 xpAddNSDecl "" "program42" $ 1226 xpickle 1227 1228xpMissingRootElement :: PU Program 1229xpMissingRootElement = xpickle 1230 1231instance XmlPickler UnOp where 1232 xpickle = xpPrim 1233 1234instance XmlPickler Op where 1235 xpickle = xpWrap (toEnum, fromEnum) xpPrim 1236 1237instance XmlPickler Expr where 1238 xpickle = xpAlt tag ps 1239 where 1240 tag (IntConst _ ) = 0 1241 tag (BoolConst _ ) = 1 1242 tag (Var _ ) = 2 1243 tag (UnExpr _ _ ) = 3 1244 tag (BinExpr _ _ _ ) = 4 1245 ps = [ xpWrap ( IntConst 1246 , \ (IntConst i ) -> i 1247 ) $ 1248 ( xpElem "int" $ 1249 xpAttr "value" $ 1250 xpickle 1251 ) 1252 1253 , xpWrap ( BoolConst 1254 , \ (BoolConst b) -> b 1255 ) $ 1256 ( xpElem "bool" $ 1257 xpAttr "value" $ 1258 xpWrap (toEnum, fromEnum) xpickle 1259 ) 1260 1261 , xpWrap ( Var 1262 , \ (Var n) -> n 1263 ) $ 1264 ( xpElem "var" $ 1265 xpAttr "name" $ 1266 xpText 1267 ) 1268 1269 , xpWrap ( uncurry UnExpr 1270 , \ (UnExpr op e) -> (op, e) 1271 ) $ 1272 ( xpElem "unex" $ 1273 xpPair (xpAttr "op" xpickle) 1274 xpickle 1275 ) 1276 1277 , xpWrap ( uncurry3 $ BinExpr 1278 , \ (BinExpr op e1 e2) -> (op, e1, e2) 1279 ) $ 1280 ( xpElem "binex" $ 1281 xpTriple (xpAttr "op" xpickle) 1282 xpickle 1283 xpickle 1284 ) 1285 ] 1286 1287instance XmlPickler Stmt where 1288 xpickle = xpAlt tag ps 1289 where 1290 tag ( Assign _ _ ) = 0 1291 tag ( Stmts _ ) = 1 1292 tag ( If _ _ _ ) = 2 1293 tag ( While _ _ ) = 3 1294 ps = [ xpWrap ( uncurry Assign 1295 , \ (Assign n v) -> (n, v) 1296 ) $ 1297 ( xpElem "assign" $ 1298 xpFilterCont (neg $ hasName "comment" <+> isText) $ -- test case test7: remove uninteresting stuff 1299 xpPair (xpAttr "name" xpText) 1300 xpickle 1301 ) 1302 , xpWrap ( Stmts 1303 , \ (Stmts sl) -> sl 1304 ) $ 1305 ( xpElem "block" $ 1306 xpList xpickle 1307 ) 1308 , xpWrap ( uncurry3 If 1309 , \ (If c t e) -> (c, t, e) 1310 ) $ 1311 ( xpElem "if" $ 1312 xpTriple xpickle 1313 xpickle 1314 xpickle 1315 ) 1316 , xpWrap ( uncurry While 1317 , \ (While c b) -> (c, b) 1318 ) $ 1319 ( xpElem "while" $ 1320 xpPair xpickle 1321 xpickle 1322 ) 1323 ] 1324 1325-- ------------------------------------------------------------ 1326-- 1327-- example programs 1328 1329progs :: [Program] 1330progs = [p0, p1, p2] 1331 1332p0, p1, p2 :: Program 1333 1334p0 = Stmts [] -- the empty program 1335 1336p1 = Stmts 1337 [ Assign i ( UnExpr UMinus ( IntConst (-22) ) ) 1338 , Assign j ( IntConst 20 ) 1339 , While 1340 ( BinExpr Neq ( Var i ) ( IntConst 0 ) ) 1341 ( Stmts 1342 [ Assign i ( BinExpr Sub ( Var i ) ( IntConst 1 ) ) 1343 , Assign j ( BinExpr Add ( Var j ) ( IntConst 1 ) ) 1344 , If ( IntConst 0 ) (Stmts []) Nothing 1345 ] 1346 ) 1347 ] 1348 where 1349 i = "i" 1350 j = "j" 1351 1352p2 = Stmts 1353 [ Assign x (IntConst 6) 1354 , Assign y (IntConst 7) 1355 , Assign p (IntConst 0) 1356 , While 1357 ( BinExpr Neq (Var x) (IntConst 0) ) 1358 ( If ( BinExpr Neq ( BinExpr Mod (Var x) (IntConst 2) ) (IntConst 0) ) 1359 ( Stmts 1360 [ Assign x ( BinExpr Sub (Var x) (IntConst 1) ) 1361 , Assign p ( BinExpr Add (Var p) (Var y) ) 1362 ] 1363 ) 1364 ( Just ( Stmts 1365 [ Assign x ( BinExpr Div (Var x) (IntConst 2) ) 1366 , Assign y ( BinExpr Mul (Var y) (IntConst 2) ) 1367 ] 1368 ) 1369 ) 1370 ) 1371 ] 1372 where 1373 x = "x" 1374 y = "y" 1375 p = "p" 1376 1377-- ------------------------------------------------------------ 1378 1379test0 = putStrLn . head . runLA 1380 ( xshow (arr (pickleDoc xpProgram) 1381 >>> getChildren 1382 ) 1383 ) 1384 1385test0' f = runLA 1386 ( xshow (arr (pickleDoc xpProgram) 1387 >>> getChildren 1388 ) 1389 >>> 1390 root [] [xread] 1391 >>> 1392 f 1393 ) 1394 1395test1' f = runLA 1396 ( xshow (arr (pickleDoc xpProgram) 1397 >>> getChildren 1398 ) 1399 >>> 1400 root [] [xread] 1401 >>> 1402 f 1403 >>> 1404 arr (unpickleDoc' xpProgram) 1405 ) 1406 1407test1 = test0' (processTopDown (setQName (mkName "real") `X.when` hasName "int")) 1408test2 = test1' this 1409test3 = test1' (processTopDown (setQName (mkName "real") `X.when` hasName "int")) 1410test4 = test1' (processTopDown (setQName (mkName "xxx") `X.when` hasName "program")) 1411test5 = test1' (processTopDown (setQName (mkName "xxx") `X.when` hasName "assign")) 1412test6 = test1' (processTopDownWithAttrl (txt "xxx" `X.when` hasText (== "UMinus"))) 1413test7 = test1' (processTopDown (insertComment `X.when` hasName "assign")) 1414 where insertComment = replaceChildren (getChildren <+> eelem "comment" <+> txt "zzz") 1415 1416-- ------------------------------------------------------------ 1417 1418-- end embeded test cases -} 1419