{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances,
             UndecidableInstances, FunctionalDependencies #-}

-- | @hexpat-pickle@ provides XML picklers that plug into the parse tree of the
-- @hexpat@ package, providing XML serialization with excellent performance.
-- They are source code similar to those of the HXT package. The concept and
-- design was lifted entirely from HXT.
--
-- The API differences between @HXT@ and @hexpat-pickle@ are:
--
--  * 'PU' and 'XmlPickler' take one extra argument, indicating the part of the
--        XML tree we are working with.
--
--  * 'xpElem' takes three arguments to HXT's two, because we treat attributes
--        and child nodes separately, while HXT groups them together.
--
--  * HXT's list of pickler primitives is a little more complete.
--
-- The data type @'PU' t a@ represents both a pickler (converting Haskell data
-- to XML) and an unpickler (XML to Haskell data), so your code only needs to be
-- written once for both serialization and deserialization.  The 'PU' primitives, such
-- as 'xpElem' for XML elements, may be composed into complex arrangements using
-- 'xpPair' and other combinators.
--
-- The @t@ argument (absent in HXT) represents the part of the XML tree
-- that this 'PU' works on. @t@ has /four/ possible values (assuming we are
-- using the String type for our strings):
--
--  * @'Element' t String String => 'PU' t a@ /(for working with an XML element)/
--
--  * @'PU' ['Node' String String] a@ /(for working with lists of elements)/
--
--  * @'TextContent' t String => 'PU' t a@ /(for working with text content)/
--
--  * @'PU' [(String, String)] a@ /(for working with attributes)/
--
-- In the /list of elements/ and /attributes/ cases we use concrete types.
-- However, 'Element' is implemented as a /type class/, because it behaves slightly
-- differently in two situations: 1. The root node of a document, and 2. A child
-- node (because in this situation it can search the list of nodes for a match).
-- 'TextContent' is also a /type class/, because it behaves differently in
-- 1. attribute values, and 2. text content of elements.
--
-- @hexpat-pickle@ can work with the following string types:
--
--  * String
--
--  * Data.ByteString
--
--  * Data.Text
--
-- and it is extensible to any other string type by 1. writing a @hexpat@ \"flavor\"
-- for it, and making it an instance of 'GenericXMLString'.  We select the type for
-- XML /tag/ and /text/ separately in our four \"tree part\" types as follows:
--
--  * @'Element' t /tag/ /text/ => 'PU' t a@
--
--  * @'PU' ['Node' /tag/ /text/] a@
--
--  * @'TextContent' t /text/ => 'PU' t a@
--
--  * @'PU' [(/tag/, /text/)]@
--
-- /tag/ may be a string type, or it may be a QName type defined in
-- the 'Text.XML.Expat.Qualified' module.  (Or you can extend it any way you like.)
--
-- The type class 'XmlPickler' is used to extend a polymorphic 'xpickle' function
-- to provide a pickler for a new type, in a similar way to 'Read' and 'Show'.
--
-- @hexpat-pickle@ abuses type classes to the extent that it requires a long
-- list of GHC extensions. You will need most or all of these in your code:
--
-- @
-- {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,
--              TypeSynonymInstances, UndecidableInstances #-}
-- @
--
-- Here is a simple and complete example to get you started:
--
-- >  {-# LANGUAGE FlexibleContexts #-}
-- >  
-- >  import Text.XML.Expat.Tree
-- >  import Text.XML.Expat.Pickle
-- >  import Text.XML.Expat.Format
-- >  import qualified Data.ByteString.Lazy as L
-- >  
-- >  -- Person name, age and description
-- >  data Person = Person String Int String
-- >  
-- >  xpPerson :: Element t String String => PU t Person
-- >  xpPerson =
-- >      -- How to wrap and unwrap a Person
-- >      xpWrap (\((name, age), descr) -> Person name age descr,
-- >              \(Person name age descr) -> ((name, age), descr)) $
-- >      xpElem "person"
-- >          (xpPair
-- >              (xpAttr "name" xpText0)
-- >              (xpAttr "age" xpickle))
-- >          xpText0
-- >  
-- >  people = [
-- >      Person "Dave" 27 "A fat thin man with long short hair",
-- >      Person "Jane" 21 "Lives in a white house with green windows"]
-- >  
-- >  main = do
-- >      L.putStrLn $
-- >          formatTree stringFlavor $
-- >              pickleTree (xpElemNodes "people" $ xpList xpPerson) people
--
-- Program output:
--
-- > <?xml version="1.0" encoding="UTF-8"?>
-- > <people><person name="Dave" age="27">A fat thin man with long short hair</person>
-- > <person name="Jane" age="21">Lives in a white house with green windows</person></people>

module Text.XML.Expat.Pickle (
        -- * Primary interface
        PU(PU),
        Node(..),
        XmlPickler(..),
        unpickleTree,
        pickleTree,
        -- * Classes for abstracting parts of the tree
        Element(..),
        TextContent(..),
        -- * Pickler primitives
        xpUnit,
        xpElem,
        xpElemAttrs,
        xpElemNodes,
        xpAttr,
        xpText0,
        xpText,
        xpReadShow,
        -- * Pickler combinators
        xpPair,
        xpTriple,
        xp4Tuple,
        xp5Tuple,
        xp6Tuple,
        xpList,
        xpListMinLen,
        -- * Pickler type conversion
        xpWrap,
        xpWrapMaybe,
        xpWrapEither,
        -- * Pickler conditionals
        xpOption,
        xpAlt,
        xpTryCatch,
        xpThrow,
        xpWithDefault,
        -- * Pickler other
        xpConst,
        xpAttrs,
        xpTree,
        xpTrees,
        -- * Abstraction of string types
        GenericXMLString(..)
    ) where

import Text.XML.Expat.IO (Encoding)
import Text.XML.Expat.Tree
import Text.XML.Expat.Format
import Text.XML.Expat.Qualified
import Data.Maybe
import Data.Either
import Data.List
import Data.Char
import Data.Monoid
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.Text as T
import qualified Codec.Binary.UTF8.String as U8


-- | A two-way pickler/unpickler that pickles an arbitrary
-- data type ''a'' to a part of an XML tree ''t''.
-- A 'PU' can be composed using the pickler primitives defined in this module.
data PU t a = PU {
        -- | Convert a @t@ XML tree part into a Haskell value of type @a@, or give an
        -- unpickling error message as @Left error@.
        unpickleTree :: t -> Either String a,
        -- | Convert a Haskell value of type @a@ to a @t@ XML tree part.
        pickleTree   :: a -> t
    }

toByteString :: String -> B.ByteString
toByteString = B.pack . map (fromIntegral . ord)

-- | We build the attributes and tags lists backwards, then reverse them afterwards
-- for speed.
reverseElement :: Node tag text -> Node tag text
reverseElement (Element eName eAttrs eChildren) = Element eName (reverse eAttrs) (reverse eChildren)
reverseElement other = other

-- | An abstraction for any string type you want to use as xml text (that is,
-- attribute values or element text content). If you want to use a
-- new string type with @hexpat-pickle@, you must make it an instance of
-- 'GenericXMLString'.
class GenericXMLString s where
    gxNullString :: s -> Bool
    gxToString :: s -> String
    gxFromString :: String -> s

instance GenericXMLString String where
    gxNullString = null
    gxToString = id
    gxFromString = id

instance GenericXMLString B.ByteString where
    gxNullString = B.null
    gxToString = U8.decodeString . map w2c . B.unpack
    gxFromString = B.pack . map c2w . U8.encodeString

instance GenericXMLString T.Text where
    gxNullString = T.null
    gxToString = T.unpack
    gxFromString = T.pack

-- | Define a generic pickler for converting a Haskell data of type @a@ to/from a
-- @t@ tree part, analogous to 'Read' / 'Show'.
class XmlPickler t a where
    xpickle :: PU t a

-- | Represents the two possible parts of an XML tree that can encode text
-- content: 1. attribute values, and 2. text content of elements.
class (Monoid text, GenericXMLString text) => TextContent t text | t -> text where
    getString :: t -> text
    putString :: text -> t

instance TextContent String String where
    getString = id
    putString = id

instance TextContent B.ByteString B.ByteString where
    getString = id
    putString = id

instance TextContent T.Text T.Text where
    getString = id
    putString = id

instance (GenericXMLString text, Monoid text) => TextContent [Node tag text] text where
    getString = mconcat . map extract
        where
            extract (Element _ _ children) = getString children
            extract (Text txt) = txt
    putString txt | gxNullString txt = []
    putString txt = [Text txt]

-- | Represents an XML element in a general way.
class Show t => Element t tag text | t -> tag, t -> text where
    getElements      :: t -> [Node tag text]
    putElement       :: Node tag text -> t

instance (Show tag, Show text) => Element [Node tag text] tag text where
    getElements = id
    putElement t = [t]

instance (Show tag, Show text) => Element (Node tag text) tag text where
    getElements elt@(Element _ _ _) = [elt]
    getElements _                   = error "No nodes to be found inside tag text"
    putElement                      = id

-- | Convert XML text content \<-\> String. Handles empty strings.
xpText0 :: TextContent t text => PU t text
xpText0 = PU {
        unpickleTree = Right . getString,
        pickleTree  = putString
    }

-- | Convert XML text content \<-\> String. Empty strings result in unpickle failure (Be warned!).
xpText :: TextContent t text => PU t text
xpText = PU {
        unpickleTree = \t ->
            case getString t of
                txt | gxNullString txt -> Left "empty text"
                txt -> Right txt,
        pickleTree = putString
    }

maybeRead :: Read a => String -> Maybe a
maybeRead s = case reads s of
    [(x, "")] -> Just x
    _         -> Nothing

instance TextContent s text => XmlPickler s Int where
    xpickle = xpReadShow

instance TextContent s text => XmlPickler s Integer where
    xpickle = xpReadShow

-- | Convert XML text content \<-\> any type that implements 'Read' and 'Show'.
xpReadShow :: (TextContent s text, Read n, Show n) => PU s n
xpReadShow = PU {
            unpickleTree = \t ->
                let txt = gxToString $ getString t
                in  case maybeRead txt of
                    Just val -> Right val
                    Nothing  -> Left $ "failed to read text: "++txt,
            pickleTree = \n -> putString (gxFromString $ show n)
        }

instance (XmlPickler (Node tag text) a, Show tag, Show text) =>
         XmlPickler [Node tag text] [a] where
    xpickle = xpList xpickle

-- | Pickle @(a,b)@ to/from an XML element of the specified name, where @a@
-- is passed to a specified pickler for attributes and @b@ to a pickler for child nodes.
-- Unpickle fails if an element of this name can't be found at this point in the tree.
--
-- This implementation differs from HXT in that it unpickles elements of different
-- names in any order, while HXT's xpElem will fail if the XML order doesn't match
-- the Haskell code.
--
-- It also differs from HXT in that it takes two pickler arguments, one for attributes
-- and one for child nodes. When migrating from HXT, often you can substitute just
-- 'xpElemAttrs' or 'xpElemNodes' for HXT's 'xpElem', but where your element has both
-- attributes and child nodes, you must split your data into a 2-tuple with 'xpWrap',
-- and separate the child picklers accordingly.
xpElem :: (Eq tag, Show tag, Element t tag text) =>
          tag                  -- ^ Element name
       -> PU [(tag, text)] a   -- ^ Pickler for attributes
       -> PU [Node tag text] b -- ^ Pickler for child nodes: accepts @Element t tag text => 'PU' t a@
       -> PU t (a,b)
xpElem name puAttrs puChildren = PU {
        unpickleTree = \t ->
            let doElem elt@(Element eName attrs children) | eName == name =
                    Just $ (unpickleTree puAttrs attrs, unpickleTree puChildren children)
                doElem _ = Nothing
                mChildren = map doElem (getElements t)
            in  case catMaybes mChildren of
                    []    -> Left $ "can't find element <"++show name++">"
                    (result:_) -> case result of
                        (Right attrs, Right children) -> Right (attrs, children)
                        (Left err, _) -> Left $ "in attributes of <"++show name++">, "++err
                        (_, Left err) -> Left $ "in <"++show name++">, "++err,
        pickleTree = \(a,b) ->
            putElement $ Element name (pickleTree puAttrs a) (pickleTree puChildren b)
    }

-- | A helper variant of xpElem for elements that contain attributes but no child tags.
xpElemAttrs :: (Eq tag, Show tag, Element t tag text) =>
               tag                 -- ^ Element name
            -> PU [(tag, text)] a  -- ^ Pickler for attributes
            -> PU t a
xpElemAttrs name puAttrs = xpWrap (fst,\a -> (a,())) $ xpElem name puAttrs xpUnit

-- | A helper variant of xpElem for elements that contain child nodes but no attributes.
xpElemNodes :: (Eq tag, Show tag, Element t tag text) =>
               tag                   -- ^ Element name
            -> PU [Node tag text] a  -- ^ Pickler for child nodes: accepts @Element t tag text => 'PU' t a@
            -> PU t a
xpElemNodes name puChildren = xpWrap (snd,\a -> ((),a)) $ xpElem name xpUnit puChildren

-- | Create/parse an XML attribute of the specified name.  Fails if the attribute
-- can't be found at this point in the tree.
xpAttr :: (Eq tag, Show tag) => tag -> PU text a -> PU [(tag,text)] a
xpAttr name pu = PU {
        unpickleTree = \attrs ->
            let doAttr attr@(aName, value) | aName == name =
                    case unpickleTree pu value of
                        Right val -> Just val
                        Left _    -> Nothing
                doAttr _ = Nothing
                mAttrs = map doAttr attrs
            in  case catMaybes mAttrs of
                    val:_ -> Right val
                    []    -> Left $ "can't find attribute '"++show name++"'",
        pickleTree = \value -> [(name, pickleTree pu value)]
    }

-- | Convert XML text \<-\> a Maybe type. During unpickling, Nothing is returned
-- if there's a failure during the unpickling of the first argument.  A typical
-- example is:
--
-- > xpElemAttrs "score" $ xpOption $ xpAttr "value" xpickle
--
-- in which @Just 5@ would be encoded as @\<score value=\"5\"\/\>@ and @Nothing@ would be
-- encoded as @\<score\/\>@.
xpOption :: PU [t] a -> PU [t] (Maybe a)
xpOption pu = PU {
        unpickleTree = \t ->
            case unpickleTree pu t of
                Right val -> Right (Just val)
                Left _    -> Right Nothing,
        pickleTree = \mValue ->
            case mValue of
                Just value -> pickleTree pu value
                Nothing    -> []
    }

-- | Convert XML text \<-\> a 2-tuple using the two arguments.
xpPair :: PU [t] a -> PU [t] b -> PU [t] (a,b)
xpPair pua pub = PU {
        unpickleTree = \t ->
            case (unpickleTree pua t, unpickleTree pub t) of
                (Right a, Right b) -> Right (a,b)
                (Left err, _) -> Left $ "in 1st of pair, "++err
                (_, Left err) -> Left $ "in 2nd of pair, "++err,
        pickleTree = \(a, b) ->
            pickleTree pua a ++
            pickleTree pub b
    }

-- | Convert XML text \<-\> a 3-tuple using the three arguments.
xpTriple :: PU [t] a -> PU [t] b -> PU [t] c -> PU [t] (a,b,c)
xpTriple pua pub puc = PU {
        unpickleTree = \t ->
            case (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t) of
                (Right a, Right b, Right c) -> Right (a,b,c)
                (Left err, _, _) -> Left $ "in 1st of triple, "++err
                (_, Left err, _) -> Left $ "in 2nd of triple, "++err
                (_, _, Left err) -> Left $ "in 3rd of triple, "++err,
        pickleTree = \(a, b, c) ->
            pickleTree pua a ++
            pickleTree pub b ++
            pickleTree puc c
    }

-- | Convert XML text \<-\> a 4-tuple using the four arguments.
xp4Tuple :: PU [t] a -> PU [t] b -> PU [t] c -> PU [t] d -> PU [t] (a,b,c,d)
xp4Tuple pua pub puc pud = PU {
        unpickleTree = \t ->
            case (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t,
                  unpickleTree pud t) of
                (Right a, Right b, Right c, Right d) -> Right (a,b,c,d)
                (Left err, _, _, _) -> Left $ "in 1st of 4-tuple, "++err
                (_, Left err, _, _) -> Left $ "in 2nd of 4-tuple, "++err
                (_, _, Left err, _) -> Left $ "in 3rd of 4-tuple, "++err
                (_, _, _, Left err) -> Left $ "in 4th of 4-tuple, "++err,
        pickleTree = \(a, b, c, d) ->
            pickleTree pua a ++
            pickleTree pub b ++
            pickleTree puc c ++
            pickleTree pud d
    }

-- | Convert XML text \<-\> a 5-tuple using the five arguments.
xp5Tuple :: PU [t] a -> PU [t] b -> PU [t] c -> PU [t] d -> PU [t] e -> PU [t] (a,b,c,d,e)
xp5Tuple pua pub puc pud pue = PU {
        unpickleTree = \t ->
            case (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t,
                  unpickleTree pud t, unpickleTree pue t) of
                (Right a, Right b, Right c, Right d, Right e) -> Right (a,b,c,d,e)
                (Left err, _, _, _, _) -> Left $ "in 1st of 5-tuple, "++err
                (_, Left err, _, _, _) -> Left $ "in 2nd of 5-tuple, "++err
                (_, _, Left err, _, _) -> Left $ "in 3rd of 5-tuple, "++err
                (_, _, _, Left err, _) -> Left $ "in 4th of 5-tuple, "++err
                (_, _, _, _, Left err) -> Left $ "in 5th of 5-tuple, "++err,
        pickleTree = \(a, b, c, d, e) ->
            pickleTree pua a ++
            pickleTree pub b ++
            pickleTree puc c ++
            pickleTree pud d ++
            pickleTree pue e
    }

-- | Convert XML text \<-\> a 6-tuple using the six arguments.
xp6Tuple :: PU [t] a -> PU [t] b -> PU [t] c -> PU [t] d -> PU [t] e -> PU [t] f -> PU [t] (a,b,c,d,e,f)
xp6Tuple pua pub puc pud pue puf = PU {
        unpickleTree = \t ->
            case (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t,
                  unpickleTree pud t, unpickleTree pue t, unpickleTree puf t) of
                (Right a, Right b, Right c, Right d, Right e, Right f) -> Right (a,b,c,d,e,f)
                (Left err, _, _, _, _, _) -> Left $ "in 1st of 6-tuple, "++err
                (_, Left err, _, _, _, _) -> Left $ "in 2nd of 6-tuple, "++err
                (_, _, Left err, _, _, _) -> Left $ "in 3rd of 6-tuple, "++err
                (_, _, _, Left err, _, _) -> Left $ "in 4th of 6-tuple, "++err
                (_, _, _, _, Left err, _) -> Left $ "in 5th of 6-tuple, "++err
                (_, _, _, _, _, Left err) -> Left $ "in 6th of 6-tuple, "++err,
        pickleTree = \(a, b, c, d, e, f) ->
            pickleTree pua a ++
            pickleTree pub b ++
            pickleTree puc c ++
            pickleTree pud d ++
            pickleTree pue e ++
            pickleTree puf f
    }

-- | Convert XML text \<-\> a list of elements. During unpickling, failure of the
-- argument unpickler is the end-of-list condition (and it isn't a failure).
xpList :: (Show tag, Show text) => PU (Node tag text) a -> PU [Node tag text] [a]
xpList pu = PU {
        unpickleTree = \nodes ->
            let munge [] = []
                munge (elt@(Element _ _ _):rem) =
                    case unpickleTree pu elt of
                        Right val -> val:munge rem
                        Left _    -> []
                munge (_:rem) = munge rem  -- ignore text nodes
            in  Right $ munge nodes,
        pickleTree = map (pickleTree pu)
    }

-- | Like xpList, but only succeed during deserialization it at least a minimum number of elements are unpickled.
xpListMinLen :: (Show tag, Show text) => Int -> PU (Node tag text) a -> PU [Node tag text] [a]
xpListMinLen ml = xpWrapEither (testLength, id) . xpList
  where
    testLength as | length as < ml = Left $ "Expecting at least " ++ show ml ++ " elements"
    testLength as = Right as

-- | Apply a lens to convert the type of your data structure to/from types that
-- the pickler primitives can handle, with the /unpickle/ case first.
-- Mostly this means the tuples used by 'xpPair' and friends. A typical example is:
--
-- > xpWrap (\(name, address) -> Person name address,
-- >         \(Person name address) -> (name, address)) $ ...
xpWrap :: (a -> b, b -> a) -> PU t a -> PU t b
xpWrap (a2b, b2a) pua = PU {
        unpickleTree = \t -> case unpickleTree pua t of
            Right val -> Right (a2b val)
            Left err  -> Left err,
        pickleTree = \value -> pickleTree pua (b2a value)
    }

-- | Like xpWrap, but strips Just (and treats Nothing as a failure) during unpickling.
xpWrapMaybe :: (a -> Maybe b, b -> a) -> PU t a -> PU t b
xpWrapMaybe (a2b, b2a) pua = PU {
        unpickleTree = \t -> case unpickleTree pua t of
            Right val ->
                case a2b val of
                    Just val' -> Right val'
                    Nothing   -> Left "xpWrapMaybe can't encode Nothing value"
            Left err  -> Left err,
        pickleTree = \value -> pickleTree pua (b2a value)
    }

-- | Like xpWrap, except it strips Right (and treats Left as a failure) during unpickling.
xpWrapEither :: (a -> Either String b, b -> a) -> PU t a -> PU t b
xpWrapEither (a2b, b2a) pua = PU {
        unpickleTree = \t -> case unpickleTree pua t of
            Right val -> a2b val
            Left err  -> Left $ "xpWrapEither failed: "++err,
        pickleTree = \value -> pickleTree pua (b2a value)
    }

-- | Execute one of a list of picklers. The /selector function/ is used during pickling, and
-- the integer returned is taken as a 0-based index to select a pickler from /pickler options/.
-- Unpickling is done by trying each list element in order until one succeeds
-- (the /selector/ is not used).
--
-- This is typically used to handle each constructor of a data type. However, it
-- can be used wherever multiple serialization strategies apply to a single type.
xpAlt :: (a -> Int)  -- ^ selector function
      -> [PU t a]    -- ^ list of picklers
      -> PU t a
xpAlt selector picklers = PU {
        unpickleTree = \t ->
            let tryAll [] = Left "all xpAlt unpickles failed"
                tryAll (x:xs) =
                    case unpickleTree x t of
                        Right val -> Right val
                        Left err  -> tryAll xs
            in  tryAll picklers,
        pickleTree = \value -> pickleTree (picklers !! (selector value)) value
    }

-- | Convert nothing \<-\> (). Does not output or consume any XML text. 
xpUnit :: PU [t] ()
xpUnit = xpConst ()

-- | Convert nothing \<-\> constant value. Does not output or consume any XML text.
xpConst :: a -> PU [t] a
xpConst a = PU
  { unpickleTree = const $ Right a
  , pickleTree = const []
  }

-- | Pickler that during pickling always uses the first pickler, and during
-- unpickling tries the first, and on failure then tries the second.
xpTryCatch :: PU t a -> PU t a -> PU t a
xpTryCatch pu1 pu2 = PU
  { unpickleTree = \t -> case unpickleTree pu1 t of
             Right val1 -> Right val1
             Left  err1 -> case unpickleTree pu2 t of
                 Right val2 -> Right val2
                 Left  err2 -> Left $ "Both xpTryCatch picklers failed: <" ++ err1 ++ "> <" ++ err2 ++ ">"
  , pickleTree = pickleTree pu1
  }

-- | No output when pickling, always generates an error with the specified message on unpickling.
xpThrow :: String    -- ^ Error message
        -> PU [t] a
xpThrow msg = PU
  { unpickleTree = \t -> Left msg
  , pickleTree = const []
  }

-- | Attempt to use a pickler. On failure, return a default value.
xpWithDefault :: a -> PU [t] a -> PU [t] a
xpWithDefault a pa = xpTryCatch pa (xpConst a)

-- | Insert/extract an attribute list literally in the xml stream.
xpAttrs :: PU [(tag, text)] [(tag, text)]
xpAttrs = PU {
        unpickleTree = Right,
        pickleTree  = id
    }

-- | Insert/extract a tree node literally in the xml stream.
xpTree :: Element t tag text => PU t (Node tag text)
xpTree = PU {
        unpickleTree = \t -> case getElements t of
            [elt]     -> Right elt
            otherwise -> Left "xpLiteral expects a single node",
        pickleTree = putElement
    }

-- | Insert/extract a list of tree nodes literally in the xml stream.
xpTrees :: PU [Node tag text] [Node tag text]
xpTrees = PU {
        unpickleTree = Right,
        pickleTree = id
    }