generic-xml (empty) → 0.1
raw patch · 8 files changed
+414/−0 lines, 8 filesdep +HaXmldep +basedep +mtlbuild-type:Customsetup-changed
Dependencies added: HaXml, base, mtl, syb-with-class, template-haskell
Files
- Setup.hs +8/−0
- Xml/Base.hs +211/−0
- Xml/DeriveAll.hs +27/−0
- Xml/HaXml.hs +45/−0
- Xml/Instances.hs +56/−0
- Xml/PrintParse.hs +35/−0
- Xml/Xml.hs +7/−0
- generic-xml.cabal +25/−0
+ Setup.hs view
@@ -0,0 +1,8 @@++module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain+
+ Xml/Base.hs view
@@ -0,0 +1,211 @@+{-# 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]+
+ Xml/DeriveAll.hs view
@@ -0,0 +1,27 @@++{-# LANGUAGE TemplateHaskell #-}++module Xml.DeriveAll (deriveAll) where++import Data.Generics as Old+import Data.Generics.SYB.WithClass.Derive+import Language.Haskell.TH++deriveAll :: Q [Dec] -> Q [Dec]+deriveAll qdecs = do decs <- qdecs+ derivedDecs <- deriveDec (filter isDataOrNewtype decs)+ let decs' = map deriveOldData decs+ return (decs' ++ derivedDecs)++deriveOldData :: Dec -> Dec+deriveOldData (DataD ctxt nm tvs cons derivs)+ = DataD ctxt nm tvs cons (''Old.Data : derivs)+deriveOldData (NewtypeD ctxt nm tvs con derivs)+ = NewtypeD ctxt nm tvs con (''Old.Data : derivs)+deriveOldData d = d++isDataOrNewtype :: Dec -> Bool+isDataOrNewtype (DataD {}) = True+isDataOrNewtype (NewtypeD {}) = True+isDataOrNewtype _ = False+
+ Xml/HaXml.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances,+ OverlappingInstances, UndecidableInstances #-}++module Xml.HaXml where++import Data.List+import Xml.Base+import qualified Text.XML.HaXml.Types as H++isAttr :: Element -> Bool+isAttr (Attr {}) = True+isAttr _ = False++toHaXmls :: [Element] -> [H.Content]+toHaXmls = map toHaXml++toHaXml :: Element -> H.Content+toHaXml (Elem n es) = case partition isAttr es of+ (as, xs) ->+ H.CElem (H.Elem n (map toAttribute as) (toHaXmls xs))+toHaXml (CData x) = H.CString True x+-- We can't do better than wrap an attribute up in a fake element.+-- This shouldn't be happening in the real world anyway.+toHaXml a@(Attr {}) = toHaXml (Elem "JustAnAttr" [a])++toAttribute :: Element -> H.Attribute+toAttribute (Attr k v) = (k, H.AttValue [Left v])+toAttribute _ = error "toAttribute: Can't happen"++fromHaXmls :: [H.Content] -> [Element]+fromHaXmls = map fromHaXml++fromHaXml :: H.Content -> Element+fromHaXml (H.CElem (H.Elem n as xs))+ = Elem n (fromAttributes as ++ fromHaXmls xs)+fromHaXml (H.CString _ x) = CData x+fromHaXml _ = error "fromHaXml: Not implemented"++fromAttributes :: [H.Attribute] -> [Element]+fromAttributes = map fromAttribute++fromAttribute :: H.Attribute -> Element+fromAttribute (k, H.AttValue [Left v]) = Attr k v+fromAttribute _ = error "fromAttribute: Not implemented"+
+ Xml/Instances.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances,+ OverlappingInstances, UndecidableInstances #-}++module Xml.Instances where++import Data.Char+import Data.List+import Xml.Base+import Data.Generics.SYB.WithClass.Basics+import Data.Generics.SYB.WithClass.Derive+import Data.Generics.SYB.WithClass.Instances ()+import Data.Maybe+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS++-- The Xml [a] context is a bit scary, but if we don't have it then+-- GHC complains about overlapping instances+instance (Xml a, Xml [a]) => Xml [a] where+ toXml = concatMap toXml+ readXml = f [] []+ where f acc_xs acc_vs [] = Just (reverse acc_xs, reverse acc_vs)+ f acc_xs acc_vs (x:xs) = case readXml [x] of+ Just ([], v) ->+ f acc_xs (v:acc_vs) xs+ _ ->+ f (x:acc_xs) acc_vs xs++instance Xml String where+ toXml x = [CData x]+ readXml = fromXmlWith f+ where f (CData x) = Just x+ f _ = Nothing++-- XXX This instance should be somewhere else as otherwise we get+-- problems when two different traversals define it+$( deriveData [''ByteString] )++instance Xml ByteString where+ toXml x = [CData $ BS.unpack x]+ readXml = fromXmlWith f+ where f (CData x) = Just $ BS.pack x+ f _ = Nothing++$( xmlShowCDatas [''Int, ''Integer, ''Float, ''Double] )++instance Xml a => Xml (Maybe a) where+ toXml = transparentToXml+ -- We can't use transparentReadXml or Nothing would always win, as+ -- it is first in the list of constructors+ readXml = aConstrFromElements $ map (toConstr xmlProxy) [Just (), Nothing]++$( transparentXml ''Either )+$( transparentXml ''(,) )+$( transparentXml ''(,,) )+$( transparentXml ''(,,,) )+
+ Xml/PrintParse.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances,+ OverlappingInstances, UndecidableInstances #-}++module Xml.PrintParse where++import Text.PrettyPrint.HughesPJ+import Text.XML.HaXml.Parse+import Text.XML.HaXml.Pretty+import Text.XML.HaXml.Types (Document(Document), Content(CElem))+import Xml.Base+import Xml.HaXml+import Data.Maybe++toString :: Element -> String+toString = render . content . toHaXml++toStrings :: [Element] -> String+toStrings = render . vcat . map (content . toHaXml)++--fromString :: String -> Element++class FromString a where+ fromString::String->Maybe a++instance FromString Element where+ fromString s = case xmlParse "NoFile" s of+ Document _ _ e _ ->+ return $ fromHaXml $ CElem e+ _ -> Nothing++instance (Xml a) => FromString a where+ fromString x = do+ el <- fromString x+ fromXml [el]+
+ Xml/Xml.hs view
@@ -0,0 +1,7 @@++module Xml.Xml (module Xml.Base, module Xml.PrintParse) where++import Xml.Base+import Xml.PrintParse+import Xml.Instances ()+
+ generic-xml.cabal view
@@ -0,0 +1,25 @@+Name: generic-xml+Version: 0.1+License: BSD3+Copyright: 2007 HAppS LLC+Author: HAppS LLC+Maintainer: AlexJacobson@HAppS.org+Stability: experimental+Synopsis: Marshalling Haskell values to/from XML+Description:+ Marshalling Haskell values to/from XML.+Category: Xml+Tested-With: GHC==6.6.1+Build-Depends: base, mtl, template-haskell, syb-with-class, HaXml+Exposed-modules:+ Xml.DeriveAll+ Xml.Xml+ Xml.HaXml+Other-modules:+ Xml.Base+ Xml.Instances+ Xml.PrintParse+Extensions: UndecidableInstances, OverlappingInstances, Rank2Types,+ TemplateHaskell, FlexibleInstances+GHC-Options: -Wall -fno-warn-orphans -fno-warn-missing-signatures+