{-# LANGUAGE TemplateHaskell, FlexibleInstances,
OverlappingInstances, UndecidableInstances #-}
module Xml.Base where
import Control.Monad.State
import Data.Char
import Data.List
import Xml.DeriveAll
import Data.Generics.SYB.WithClass.Basics
import Data.Generics.SYB.WithClass.Instances ()
import Data.Maybe
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import Language.Haskell.TH
$(deriveAll [d|
data Element = Elem String [Element]
| CData String
| Attr String String
|])
-- This is a more readable representation than the default, but is still
-- Haskell syntax
instance Show Element where
show (Elem s es) = "Elem " ++ show s ++ " ["
++ fiddle (unlines (indent (concatMap (lines . show) es)))
++ "]"
where indent = map (" " ++)
fiddle "" = ""
fiddle xs = '\n' : (if last xs == '\n' then init xs else xs)
show (CData s) = "CData " ++ show s
show (Attr k v) = "Attr " ++ show k ++ " " ++ show v
-- XXX defaulting should happen here?
fromXml :: Xml a => [Element] -> Maybe a
fromXml xs = fmap snd $ readXml xs
class Data XmlD a => Xml a where
toXml :: a -> [Element]
toXml = defaultToXml
readXml :: [Element] -> Maybe ([Element], a)
readXml = defaultFromXml
instance Data XmlD t => Xml t
data XmlD a = XmlD { toXmlD :: a -> [Element], readMXmlD :: ReadM a }
xmlProxy :: Proxy XmlD
xmlProxy = error "xmlProxy"
instance Xml t => Sat (XmlD t) where
dict = XmlD { toXmlD = toXml, readMXmlD = readMXml }
first :: (a -> a) -> [a] -> [a]
first _ [] = []
first f (x:xs) = f x : xs
defaultToXml :: Xml t => t -> [Element]
defaultToXml x = [Elem (first toLower $ constring $ toConstr xmlProxy x)
(transparentToXml x)]
transparentToXml :: Xml t => t -> [Element]
transparentToXml x = concat $ gmapQ xmlProxy (toXmlD dict) x
transparentReadXml :: Xml t => [Element] -> Maybe ([Element], t)
transparentReadXml es = res
where resType = dataTypeOf xmlProxy (snd $ fromJust res)
res = aConstrFromElements (dataTypeConstrs resType) es
transparentXml :: Name -> Q [Dec]
transparentXml n
= do i <- reify n
case i of
TyConI (DataD _ _ vs _ _) ->
do argNames <- replicateM (length vs) (newName "a")
let args = map varT argNames
mkXml a = conT ''Xml `appT` a
ctxt = cxt $ map mkXml args
typ = mkXml $ foldl appT (conT n) args
decs <- [d| toXml = transparentToXml
readXml = transparentReadXml |]
d <- instanceD ctxt typ (map return decs)
return [d]
defaultFromXml :: Xml t => [Element] -> Maybe ([Element], t)
defaultFromXml = fromXmlWith fromElement
fromXmlWith :: Xml t
=> (Element -> Maybe t) -> [Element] -> Maybe ([Element], t)
fromXmlWith f = fromXmlWith' f []
fromXmlWith' :: Xml t
=> (Element -> Maybe t) -> [Element] -> [Element]
-> Maybe ([Element], t)
fromXmlWith' f acc (x:xs)
= case f x of
Nothing -> fromXmlWith' f (x:acc) xs
Just v ->
Just (reverse acc ++ xs, v)
fromXmlWith' _ _ [] = Nothing
fromElement :: Xml t => Element -> Maybe t
fromElement (Elem n es) = res
where resType = dataTypeOf xmlProxy (fromJust res)
res = case readConstr resType $ first toUpper n of
Just c ->
case constrFromElements c es of
-- We ignore left over elements
Just (_, x) -> Just x
Nothing -> Nothing
Nothing -> Nothing
fromElement _ = Nothing
aConstrFromElements :: Xml t => [Constr] -> [Element] -> Maybe ([Element], t)
aConstrFromElements cs es = msum [ constrFromElements c es | c <- cs ]
constrFromElements :: Xml t => Constr -> [Element] -> Maybe ([Element], t)
constrFromElements c es = case runStateT m st of
-- XXX Should we flip the result order?
Just (x, st) -> Just (xmls st, x)
Nothing -> Nothing
where m = fromConstrM xmlProxy (readMXmlD dict) c
st = ReadState { xmls = es }
type ReadM = StateT ReadState Maybe
data ReadState = ReadState {
xmls :: [Element]
}
getXmls :: ReadM [Element]
getXmls = do st <- get
return $ xmls st
putXmls :: [Element] -> ReadM ()
putXmls xs = do st <- get
put $ st { xmls = xs }
readMXml :: Xml a => ReadM a
readMXml = do xs <- getXmls
case readXml xs of
Nothing ->
fail "Can't read value"
Just (xs', v) ->
do putXmls xs'
return v
xmlAttr :: Name -> Q [Dec]
xmlAttr newTypeName
= do i <- reify newTypeName
case i of
TyConI (NewtypeD _ n _ (NormalC c [(_, ConT t)]) _)
| t == ''ByteString -> mkDecs n c t
_ -> fail "xmlAttr: Didn't get what I wanted"
where mkDecs n c t =
do let x = mkName "x"
f = mkName "f"
cstr = stringL $ first toLower $ nameBase c
-- toXml (c x) = [Attr "c" $ BS.unpack x]
toFun = funD
'toXml
[clause
[conP c [varP x]]
(normalB [| [Attr $(litE cstr)
$ BS.unpack $(varE x)] |])
[]]
-- readXml = fromXmlWith f
-- where <readHelper>
readFun = funD
'readXml
[clause
[]
(normalB [| fromXmlWith $(varE f) |])
[readHelper]]
-- f (Attr "c" x) = Just $ c $ BS.pack x
-- f _ = Nothing
readHelper
= funD f
[
clause [conP 'Attr [litP cstr, (varP x)]]
(normalB [| Just $ $(conE c)
$ BS.pack $(varE x) |])
[],
clause [wildP]
(normalB [| Nothing |])
[]
]
inst <- instanceD (cxt [])
( conT ''Xml `appT` conT n)
[toFun, readFun]
return [inst]
xmlShowCDatas :: [Name] -> Q [Dec]
xmlShowCDatas = liftM concat . mapM xmlShowCData
xmlShowCData :: Name -> Q [Dec]
xmlShowCData newTypeName
= do ds <- [d|
toXml x = [CData $ show x]
readXml = fromXmlWith f
where f (CData x)
| [(v, "")] <- reads x = Just v
f _ = Nothing
|]
d <- instanceD (cxt [])
(conT ''Xml `appT` conT newTypeName)
(map return ds)
return [d]