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

-- | /hexpat-pickle/ provides XML picklers that plug into the parse tree of the
-- /hexpat/ package, giving XML serialization with excellent performance.
-- Picklers 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.
--
--  * Two type adapters (absent in /HXT/), 'xpRoot' and 'xpContent' are needed in certain
--        places.  See below.
--
--  * These /HXT/ picklers are missing: @xpCondSeq@, @xpSeq@, @xpChoice@, @xpList1@
--        ('xpListMinLen' may be substituted), @xpElemWithAttrValue@
--
-- 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 /three/ possible values. These are the
-- most general types, and your picklers should not use any other types for @t@.
-- Here they are, assuming we are using the /String/ type for our strings:
--
--  * @'PU' ['Node' String String] a@ /(for working with an XML element)/
--
--  * @'PU' String a@ /(for working with text content)/
--
--  * @'PU' ('Attributes' String String) a@ /(for working with attributes)/
--
-- The reason why you a list of 'Node' instead of just one when working with a single
-- element is because the unpickler of 'xpElem' needs to see the whole list of nodes
-- so that it can 1. skip whitespace, and 2. search to match the specified tag name.
--
-- The top level of the document does not follow this rule, because it is a single
-- 'Node' type.  'xpRoot' is needed to adapt this to type ['Node'] for your
-- pickler to use.  You would typically define a pickler for a whole document with
-- 'xpElem', then pickle it to a single 'Node' with @'pickleTree' (xpRoot myDocPickler) value@.
--
-- The type for /text content/ works for attribute values directly, but if you want
-- to use it as the text content of an element, you need to adapt it by wrapping with
-- 'xpContent'.
--
-- /hexpat-pickle/ can work with the following string types:
--
--  * String
--
--  * Data.ByteString
--
--  * Data.Text
--
-- and it is extensible to any other string type by making it an instance of
-- 'GenericXMLString'.  We select the type for XML /tag/ and /text/ separately
-- in our four \"tree part\" types as follows:
--
--  * @'PU' [Node tag text] a@ /(for working with an XML element)/
--
--  * @'PU' text a@ /(for working with text content)/
--
--  * @'PU' (Attributes tag text) a@ /(for working with attributes)/
--
-- /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 /Text.XML.Expat.Tree/ and /Text.XML.Expat.Qualified/ provide the follow
-- useful shortcuts for common cases of 'Node' and 'Attributes':
--
--  * 'UNode', 'UAttributes', 'QNode', 'QAttributes'.
--
-- The type class 'XmlPickler' is used to extend a polymorphic 'xpickle' function
-- to provide a pickler for a new type, in a similar way to 'Read' and 'Show'.
--
-- Here is a simple and complete example to get you started:
--
-- > import Text.XML.Expat.Pickle
-- > import Text.XML.Expat.Tree
-- > import qualified Data.ByteString.Lazy as L
-- > 
-- > -- Person name, age and description
-- > data Person = Person String Int String
-- > 
-- > xpPerson :: PU [UNode String] 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))
-- >         (xpContent 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 $
-- >         pickleXML (xpRoot $ 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(..),
        Node(..),
        XmlPickler(..),
        UnpickleException(..),
        unpickleXML,
        unpickleXML',
        pickleXML,
        pickleXML',
        -- * Re-exported types
        UNode,
        QNode,
        NNode,
        Attributes,
        UAttributes,
        QAttributes,
        NAttributes,
        ParseOptions(..),
        defaultParseOptions,
        -- * Pickler adapters
        xpRoot,
        xpContent,
        -- * Pickler primitives
        xpUnit,
        xpZero,
        xpLift,
        xpElem,
        xpElemAttrs,
        xpElemNodes,
        xpAttr,
        xpAttrImplied,
        xpAttrFixed,
        xpAddFixedAttr,
        xpText0,
        xpText,
        xpPrim,
        -- * Pickler combinators
        xpPair,
        xpTriple,
        xp4Tuple,
        xp5Tuple,
        xp6Tuple,
        xpList0,
        xpList,
        xpListMinLen,
        xpMap,
        -- * Pickler type conversion
        xpWrap,
        xpWrapMaybe,
        xpWrapMaybe_,
        xpWrapEither,
        -- * Pickler conditionals
        xpOption,
        xpDefault,
        xpWithDefault,
        xpAlt,
        xpTryCatch,
        xpThrow,
        -- * Pickler other
        xpAttrs,
        xpTree,
        xpTrees,
        GenericXMLString(..) --re-exported
    ) where

import Text.XML.Expat.Tree
import Text.XML.Expat.Format
import Control.Exception.Extensible
import Data.Maybe
import Data.List
import Data.Char
import Data.Monoid
import Data.Typeable
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
import qualified Data.Map as M


-- | 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.
--
-- /unpickleTree/, /unpickleTree'/ and /pickleTree/ should be used directly by
-- the caller.
data PU t a = PU {
        -- | Lazily convert a @t@ XML tree part into a Haskell value of type @a@.
        -- In the event of an error, it throws 'UnpickleException'.
        unpickleTree  :: t -> a,
        -- | strictly 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
    }

-- | An exception indicating an error during unpickling, using by the lazy variants.
data UnpickleException = UnpickleException String
    deriving (Eq, Show, Typeable)

instance Exception UnpickleException where

-- | A helper that combines 'pickleTree' with 'formatXML' to pickle to an
-- XML document. Lazy variant returning lazy ByteString.
pickleXML :: (GenericXMLString tag, GenericXMLString text) =>
             PU (Node tag text) a
          -> a
          -> BL.ByteString 
pickleXML pu value = format $ pickleTree pu value

-- | A helper that combines 'pickleTree' with 'formatXML' to pickle to an
-- XML document. Strict variant returning strict ByteString.
pickleXML' :: (GenericXMLString tag, GenericXMLString text) =>
              PU (Node tag text) a
           -> a
           -> B.ByteString 
pickleXML' pu value = format' $ pickleTree pu value

-- | A helper that combines 'parseXML' with 'unpickleTree' to unpickle from an
-- XML document - lazy version.   In the event of an error, it throws either
-- 'Text.XML.Expat.Tree.XMLParseException' or 'UnpickleException'.
unpickleXML :: (GenericXMLString tag, GenericXMLString text) =>
               ParseOptions tag text
            -> PU (Node tag text) a
            -> BL.ByteString
            -> a
unpickleXML options pu =
    unpickleTree pu . parseThrowing options

-- | A helper that combines 'parseXML' with 'unpickleTree' to unpickle from an
-- XML document - strict version.
unpickleXML' :: (GenericXMLString tag, GenericXMLString text) =>
                ParseOptions tag text
             -> PU (Node tag text) a
             -> B.ByteString
             -> Either String a
unpickleXML' options pu xml =
    case parse' options xml of
        Right tree -> unpickleTree' pu tree
        Left err   -> Left $ show err

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

-- | Define a generalized 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

-- | Adapts a list of nodes to a single node. Generally used at the top level of
-- an XML document.
xpRoot ::PU [Node tag text] a -> PU (Node tag text) a
xpRoot pa = PU {
       unpickleTree  = \t -> unpickleTree pa [t],
       unpickleTree' = \t -> unpickleTree' pa [t],
       pickleTree = \t -> case pickleTree pa t of
           [t1] -> t1
           _    -> error "pickler called by xpRoot must output only one element"
   }

-- | If you have a pickler that works with /text/, and you want to use it as
-- text content of an XML element, you need to wrap it with /xpContent/.  See the
-- example at the top.
xpContent :: GenericXMLString text => PU text a -> PU [Node tag text] a
xpContent tp = PU {
        unpickleTree  = \t -> unpickleTree tp $ mconcat $ map extract t,
        unpickleTree' = \t -> unpickleTree' tp $ mconcat $ map extract t,
        pickleTree = \t ->
            let txt = pickleTree tp t
            in  if gxNullString txt then [] else [Text txt]
    }
    where
        extract (Element _ _ children) = mconcat $ map extract children
        extract (Text txt) = txt

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

-- | Convert XML text content \<-\> String. Empty strings result in unpickle failure (Be warned!).
xpText :: GenericXMLString text => PU text text
xpText = PU {
        unpickleTree = \t ->
            if gxNullString t
                then throw $ UnpickleException "empty text"
                else t,
        unpickleTree' = \t ->
            if gxNullString t
                then Left "empty text"
                else Right t,
        pickleTree = id
    }

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

instance GenericXMLString text => XmlPickler text Int where
    xpickle = xpPrim

instance GenericXMLString text => XmlPickler text Integer where
    xpickle = xpPrim

-- | Convert XML text content \<-\> any type that implements 'Read' and 'Show'.
-- Fails on unpickle if 'read' fails.
xpPrim :: (Read n, Show n, GenericXMLString text) => PU text n
xpPrim = PU {
        unpickleTree = throwify doUnpickle,
        unpickleTree' = doUnpickle,
        pickleTree = \n -> gxFromString $ show n
    }
  where
    doUnpickle t =
        let txt = gxToString t
        in  case maybeRead txt of
            Just val -> Right val
            Nothing  -> Left $ "failed to read text: "++txt

throwify :: (t -> Either String a) -> t -> a
{-# INLINE throwify #-}
throwify f t = case f t of
    Right val -> val
    Left err -> throw $ UnpickleException err

-- This is a roundabout way of converting a tag name into a String.
showUnquoted :: Show tag => tag -> String
showUnquoted tag = case (maybeRead tag') of
    Just str -> str
    Nothing  -> tag'
  where
    tag' = show tag

-- | 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) =>
          tag                   -- ^ Element name
       -> PU [(tag, text)] a    -- ^ Pickler for attributes
       -> PU [Node tag text] b -- ^ Pickler for child nodes
       -> PU [Node tag text] (a,b)
xpElem name puAttrs puChildren = PU {
        unpickleTree = \t ->
            let doElem elt@(Element eName attrs children) | eName == name =
                    Just $ (unpickleTree puAttrs attrs, unpickleTree puChildren children)
                doElem _ = Nothing
                mChildren = map doElem t
            in  case catMaybes mChildren of
                    []    -> throw $ UnpickleException $ "can't find <"++showUnquoted name++">"
                    (result:_) -> result,
        unpickleTree' = \t ->
            let doElem elt@(Element eName attrs children) | eName == name =
                    Just $ (unpickleTree' puAttrs attrs, unpickleTree' puChildren children)
                doElem _ = Nothing
                mChildren = map doElem t
            in  case catMaybes mChildren of
                    []    -> Left $ "can't find <"++showUnquoted name++">"
                    (result:_) -> case result of
                        (Right attrs, Right children) -> Right (attrs, children)
                        (Left err, _) -> Left $ "in <"++showUnquoted name++">, "++err
                        (_, Left err) -> Left $ "in <"++showUnquoted name++">, "++err,    
        pickleTree = \(a,b) ->
            [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) =>
               tag                 -- ^ Element name
            -> PU (Attributes tag text) a  -- ^ Pickler for attributes
            -> PU [Node tag text] a
xpElemAttrs name puAttrs = xpWrap (fst,\a -> (a,())) $ xpElem name puAttrs xpUnit

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

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

-- | Optionally add an attribute, unwrapping a Maybe value.
xpAttrImplied :: (Eq tag, Show tag) => tag -> PU text a -> PU (Attributes tag text) (Maybe a)
xpAttrImplied name pa = xpOption $ xpAttr name pa

-- | Pickle an attribute with the specified name and value, fail if the same attribute is
-- not present on unpickle.
xpAttrFixed :: (Eq tag, Show tag, GenericXMLString text) => tag -> text -> PU (Attributes tag text) ()
xpAttrFixed name val =
    xpWrapMaybe_ ("expected fixed attribute "++showUnquoted name++"="++show (gxToString val))
                (\v -> if v == val then Just () else Nothing, const val) $
    xpAttr name xpText

-- | Add an attribute with a fixed value.
--
-- Useful e.g. to declare namespaces. Is implemented by 'xpAttrFixed'
xpAddFixedAttr :: (Eq tag, Show tag, GenericXMLString text) =>
                  tag
               -> text
               -> PU (Attributes tag text) a
               -> PU (Attributes tag text) a
xpAddFixedAttr name val pa
    = xpWrap ( snd
	     , (,) ()
	     ) $
      xpPair (xpAttrFixed name val) pa

-- | 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\/\>@.
--
-- Note on lazy unpickle: The argument is evaluated strictly.
xpOption :: PU [t] a -> PU [t] (Maybe a)
xpOption pu = PU {
        unpickleTree = doUnpickle,
        unpickleTree' = Right . doUnpickle,
        pickleTree = \mValue ->
            case mValue of
                Just value -> pickleTree pu value
                Nothing    -> []
    }
  where
    doUnpickle t =
        case unpickleTree' pu t of
            Right val -> (Just val)
            Left _    -> Nothing

-- | Optional conversion with default value
--
-- Unlike 'xpWithDefault' the default value is not encoded in the XML document,
-- during unpickling the default value is inserted if the pickler fails
--
-- Note on lazy unpickle: The child is evaluated strictly.
xpDefault :: (Eq a) => a -> PU [t] a -> PU [t] a
xpDefault df
    = xpWrap ( fromMaybe df
	     , \ x -> if x == df then Nothing else Just x
	     ) .
      xpOption

-- | Attempt to use a pickler. On failure, return a default value.
--
-- Unlike 'xpDefault', the default value /is/ encoded in the XML document.
--
-- Note on lazy unpickle: The child is evaluated strictly.
xpWithDefault :: a -> PU t a -> PU t a
xpWithDefault a pa = xpTryCatch pa (lift a)
  where
    -- use this instead of standard xpLift, allowing us to use a more general tree type
    lift a = PU
      { unpickleTree = const a
      , unpickleTree' = const $ Right a
      , pickleTree = error "xpWithDefault impossible" -- xpTryCatch never runs the second pickler
      }

-- | 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 -> (unpickleTree pua t, unpickleTree pub t),
        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 -> (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t),
        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 -> (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t,
                  unpickleTree pud t),
        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 -> (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t,
                  unpickleTree pud t, unpickleTree pue t),
        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 -> (unpickleTree pua t, unpickleTree pub t, unpickleTree puc t,
                  unpickleTree pud t, unpickleTree pue t, unpickleTree puf t),
        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
    }

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

-- | 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).
--
-- Note on lazy unpickle: Because we're using a failure to pickle a child as
-- the end condition it means we're only lazy at the top-level xpList. Children
-- of xpList are evaluated strictly. Use 'xpList0' to fix this.
xpList :: Show tag => PU [Node tag text] a -> PU [Node tag text] [a]
xpList pu = PU {
        unpickleTree = doUnpickle,
        unpickleTree' = Right . doUnpickle, 
        pickleTree = \t -> mconcat $ map (pickleTree pu) t
    }
  where
    doUnpickle [] = []
    doUnpickle (elt@(Element _ _ _):rem) =
                case unpickleTree' pu [elt] of
                    Right val -> val:doUnpickle rem
                    Left _    -> []
    doUnpickle (_:rem) = doUnpickle rem  -- ignore text nodes

-- | Convert XML text \<-\> a list of elements. Unlike 'xpList', this function
-- uses /no more elements/ as the end of list condition, which means it can
-- evaluate its children lazily.
--
-- Any error in a child will cause an error to be reported.
xpList0 :: Show tag => PU [Node tag text] a -> PU [Node tag text] [a]
xpList0 pu = PU {
        unpickleTree = \nodes ->
            let munge [] = []
                munge (elt@(Element _ _ _):rem) =
                    unpickleTree pu [elt]:munge rem
                munge (_:rem) = munge rem  -- ignore text nodes
            in  munge nodes,
        unpickleTree' = \nodes ->
            let munge [] = []
                munge (elt@(Element _ _ _):rem) =
                    case unpickleTree' pu [elt] of
                        Right val -> Right val:munge rem
                        Left err  -> [Left $ "in list, "++err]
                munge (_:rem) = munge rem  -- ignore text nodes
                m = munge nodes
            in  case m of
                    [] -> Right []
                    otherwise ->
                        case last m of
                                Left err -> Left err
                                Right _ -> Right $ rights m,
        pickleTree = \t -> mconcat $ map (pickleTree pu) t
    }
  where
    rights x = [a | Right a <- x]  -- In Data.Either in base 4.x, but doesn't exist in base 3.x

-- | Like xpList, but only succeed during deserialization if at least a minimum number of elements are unpickled.
xpListMinLen :: Show tag => Int -> PU [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

-- | Standard pickler for maps
--
-- This pickler converts a map into a list of pairs of the form
--
-- > <elt attr="key">value</elt>
xpMap :: (Eq tag, Show tag, Ord k) =>
         tag                   -- ^ Element name (elt) 
      -> tag                   -- ^ Attribute name (attr)
      -> PU text k             -- ^ Pickler for keys (key)
      -> PU [Node tag text] v -- ^ Pickler for values (value)
      -> PU [Node tag text] (M.Map k v)
xpMap en an xpk xpv
    = xpWrap ( M.fromList
	     , M.toList
	     ) $
      xpList $
      xpElem en
          (xpAttr an xpk)
          xpv

-- | 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 -> a2b $ unpickleTree pua t,
        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 = xpWrapMaybe_ "xpWrapMaybe can't encode Nothing value"

-- | Like xpWrap, but strips Just (and treats Nothing as a failure) during unpickling,
-- with specified error message for Nothing value.
xpWrapMaybe_ :: String -> (a -> Maybe b, b -> a) -> PU t a -> PU t b
xpWrapMaybe_ errorMsg (a2b, b2a) pua = PU {
        unpickleTree = \t ->
            case a2b $ unpickleTree pua t of
                Just val' -> val'
                Nothing   -> throw $ UnpickleException errorMsg,
        unpickleTree' = \t -> case unpickleTree' pua t of
            Right val ->
                case a2b val of
                    Just val' -> Right val'
                    Nothing   -> Left errorMsg
            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 a2b $ unpickleTree pua t of
            Right val -> val
            Left err  -> throw $ UnpickleException $ "xpWrapEither failed: "++err,
        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.
--
-- Note on lazy unpickle: Because we're using a failure to pickle a child as
-- the end condition it means children of xpAlt are evaluated strictly.
xpAlt :: (a -> Int)  -- ^ selector function
      -> [PU t a]    -- ^ list of picklers
      -> PU t a
xpAlt selector picklers = PU {
        unpickleTree = throwify doUnpickle,
        unpickleTree' = doUnpickle,
        pickleTree = \value -> pickleTree (picklers !! (selector value)) value
    }
  where
    doUnpickle 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

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

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

-- | 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 [t] a
xpLiftMaybe Nothing = xpZero
xpLiftMaybe (Just x) = xpLift x

-- | Pickler that during pickling always uses the first pickler, and during
-- unpickling tries the first, and on failure then tries the second.
--
-- Note on lazy unpickle: The first argument is evaluated strictly.
xpTryCatch :: PU t a -> PU t a -> PU t a
xpTryCatch pu1 pu2 = PU
  { unpickleTree = \t -> case unpickleTree' pu1 t of
             Right val1 -> val1
             Left  err1 -> unpickleTree pu2 t
  , 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
  }

-- | The zero pickler
--
-- Encodes nothing, fails always during unpickling. (Same as @'xpThrow' \"got xpZero\"@).
xpZero :: PU [t] a
xpZero = xpThrow "got xpZero"

-- | 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 -> throw $ UnpickleException $ msg
  , unpickleTree' = \t -> Left msg
  , pickleTree = const []
  }

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

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

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

{-
-- | Insert a namespace binding, along with other attributes.
xpNamespaceBinding :: (GenericXMLString text)
                   => [(text, text)] -> PU (NAttributes text) a -> PU (NAttributes text) a
xpNamespaceBinding ups pa =
  xpWrap (\(nsb, a) -> a, \a -> (nsb, a)) $ xpPair xpAttrs pa
    where
      nsb = map (\(uri, prefix) -> (mkNName xmlnsUri prefix, uri)) ups

-- | Insert a default namespace binding, along with other attributes.
xpDefaultNamespace :: (GenericXMLString text)
                   => text -> PU (NAttributes text) a -> PU (NAttributes text) a
xpDefaultNamespace uri pa =
  xpWrap (\(nsb, a) -> a, \a -> (nsb, a)) $ xpPair xpAttrs pa
    where
      nsb = [(mkAnNName xmlns, uri)]
-}