module Text.XML.ToFromXML (
ToFromXML(..),
toXML,fromXML,fromXMLEither,
readFromXMLFile,writeToXMLFile,
module GHC.Generics
) where
import GHC.Generics
import qualified Data.ByteString as BS
import Text.XML.Expat.Pickle
import Text.XML.Expat.Tree
import qualified Text.XML.Expat.Format as Format
import Text.Printf
import Data.Char
import Data.Word
import Data.Ratio
import Data.Int
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Complex
import Data.Array.IArray
type Pickler a = PU (ListOf (UNode String)) a
class GToFromXML f where
gXMLPickler :: Pickler (f p)
class PickleProdN f where
pickleProdN :: Int -> (Int,Pickler (f p))
instance (PickleProdN f1,PickleProdN f2) => PickleProdN (f1 :*: f2) where
pickleProdN i = (i2,xpWrap (uncurry (:*:),\ (a :*: b) -> (a,b)) $ xpPair p1 p2) where
(i1,p1) = pickleProdN i
(i2,p2) = pickleProdN i1
argTagNames = [ "ARG-" ++ show i | i <- [1..] ]
instance (GToFromXML f) => PickleProdN (M1 S NoSelector f) where
pickleProdN i = (i+1,xpElemNodes (argTagNames!!i) gXMLPickler)
instance (GToFromXML f,Selector s) => PickleProdN (M1 S s f) where
pickleProdN i = (i+1,picklearg) where
selname = selName (undefined :: M1 S s f p)
picklearg = xpAlt (\_->0) [
xpElemWithAttr (argTagNames!!i) "selector" selname gXMLPickler,
xpElemNodes (argTagNames!!i) gXMLPickler ]
instance (PickleProdN (f1 :*: f2)) => GToFromXML (f1 :*: f2) where
gXMLPickler = snd (pickleProdN 0)
instance (GToFromXML f1,GToFromXML f2) => GToFromXML (f1 :+: f2) where
gXMLPickler = xpAlt selfun [
xpWrap (L1,\ (L1 x) -> x) gXMLPickler,
xpWrap (R1,\ (R1 x) -> x) gXMLPickler ] where
selfun (L1 _) = 0
selfun (R1 _) = 1
instance (GToFromXML f,Datatype d) => GToFromXML (M1 D d f) where
gXMLPickler = xpWrap (M1,unM1) gXMLPickler
instance (GToFromXML f,Constructor c) => GToFromXML (M1 C c f) where
gXMLPickler = xpWrap (M1,unM1) $ xpElemWithAttr "CONSTRUCTOR" "name" conname gXMLPickler where
conname = conName (undefined :: M1 C c f p)
instance (GToFromXML f) => GToFromXML (M1 S NoSelector f) where
gXMLPickler = xpWrap (M1,unM1) gXMLPickler
instance (GToFromXML f,Selector s) => GToFromXML (M1 S s f) where
gXMLPickler = xpWrap (M1,unM1) gXMLPickler
xpElemWithAttr tag attrname attrval pickler = xpWrap (snd,\b->((),b)) $
xpElem tag (xpAttrFixed attrname attrval) pickler
instance GToFromXML U1 where
gXMLPickler = xpLift U1
instance (ToFromXML a) => GToFromXML (K1 R a) where
gXMLPickler = xpWrap (K1,unK1) xMLPickler
class ToFromXML a where
xMLPickler :: Pickler a
default xMLPickler :: (Read a,Show a) => Pickler a
xMLPickler = xpContent xpPrim
instance ToFromXML () where
xMLPickler = xpElemNodes "UNIT" xpUnit
instance (ToFromXML a) => ToFromXML [a] where
xMLPickler = xpElemNodes "LIST" $ xpList0 $ xpElemNodes "ITEM" xMLPickler
instance ToFromXML Int
instance ToFromXML Int8
instance ToFromXML Int16
instance ToFromXML Int32
instance ToFromXML Int64
instance ToFromXML Integer
instance ToFromXML Word
instance ToFromXML Word8
instance ToFromXML Word16
instance ToFromXML Word32
instance ToFromXML Word64
instance ToFromXML Float
instance ToFromXML Double
instance (Show a,Read a,Integral a) => ToFromXML (Ratio a)
instance (Show a,Read a) => ToFromXML (Complex a)
instance ToFromXML Bool where
xMLPickler = xpAlt selfun [
xpElemNodes "TRUE" $ xpLift True,
xpElemNodes "FALSE" $ xpLift False ] where
selfun True = 0
selfun False = 1
instance ToFromXML Char where
xMLPickler = xpContent $ xpWrap ( fst.head.readLitChar, (`showLitChar` "") ) xpText
instance ToFromXML String where
xMLPickler = xpContent pickleContentString
skipPickleString = (`elem` ['\r','\n','\t'])
pickleContentString :: PU String String
pickleContentString = xpWrap ( readLitString, showLitString ) xpText0 where
readLitString "" = ""
readLitString (c:ss) | skipPickleString c = readLitString ss
readLitString s = let [(c,ss)] = readLitChar s in c : readLitString ss
showLitString "" = ""
showLitString (c:ss) | skipPickleString c = showLitChar c $ c : showLitString ss
showLitString (c:ss) = showLitChar c $ showLitString ss
instance (Ord k,ToFromXML k,ToFromXML v) => ToFromXML (Map.Map k v) where
xMLPickler = xpElemNodes "MAP" $ xpWrap (Map.fromList,Map.toList) $ xpList $
xpElemNodes "ASSOC" $ xpPair
(xpElemNodes "KEY" xMLPickler)
(xpElemNodes "ELEM" xMLPickler)
instance (ToFromXML v) => ToFromXML (IntMap.IntMap v) where
xMLPickler = xpElemNodes "INTMAP" $ xpWrap (IntMap.fromList,IntMap.toList) $ xpList $
xpElem "ELEM" (xpAttr "index" xpPrim) xMLPickler
instance (ToFromXML a,ToFromXML b) => ToFromXML (a,b) where
xMLPickler = xpElemNodes "PAIR" $ xpPair (xpComponent 0) (xpComponent 1)
instance (ToFromXML a,ToFromXML b,ToFromXML c) => ToFromXML (a,b,c) where
xMLPickler = xpElemNodes "TRIPLE" $ xpTriple (xpComponent 0) (xpComponent 1) (xpComponent 2)
instance (ToFromXML a,ToFromXML b,ToFromXML c,ToFromXML d) => ToFromXML (a,b,c,d) where
xMLPickler = xpElemNodes "QUADRUPLE" $ xp4Tuple (xpComponent 0) (xpComponent 1) (xpComponent 2) (xpComponent 3)
instance (ToFromXML a,ToFromXML b,ToFromXML c,ToFromXML d,ToFromXML e) => ToFromXML (a,b,c,d,e) where
xMLPickler = xpElemNodes "QUINTUPLE" $ xp5Tuple (xpComponent 0) (xpComponent 1) (xpComponent 2) (xpComponent 3) (xpComponent 4)
instance (ToFromXML a,ToFromXML b,ToFromXML c,ToFromXML d,ToFromXML e,ToFromXML f) => ToFromXML (a,b,c,d,e,f) where
xMLPickler = xpElemNodes "SEXTUPLE" $ xp6Tuple (xpComponent 0) (xpComponent 1) (xpComponent 2) (xpComponent 3) (xpComponent 4) (xpComponent 5)
xpComponent :: (ToFromXML a) => Int -> Pickler a
xpComponent i = xpElemNodes (componentnames!!i) xMLPickler where
componentnames = [ "FIRST","SECOND","THIRD","FOURTH","FIFTH","SIXTH" ]
instance (ToFromXML a) => ToFromXML (Maybe a) where
xMLPickler = xpAlt selfun [
xpElemNodes "NOTHING" $ xpLift Nothing,
xpElemNodes "JUST" $ xpWrap (Just, \ (Just a) -> a ) xMLPickler ] where
selfun Nothing = 0
selfun (Just _) = 1
instance (ToFromXML a,ToFromXML b) => ToFromXML (Either a b) where
xMLPickler = xpAlt selfun [
xpElemNodes "LEFT" $ xpWrap ( Left, \ (Left a) -> a ) xMLPickler,
xpElemNodes "RIGHT" $ xpWrap ( Right, \ (Right b) -> b ) xMLPickler ] where
selfun (Left _) = 0
selfun (Right _) = 1
instance (ToFromXML a,Ord a) => ToFromXML (Set.Set a) where
xMLPickler = xpElemNodes "SET" $ xpWrap (Set.fromList,Set.toList) $ xpList $
xpElemNodes "ELEM" xMLPickler
instance (Ix i,Show i,Read i,ToFromXML e) => ToFromXML (Array i e) where
xMLPickler = xpWrap (list2arr,arr2list) $ xpElem "ARRAY" xpbounds $ xpList $
xpElemNodes "ELEM" xMLPickler where
xpbounds = xpPair (xpAttr "lowerBound" xpPrim) (xpAttr "upperBound" xpPrim)
arr2list arr = (bounds arr,elems arr)
list2arr (bounds,arrelems) = listArray bounds arrelems
instance (Generic a,GToFromXML (Rep a)) => ToFromXML a where
xMLPickler = xpWrap (to,from) gXMLPickler
toXML :: (Generic a,GToFromXML (Rep a)) => a -> BS.ByteString
toXML x = Format.format' $ Format.indent 2 $ pickleTree (xpRoot gXMLPickler) (from x)
fromXMLEither :: (GToFromXML f) => BS.ByteString -> Either String (f p)
fromXMLEither bs = case parse' defaultParseOptions bs of
Left (XMLParseError errmsg loc) ->
Left $ printf "XMLParseError at %s:\n %s" (show loc) errmsg
Right tree ->
unpickleTree' (xpRoot gXMLPickler) tree
fromXML :: (Generic a,GToFromXML (Rep a)) => BS.ByteString -> a
fromXML bs = case fromXMLEither bs of
Left errmsg -> error errmsg
Right x -> to x
writeToXMLFile :: (Generic a,GToFromXML (Rep a)) => FilePath -> a -> IO ()
writeToXMLFile filepath a = BS.writeFile filepath $ toXML a
readFromXMLFile :: (Generic a,GToFromXML (Rep a)) => FilePath -> IO a
readFromXMLFile filepath = BS.readFile filepath >>= return . fromXML