module Text.XML.Expat.Pickle (
PU(..),
Node(..),
XmlPickler(..),
UnpickleException(..),
unpickleXML,
unpickleXML',
pickleXML,
pickleXML',
UNode,
QNode,
Nodes,
UNodes,
QNodes,
Attributes,
UAttributes,
QAttributes,
xpRoot,
xpContent,
xpUnit,
xpZero,
xpLift,
xpElem,
xpElemAttrs,
xpElemNodes,
xpAttr,
xpAttrImplied,
xpAttrFixed,
xpAddFixedAttr,
xpText0,
xpText,
xpPrim,
xpPair,
xpTriple,
xp4Tuple,
xp5Tuple,
xp6Tuple,
xpList0,
xpList,
xpListMinLen,
xpMap,
xpWrap,
xpWrapMaybe,
xpWrapMaybe_,
xpWrapEither,
xpOption,
xpDefault,
xpWithDefault,
xpAlt,
xpTryCatch,
xpThrow,
xpAttrs,
xpTree,
xpTrees,
GenericXMLString(..) --re-exported
) where
import Text.XML.Expat.IO (Encoding)
import Text.XML.Expat.Tree
import Text.XML.Expat.Format
import Text.XML.Expat.Qualified
import Text.XML.Expat.Namespaced
import Control.Exception.Extensible
import Data.Maybe
import Data.Either
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
data PU t a = PU {
unpickleTree :: t -> a,
unpickleTree' :: t -> Either String a,
pickleTree :: a -> t
}
data UnpickleException = UnpickleException String
deriving (Eq, Show, Typeable)
instance Exception UnpickleException where
pickleXML :: (GenericXMLString tag, GenericXMLString text) =>
PU (Node tag text) a
-> a
-> BL.ByteString
pickleXML pu value = formatTree $ pickleTree pu value
pickleXML' :: (GenericXMLString tag, GenericXMLString text) =>
PU (Node tag text) a
-> a
-> B.ByteString
pickleXML' pu value = formatTree' $ pickleTree pu value
unpickleXML :: (GenericXMLString tag, GenericXMLString text) =>
Maybe Encoding
-> PU (Node tag text) a
-> BL.ByteString
-> a
unpickleXML mEnc pu =
unpickleTree pu . parseTreeThrowing mEnc
unpickleXML' :: (GenericXMLString tag, GenericXMLString text) =>
Maybe Encoding
-> PU (Node tag text) a
-> B.ByteString
-> Either String a
unpickleXML' mEnc pu xml =
case parseTree' mEnc xml of
Right tree -> unpickleTree' pu tree
Left err -> Left $ show err
toByteString :: String -> B.ByteString
toByteString = B.pack . map (fromIntegral . ord)
class XmlPickler t a where
xpickle :: PU t a
xpRoot ::PU (Nodes 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"
}
xpContent :: GenericXMLString text => PU text a -> PU (Nodes 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
xpText0 :: PU text text
xpText0 = PU {
unpickleTree = id,
unpickleTree' = Right,
pickleTree = id
}
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
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
throwify f t = case f t of
Right val -> val
Left err -> throw $ UnpickleException err
showUnquoted :: Show tag => tag -> String
showUnquoted tag = case (maybeRead tag') of
Just str -> str
Nothing -> tag'
where
tag' = show tag
xpElem :: (Eq tag, Show tag) =>
tag
-> PU [(tag, text)] a
-> PU (Nodes tag text) b
-> PU (Nodes 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)]
}
xpElemAttrs :: (Eq tag, Show tag) =>
tag
-> PU (Attributes tag text) a
-> PU (Nodes tag text) a
xpElemAttrs name puAttrs = xpWrap (fst,\a -> (a,())) $ xpElem name puAttrs xpUnit
xpElemNodes :: (Eq tag, Show tag) =>
tag
-> PU (Nodes tag text) a
-> PU (Nodes tag text) a
xpElemNodes name puChildren = xpWrap (snd,\a -> ((),a)) $ xpElem name xpUnit puChildren
xpAttr :: (Eq tag, Show tag) => tag -> PU text a -> PU (Attributes tag text) a
xpAttr name pu = PU {
unpickleTree = throwify doUnpickle,
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
xpAttrImplied :: (Eq tag, Show tag) => tag -> PU text a -> PU (Attributes tag text) (Maybe a)
xpAttrImplied name pa = xpOption $ xpAttr name pa
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
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
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
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
xpWithDefault :: a -> PU [t] a -> PU [t] a
xpWithDefault a pa = xpTryCatch pa (xpLift a)
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
}
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
}
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
}
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
}
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
xpList :: Show tag => PU (Nodes tag text) a -> PU (Nodes 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
xpList0 :: Show tag => PU (Nodes tag text) a -> PU (Nodes tag text) [a]
xpList0 pu = PU {
unpickleTree = \nodes ->
let munge [] = []
munge (elt@(Element _ _ _):rem) =
unpickleTree pu [elt]:munge rem
munge (_:rem) = munge rem
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
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
}
xpListMinLen :: Show tag => Int -> PU (Nodes tag text) a -> PU (Nodes 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
xpMap :: (Eq tag, Show tag, Ord k) =>
tag
-> tag
-> PU text k
-> PU (Nodes tag text) v
-> PU (Nodes tag text) (M.Map k v)
xpMap en an xpk xpv
= xpWrap ( M.fromList
, M.toList
) $
xpList $
xpElem en
(xpAttr an xpk)
xpv
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)
}
xpWrapMaybe :: (a -> Maybe b, b -> a) -> PU t a -> PU t b
xpWrapMaybe = xpWrapMaybe_ "xpWrapMaybe can't encode 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)
}
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)
}
xpAlt :: (a -> Int)
-> [PU t a]
-> 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
xpUnit :: PU [t] ()
xpUnit = xpLift ()
xpLift :: a -> PU [t] a
xpLift a = PU
{ unpickleTree = const a
, unpickleTree' = const $ Right a
, pickleTree = const []
}
xpLiftMaybe :: Maybe a -> PU [t] a
xpLiftMaybe Nothing = xpZero
xpLiftMaybe (Just x) = xpLift x
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
}
xpZero :: PU [t] a
xpZero = xpThrow "got xpZero"
xpThrow :: String
-> PU [t] a
xpThrow msg = PU
{ unpickleTree = \t -> throw $ UnpickleException $ msg
, unpickleTree' = \t -> Left msg
, pickleTree = const []
}
xpAttrs :: PU [(tag, text)] [(tag, text)]
xpAttrs = PU {
unpickleTree = id,
unpickleTree' = Right,
pickleTree = id
}
xpTree :: PU (Nodes 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]
}
xpTrees :: PU [Node tag text] [Node tag text]
xpTrees = PU {
unpickleTree = id,
unpickleTree' = Right,
pickleTree = id
}