module Text.XML.HXT.Arrow.Pickle.Xml
where
import Control.Arrow.ListArrows
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as M
import Text.XML.HXT.DOM.Interface
import qualified Text.XML.HXT.DOM.XmlNode as XN
import Text.XML.HXT.Arrow.Edit (xshowEscapeXml)
import Text.XML.HXT.Arrow.Pickle.Schema
import Text.XML.HXT.Arrow.ReadDocument (xread)
import Text.XML.HXT.Arrow.WriteDocument (writeDocumentToString)
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlState
data St = St { attributes :: [XmlTree]
, contents :: [XmlTree]
}
data PU a = PU { appPickle :: (a, St) -> St
, appUnPickle :: St -> (Maybe a, St)
, theSchema :: Schema
}
emptySt :: St
emptySt = St { attributes = []
, contents = []
}
addAtt :: XmlTree -> St -> St
addAtt x s = s {attributes = x : attributes s}
addCont :: XmlTree -> St -> St
addCont x s = s {contents = x : contents s}
dropCont :: St -> St
dropCont s = s { contents = drop 1 (contents s) }
getAtt :: QName -> St -> Maybe XmlTree
getAtt qn s
= listToMaybe $
runLA ( arrL attributes
>>>
isAttr >>> hasQName qn
) s
getCont :: St -> Maybe XmlTree
getCont s = listToMaybe . contents $ s
pickleDoc :: PU a -> a -> XmlTree
pickleDoc p v
= XN.mkRoot (attributes st) (contents st)
where
st = appPickle p (v, emptySt)
unpickleDoc :: PU a -> XmlTree -> Maybe a
unpickleDoc p t
| XN.isRoot t
= fst . appUnPickle p $ St { attributes = fromJust . XN.getAttrl $ t
, contents = XN.getChildren t
}
| otherwise
= unpickleDoc p (XN.mkRoot [] [t])
showPickled :: (XmlPickler a) => SysConfigList -> a -> String
showPickled a = concat . (pickleDoc xpickle >>> runLA (writeDocumentToString a))
xpZero :: PU a
xpZero = PU { appPickle = snd
, appUnPickle = \ s -> (Nothing, s)
, theSchema = scNull
}
xpUnit :: PU ()
xpUnit = xpLift ()
xpLift :: a -> PU a
xpLift x = PU { appPickle = snd
, appUnPickle = \ s -> (Just x, s)
, theSchema = scEmpty
}
xpLiftMaybe :: Maybe a -> PU a
xpLiftMaybe v = (xpLiftMaybe' v) { theSchema = scOption scEmpty }
where
xpLiftMaybe' Nothing = xpZero
xpLiftMaybe' (Just x) = xpLift x
xpCondSeq :: PU b -> (b -> a) -> PU a -> (a -> PU b) -> PU b
xpCondSeq pd f pa k
= PU { appPickle = ( \ (b, s) ->
let
a = f b
pb = k a
in
appPickle pa (a, (appPickle pb (b, s)))
)
, appUnPickle = ( \ s ->
let
(a, s') = appUnPickle pa s
in
case a of
Nothing -> appUnPickle pd s
Just a' -> appUnPickle (k a') s'
)
, theSchema = undefined
}
xpSeq :: (b -> a) -> PU a -> (a -> PU b) -> PU b
xpSeq = xpCondSeq xpZero
xpChoice :: PU b -> PU a -> (a -> PU b) -> PU b
xpChoice pb = xpCondSeq pb undefined
xpWrap :: (a -> b, b -> a) -> PU a -> PU b
xpWrap (i, j) pa = (xpSeq j pa (xpLift . i)) { theSchema = theSchema pa }
xpWrapMaybe :: (a -> Maybe b, b -> a) -> PU a -> PU b
xpWrapMaybe (i, j) pa = (xpSeq j pa (xpLiftMaybe . i)) { theSchema = theSchema pa }
xpPair :: PU a -> PU b -> PU (a, b)
xpPair pa pb
= ( xpSeq fst pa (\ a ->
xpSeq snd pb (\ b ->
xpLift (a,b)))
) { theSchema = scSeq (theSchema pa) (theSchema pb) }
xpTriple :: PU a -> PU b -> PU c -> PU (a, b, c)
xpTriple pa pb pc
= xpWrap (toTriple, fromTriple) (xpPair pa (xpPair pb pc))
where
toTriple ~(a, ~(b, c)) = (a, b, c )
fromTriple ~(a, b, c ) = (a, (b, c))
xp4Tuple :: PU a -> PU b -> PU c -> PU d -> PU (a, b, c, d)
xp4Tuple pa pb pc pd
= xpWrap (toQuad, fromQuad) (xpPair pa (xpPair pb (xpPair pc pd)))
where
toQuad ~(a, ~(b, ~(c, d))) = (a, b, c, d )
fromQuad ~(a, b, c, d ) = (a, (b, (c, d)))
xp5Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU (a, b, c, d, e)
xp5Tuple pa pb pc pd pe
= xpWrap (toQuint, fromQuint) (xpPair pa (xpPair pb (xpPair pc (xpPair pd pe))))
where
toQuint ~(a, ~(b, ~(c, ~(d, e)))) = (a, b, c, d, e )
fromQuint ~(a, b, c, d, e ) = (a, (b, (c, (d, e))))
xp6Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU f -> PU (a, b, c, d, e, f)
xp6Tuple pa pb pc pd pe pf
= xpWrap (toSix, fromSix) (xpPair pa (xpPair pb (xpPair pc (xpPair pd (xpPair pe pf)))))
where
toSix ~(a, ~(b, ~(c, ~(d, ~(e, f))))) = (a, b, c, d, e, f )
fromSix ~(a, b, c, d, e, f) = (a, (b, (c, (d, (e, f)))))
xp7Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU (a, b, c, d, e, f, g)
xp7Tuple a b c d e f g
= xpWrap ( \ (a, (b, c, d, e, f, g)) -> (a, b, c, d, e, f, g)
, \ (a, b, c, d, e, f, g) -> (a, (b, c, d, e, f, g))
)
(xpPair a (xp6Tuple b c d e f g))
xp8Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU (a, b, c, d, e, f, g, h)
xp8Tuple a b c d e f g h
= xpWrap ( \ ((a, b), (c, d, e, f, g, h)) -> (a, b, c, d, e, f, g, h)
, \ (a, b, c, d, e, f, g, h) -> ((a, b), (c, d, e, f, g, h))
)
(xpPair (xpPair a b) (xp6Tuple c d e f g h))
xp9Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU (a, b, c, d, e, f, g, h, i)
xp9Tuple a b c d e f g h i
= xpWrap ( \ ((a, b, c), (d, e, f, g, h, i)) -> (a, b, c, d, e, f, g, h, i)
, \ (a, b, c, d, e, f, g, h, i) -> ((a, b, c), (d, e, f, g, h, i))
)
(xpPair (xpTriple a b c) (xp6Tuple d e f g h i))
xp10Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU j ->
PU (a, b, c, d, e, f, g, h, i, j)
xp10Tuple a b c d e f g h i j
= xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j)) -> (a, b, c, d, e, f, g, h, i, j)
, \ (a, b, c, d, e, f, g, h, i, j) -> ((a, b, c, d), (e, f, g, h, i, j))
)
(xpPair (xp4Tuple a b c d) (xp6Tuple e f g h i j))
xp11Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU j ->
PU k -> PU (a, b, c, d, e, f, g, h, i, j, k)
xp11Tuple a b c d e f g h i j k
= xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k)) -> (a, b, c, d, e, f, g, h, i, j, k)
, \ (a, b, c, d, e, f, g, h, i, j, k) -> ((a, b, c, d, e), (f, g, h, i, j, k))
)
(xpPair (xp5Tuple a b c d e) (xp6Tuple f g h i j k))
xp12Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU j ->
PU k -> PU l -> PU (a, b, c, d, e, f, g, h, i, j, k, l)
xp12Tuple a b c d e f g h i j k l
= xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l)) -> (a, b, c, d, e, f, g, h, i, j, k, l)
, \ (a, b, c, d, e, f, g, h, i, j, k, l) -> ((a, b, c, d, e, f), (g, h, i, j, k, l))
)
(xpPair (xp6Tuple a b c d e f) (xp6Tuple g h i j k l))
xp13Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU j ->
PU k -> PU l -> PU m -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m)
xp13Tuple a b c d e f g h i j k l m
= xpWrap ( \ (a, (b, c, d, e, f, g), (h, i, j, k, l, m)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m)
, \ (a, b, c, d, e, f, g, h, i, j, k, l, m) -> (a, (b, c, d, e, f, g), (h, i, j, k, l, m))
)
(xpTriple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m))
xp14Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU j ->
PU k -> PU l -> PU m -> PU n -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n)
xp14Tuple a b c d e f g h i j k l m n
= xpWrap ( \ ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n)
, \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n))
)
(xpTriple (xpPair a b) (xp6Tuple c d e f g h) (xp6Tuple i j k l m n))
xp15Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU j ->
PU k -> PU l -> PU m -> PU n -> PU o ->
PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)
xp15Tuple a b c d e f g h i j k l m n o
= xpWrap ( \ ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)
, \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o))
)
(xpTriple (xpTriple a b c) (xp6Tuple d e f g h i) (xp6Tuple j k l m n o))
xp16Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU j ->
PU k -> PU l -> PU m -> PU n -> PU o ->
PU p -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)
xp16Tuple a b c d e f g h i j k l m n o p
= xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)
, \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) -> ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p))
)
(xpTriple (xp4Tuple a b c d) (xp6Tuple e f g h i j) (xp6Tuple k l m n o p))
xp17Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU j ->
PU k -> PU l -> PU m -> PU n -> PU o ->
PU p -> PU q -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)
xp17Tuple a b c d e f g h i j k l m n o p q
= xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)
, \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) -> ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q))
)
(xpTriple (xp5Tuple a b c d e) (xp6Tuple f g h i j k) (xp6Tuple l m n o p q))
xp18Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU j ->
PU k -> PU l -> PU m -> PU n -> PU o ->
PU p -> PU q -> PU r -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)
xp18Tuple a b c d e f g h i j k l m n o p q r
= xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)
, \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) -> ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r))
)
(xpTriple (xp6Tuple a b c d e f) (xp6Tuple g h i j k l) (xp6Tuple m n o p q r))
xp19Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU j ->
PU k -> PU l -> PU m -> PU n -> PU o ->
PU p -> PU q -> PU r -> PU s -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)
xp19Tuple a b c d e f g h i j k l m n o p q r s
= xpWrap ( \ (a, (b, c, d, e, f, g), (h, i, j, k, l, m), (n, o, p, q, r, s)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)
, \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) -> (a, (b, c, d, e, f, g), (h, i, j, k, l, m), (n, o, p, q, r, s))
)
(xp4Tuple a (xp6Tuple b c d e f g) (xp6Tuple h i j k l m) (xp6Tuple n o p q r s))
xp20Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU j ->
PU k -> PU l -> PU m -> PU n -> PU o ->
PU p -> PU q -> PU r -> PU s -> PU t ->
PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)
xp20Tuple a b c d e f g h i j k l m n o p q r s t
= xpWrap ( \ ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n), (o, p, q, r, s, t)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)
, \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) -> ((a, b), (c, d, e, f, g, h), (i, j, k, l, m, n), (o, p, q, r, s, t))
)
(xp4Tuple (xpPair a b) (xp6Tuple c d e f g h) (xp6Tuple i j k l m n) (xp6Tuple o p q r s t))
xp21Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU j ->
PU k -> PU l -> PU m -> PU n -> PU o ->
PU p -> PU q -> PU r -> PU s -> PU t ->
PU u -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u)
xp21Tuple a b c d e f g h i j k l m n o p q r s t u
= xpWrap ( \ ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o), (p, q, r, s, t, u)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u)
, \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) -> ((a, b, c), (d, e, f, g, h, i), (j, k, l, m, n, o), (p, q, r, s, t, u))
)
(xp4Tuple (xpTriple a b c) (xp6Tuple d e f g h i) (xp6Tuple j k l m n o) (xp6Tuple p q r s t u))
xp22Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU j ->
PU k -> PU l -> PU m -> PU n -> PU o ->
PU p -> PU q -> PU r -> PU s -> PU t ->
PU u -> PU v -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v)
xp22Tuple a b c d e f g h i j k l m n o p q r s t u v
= xpWrap ( \ ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p), (q, r, s, t, u, v)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v)
, \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) -> ((a, b, c, d), (e, f, g, h, i, j), (k, l, m, n, o, p), (q, r, s, t, u, v))
)
(xp4Tuple (xp4Tuple a b c d) (xp6Tuple e f g h i j) (xp6Tuple k l m n o p) (xp6Tuple q r s t u v))
xp23Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU j ->
PU k -> PU l -> PU m -> PU n -> PU o ->
PU p -> PU q -> PU r -> PU s -> PU t ->
PU u -> PU v -> PU w -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w)
xp23Tuple a b c d e f g h i j k l m n o p q r s t u v w
= xpWrap ( \ ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q), (r, s, t, u, v, w)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w)
, \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) -> ((a, b, c, d, e), (f, g, h, i, j, k), (l, m, n, o, p, q), (r, s, t, u, v, w))
)
(xp4Tuple (xp5Tuple a b c d e) (xp6Tuple f g h i j k) (xp6Tuple l m n o p q) (xp6Tuple r s t u v w))
xp24Tuple :: PU a -> PU b -> PU c -> PU d -> PU e ->
PU f -> PU g -> PU h -> PU i -> PU j ->
PU k -> PU l -> PU m -> PU n -> PU o ->
PU p -> PU q -> PU r -> PU s -> PU t ->
PU u -> PU v -> PU w -> PU x -> PU (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x)
xp24Tuple a b c d e f g h i j k l m n o p q r s t u v w x
= xpWrap ( \ ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r), (s, t, u, v, w, x)) -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x)
, \ (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) -> ((a, b, c, d, e, f), (g, h, i, j, k, l), (m, n, o, p, q, r), (s, t, u, v, w, x))
)
(xp4Tuple (xp6Tuple a b c d e f) (xp6Tuple g h i j k l) (xp6Tuple m n o p q r) (xp6Tuple s t u v w x))
xpText :: PU String
xpText = xpTextDT scString1
xpTextDT :: Schema -> PU String
xpTextDT sc
= PU { appPickle = \ (s, st) -> addCont (XN.mkText s) st
, appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleString st)
, theSchema = sc
}
where
unpickleString st
= do
t <- getCont st
s <- XN.getText t
return (Just s, dropCont st)
xpText0 :: PU String
xpText0 = xpText0DT scString1
xpText0DT :: Schema -> PU String
xpText0DT sc
= xpWrap (fromMaybe "", emptyToNothing) $ xpOption $ xpTextDT sc
where
emptyToNothing "" = Nothing
emptyToNothing x = Just x
xpPrim :: (Read a, Show a) => PU a
xpPrim
= xpWrapMaybe (readMaybe, show) xpText
where
readMaybe :: Read a => String -> Maybe a
readMaybe str
= val (reads str)
where
val [(x,"")] = Just x
val _ = Nothing
xpTree :: PU XmlTree
xpTree = PU { appPickle = \ (s, st) -> addCont s st
, appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleTree st)
, theSchema = Any
}
where
unpickleTree st
= do
t <- getCont st
return (Just t, dropCont st)
xpTrees :: PU [XmlTree]
xpTrees = (xpList xpTree) { theSchema = Any }
xpXmlText :: PU String
xpXmlText
= xpWrap ( showXML, readXML ) $ xpTrees
where
showXML = concat . runLA ( xshowEscapeXml unlistA )
readXML = runLA xread
xpOption :: PU a -> PU (Maybe a)
xpOption pa
= PU { appPickle = ( \ (a, st) ->
case a of
Nothing -> st
Just x -> appPickle pa (x, st)
)
, appUnPickle = appUnPickle $
xpChoice (xpLift Nothing) pa (xpLift . Just)
, theSchema = scOption (theSchema pa)
}
xpDefault :: (Eq a) => a -> PU a -> PU a
xpDefault df
= xpWrap ( fromMaybe df
, \ x -> if x == df then Nothing else Just x
) .
xpOption
xpList :: PU a -> PU [a]
xpList pa
= PU { appPickle = ( \ (a, st) ->
case a of
[] -> st
_:_ -> appPickle pc (a, st)
)
, appUnPickle = appUnPickle $
xpChoice (xpLift []) pa
(\ x -> xpSeq id (xpList pa) (\xs -> xpLift (x:xs)))
, theSchema = scList (theSchema pa)
}
where
pc = xpSeq head pa (\ x ->
xpSeq tail (xpList pa) (\ xs ->
xpLift (x:xs)))
xpList1 :: PU a -> PU [a]
xpList1 pa
= ( xpWrap (\ (x, xs) -> x : xs
,\ (x : xs) -> (x, xs)
) $
xpPair pa (xpList pa)
) { theSchema = scList1 (theSchema pa) }
xpMap :: Ord k => String -> String -> PU k -> PU v -> PU (Map k v)
xpMap en an xpk xpv
= xpWrap ( M.fromList
, M.toList
) $
xpList $
xpElem en $
xpPair ( xpAttr an $ xpk ) xpv
xpAlt :: (a -> Int) -> [PU a] -> PU a
xpAlt tag ps
= PU { appPickle = ( \ (a, st) ->
let
pa = ps !! (tag a)
in
appPickle pa (a, st)
)
, appUnPickle = appUnPickle $
( case ps of
[] -> xpZero
pa:ps1 -> xpChoice (xpAlt tag ps1) pa xpLift
)
, theSchema = scAlts (map theSchema ps)
}
xpElemQN :: QName -> PU a -> PU a
xpElemQN qn pa
= PU { appPickle = ( \ (a, st) ->
let
st' = appPickle pa (a, emptySt)
in
addCont (XN.mkElement qn (attributes st') (contents st')) st
)
, appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st)
, theSchema = scElem (qualifiedName qn) (theSchema pa)
}
where
unpickleElement st
= do
t <- getCont st
n <- XN.getElemName t
if n /= qn
then fail ("element name " ++ show n ++ " does not match" ++ show qn)
else do
let cs = XN.getChildren t
al <- XN.getAttrl t
res <- fst . appUnPickle pa $ St {attributes = al, contents = cs}
return (Just res, dropCont st)
xpElem :: String -> PU a -> PU a
xpElem = xpElemQN . mkName
xpElemWithAttrValue :: String -> String -> String -> PU a -> PU a
xpElemWithAttrValue name an av pa
= PU { appPickle = ( \ (a, st) ->
let
st' = appPickle pa' (a, emptySt)
in
addCont (XN.mkElement (mkName name) (attributes st') (contents st')) st
)
, appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st)
, theSchema = scElem name (theSchema pa')
}
where
pa' = xpAddFixedAttr an av $ pa
noMatch = null . runLA ( isElem
>>>
hasName name
>>>
hasAttrValue an (==av)
)
unpickleElement st
= do
t <- getCont st
if noMatch t
then fail "element name or attr value does not match"
else do
let cs = XN.getChildren t
al <- XN.getAttrl t
res <- fst . appUnPickle pa $ St {attributes = al, contents = cs}
return (Just res, dropCont st)
xpAttrQN :: QName -> PU a -> PU a
xpAttrQN qn pa
= PU { appPickle = ( \ (a, st) ->
let
st' = appPickle pa (a, emptySt)
in
addAtt (XN.mkAttr qn (contents st')) st
)
, appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleAttr st)
, theSchema = scAttr (qualifiedName qn) (theSchema pa)
}
where
unpickleAttr st
= do
a <- getAtt qn st
let av = XN.getChildren a
res <- fst . appUnPickle pa $ St {attributes = [], contents = av}
return (Just res, st)
xpAttr :: String -> PU a -> PU a
xpAttr = xpAttrQN . mkName
xpTextAttr :: String -> PU String
xpTextAttr = flip xpAttr xpText
xpAttrImplied :: String -> PU a -> PU (Maybe a)
xpAttrImplied name pa
= xpOption $ xpAttr name pa
xpAttrFixed :: String -> String -> PU ()
xpAttrFixed name val
= ( xpWrapMaybe ( \ v -> if v == val then Just () else Nothing
, const val
) $
xpAttr name xpText
) { theSchema = scAttr name (scFixed val) }
xpAddFixedAttr :: String -> String -> PU a -> PU a
xpAddFixedAttr name val pa
= xpWrap ( snd
, (,) ()
) $
xpPair (xpAttrFixed name val) pa
class XmlPickler a where
xpickle :: PU a
instance XmlPickler Int where
xpickle = xpPrim
instance XmlPickler Integer where
xpickle = xpPrim
instance XmlPickler () where
xpickle = xpUnit
instance (XmlPickler a, XmlPickler b) => XmlPickler (a,b) where
xpickle = xpPair xpickle xpickle
instance (XmlPickler a, XmlPickler b, XmlPickler c) => XmlPickler (a,b,c) where
xpickle = xpTriple xpickle xpickle xpickle
instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d) => XmlPickler (a,b,c,d) where
xpickle = xp4Tuple xpickle xpickle xpickle xpickle
instance (XmlPickler a, XmlPickler b, XmlPickler c, XmlPickler d, XmlPickler e) => XmlPickler (a,b,c,d,e) where
xpickle = xp5Tuple xpickle xpickle xpickle xpickle xpickle
instance XmlPickler a => XmlPickler [a] where
xpickle = xpList xpickle
instance XmlPickler a => XmlPickler (Maybe a) where
xpickle = xpOption xpickle