module Generics.Regular.XmlPickler.Function (gxpickle, GXmlPickler(..)) where
import Data.Char (toLower)
import Generics.Regular
import Text.XML.HXT.Arrow.Pickle
import Text.XML.HXT.Arrow.Pickle.Schema
class GXmlPickler f where
gxpicklef :: PU a -> PU (f a)
instance GXmlPickler I where
gxpicklef = xpWrap (I, unI)
instance XmlPickler a => GXmlPickler (K a) where
gxpicklef _ = (K, unK) `xpWrap` xpickle
instance GXmlPickler U where
gxpicklef _ = (const U, const ()) `xpWrap` xpUnit
instance (GXmlPickler f, GXmlPickler g) => GXmlPickler (f :+: g) where
gxpicklef f = gxpicklef f `xpSum` gxpicklef f
instance (GXmlPickler f, GXmlPickler g) => GXmlPickler (f :*: g) where
gxpicklef f = (uncurry (:*:), \(a :*: b) -> (a, b)) `xpWrap` (gxpicklef f `xpPair` gxpicklef f)
instance (Constructor c, GXmlPickler f) => GXmlPickler (C c f) where
gxpicklef f = xpElem (map toLower $ conName (undefined :: C c f r)) ((C, unC) `xpWrap` (gxpicklef f))
instance (Selector s, GXmlPickler f) => GXmlPickler (S s f) where
gxpicklef f = xpElem (map toLower $ selName (undefined :: S s f r)) ((S, unS) `xpWrap` gxpicklef f)
gxpickle :: (Regular a, GXmlPickler (PF a)) => PU a
gxpickle = (to, from) `xpWrap` gxpicklef gxpickle
xpEither :: PU a -> PU b -> PU (Either a b)
xpEither ~(PU fl tl sa) ~(PU fr tr sb) = PU
(\(x, st) -> case x of
Left y -> fl (y, st)
Right y -> fr (y, st))
(\x -> case tl x of
(Nothing, _) -> lmap (fmap Right) (tr x)
r -> lmap (fmap Left) r)
(sa `scAlt` sb)
where lmap f (a, b) = (f a, b)
xpSum :: PU (f r) -> PU (g r) -> PU ((f :+: g) r)
xpSum l r = (i, o) `xpWrap` xpEither l r
where
i (Left x) = L x
i (Right x) = R x
o (L x) = Left x
o (R x) = Right x