module Text.XML.Expat.Pickle.Generic
(
IsXML (..)
, encodeXML
, decodeXML
, PU (..)
, GenericXMLOptions (..)
, defaultXMLOptions
, genericXMLPickler
, xpSum
, xpEither
, xpGenericString
, xpText0
, xpText
, xpList0
, xpList
, xpContent
, xpPrim
, xpWrap
) where
import Data.ByteString (ByteString)
import Data.Char (isLower)
import Data.Text (Text)
import GHC.Generics
import qualified Text.XML.Expat.Pickle as Pickle
import Text.XML.Expat.Pickle hiding (xpPrim)
class IsXML a where
xmlPickler :: PU [UNode ByteString] a
default xmlPickler :: (Generic a, GIsXML [UNode ByteString] (Rep a))
=> PU [UNode ByteString] a
xmlPickler = genericXMLPickler defaultXMLOptions
encodeXML :: IsXML a => a -> ByteString
encodeXML = pickleXML' (xpRoot xmlPickler)
decodeXML :: IsXML a => ByteString -> Either String a
decodeXML = unpickleXML' defaultParseOptions (xpRoot xmlPickler)
data GenericXMLOptions = GenericXMLOptions
{ constructorTagModifier :: String -> String
, fieldLabelModifier :: String -> String
}
type Options = GenericXMLOptions
defaultXMLOptions :: Options
defaultXMLOptions = GenericXMLOptions id (dropWhile isLower)
genericXMLPickler opts =
(to, from) `xpWrap` (gXMLPickler opts) (genericXMLPickler opts)
class GIsXML t f where
gXMLPickler :: Options -> PU t a -> PU t (f a)
instance IsXML a => GIsXML [UNode ByteString] (K1 i a) where
gXMLPickler _ _ = (K1, unK1) `xpWrap` xmlPickler
instance GIsXML [t] U1 where
gXMLPickler _ _ = (const U1, const ()) `xpWrap` xpUnit
instance (GIsXML t f, GIsXML t g) => GIsXML t (f :+: g) where
gXMLPickler opts f = gXMLPickler opts f `xpSum` gXMLPickler opts f
instance (GIsXML [t] f, GIsXML [t] g) => GIsXML [t] (f :*: g) where
gXMLPickler opts f = xpWrap
(uncurry (:*:), \(a :*: b) -> (a, b))
(gXMLPickler opts f `xpPair` gXMLPickler opts f)
instance (Datatype d, GIsXML t f) => GIsXML t (M1 D d f) where
gXMLPickler opts = xpWrap (M1, unM1) . gXMLPickler opts
instance (Constructor c, GIsXML [UNode ByteString] f)
=> GIsXML [UNode ByteString] (M1 C c f) where
gXMLPickler opts f = xpElemNodes
(gxFromString . constructorTagModifier opts $ conName (undefined :: M1 C c f r))
((M1, unM1) `xpWrap` gXMLPickler opts f)
instance (Selector s, GIsXML [UNode ByteString] f)
=> GIsXML [UNode ByteString] (M1 S s f) where
gXMLPickler opts f = xpElemNodes
(gxFromString . fieldLabelModifier opts $ selName (undefined :: M1 S s f r))
((M1, unM1) `xpWrap` gXMLPickler opts f)
xpPrim :: (Read b, Show b, GenericXMLString t) => PU [Node a t] b
xpPrim = xpContent Pickle.xpPrim
xpSum :: PU t (f r) -> PU t (g r) -> PU t ((f :+: g) r)
xpSum left right = (inp, out) `xpWrap` xpEither left right
where
inp (Left x) = L1 x
inp (Right x) = R1 x
out (L1 x) = Left x
out (R1 x) = Right x
xpEither :: PU t a -> PU t b -> PU t (Either a b)
xpEither ~(PU _ uea pa) ~(PU ub ueb pb) =
PU unpickle unpickleEither pickle
where
unpickle t = case uea t of
Right x -> Left x
Left _ -> Right $ ub t
unpickleEither t = case uea t of
Right x -> Right . Left $ x
Left _ -> Right `fmap` ueb t
pickle (Left x) = pa x
pickle (Right y) = pb y
xpGenericString :: GenericXMLString t => PU [UNode ByteString] t
xpGenericString = (gxFromByteString, gxToByteString) `xpWrap` xpContent xpText0
instance IsXML Int where
xmlPickler = xpPrim
instance IsXML Integer where
xmlPickler = xpPrim
instance IsXML Text where
xmlPickler = xpGenericString
instance IsXML ByteString where
xmlPickler = xpGenericString
instance IsXML a => IsXML (Maybe a) where
xmlPickler = xpOption xmlPickler
instance IsXML a => IsXML [a] where
xmlPickler = xpList0 xmlPickler