diff --git a/COPYING.txt b/COPYING.txt new file mode 100644 --- /dev/null +++ b/COPYING.txt @@ -0,0 +1,14 @@ + DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE + Version 2, December 2004 + + Copyright (C) 2010 Oscar Finnsson + + Everyone is permitted to copy and distribute verbatim or modified + copies of this license document, and changing it is allowed as long + as the name is changed. + + DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. You just DO WHAT THE FUCK YOU WANT TO. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/src/Text/XML/Generic.hs b/src/Text/XML/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Generic.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE DeriveDataTypeable, PackageImports, GADTs, RankNTypes, TypeSynonymInstances, FlexibleInstances, UndecidableInstances, TypeSynonymInstances #-} +module Text.XML.Generic ( + -- ** Decode + decodeXML, + fromXML, + -- ** Encode + encodeXML, + toXML + ) where + +import Text.XML.Light +import Data.Generics +import Data.List.Split +import Data.List +import Data.Data +import NIB.String +import Data.Maybe +import Data.Either + +import Data.Int +import Data.Word +import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.IntSet as I +import Data.Char + +import "mtl" Control.Monad.State + +-------------------------------------------------------------------------- +-- ** Decode + +decodeXML :: Data a => String -> Either String a +decodeXML xml = maybe (Left "Could not parse xml in decodeXML") fromXML (parseXMLDoc xml) + +primitiveFromXML :: (Read d, Data d) => Element -> Either String d +primitiveFromXML x = parsed + where + parsed = maybe (Left "No content.") (\c -> Right $ read $ showContent c ) getContent + getContent = listToMaybe $ elContent x + myDataType = dataTypeOf parsed + +stringFromXML :: Element -> Either String String +stringFromXML x = Right $ res + where + res = if null cont then "" else contentString $ head cont + cont = elContent x + contentString (Text (CData _ t _)) = t + contentString _ = "" + +type F a = Element -> Either String a + +fromXML :: Data d => Element -> Either String d +fromXML e = either Left fromXML'' e' + where + fromXML'' = + fromXML' + `extR` stringFromXML + `extR` (primitiveFromXML :: F Integer ) + `extR` (primitiveFromXML :: F Int) + `extR` (primitiveFromXML :: F Bool) + `extR` (primitiveFromXML :: F Word8) + `extR` (primitiveFromXML :: F Word16) + `extR` (primitiveFromXML :: F Word32) + `extR` (primitiveFromXML :: F Word64) + `extR` (primitiveFromXML :: F Int8) + `extR` (primitiveFromXML :: F Int16) + `extR` (primitiveFromXML :: F Int32) + `extR` (primitiveFromXML :: F Int64) + `extR` (primitiveFromXML :: F Double) + `extR` (primitiveFromXML :: F Float) + e' :: Either String Element + e' = if qName ( elName e) == [] + then Left $ "qName in fromXML is []. e: " ++ show e + else + if isUpper $ head $ qName $ elName e + then Right e + else + if null [e | Elem e <- elContent e] + then Left $ "elContent in e in fromXML is []. e: " ++ show e + else Right $ head [e | Elem e <- elContent e] + + + + +instance Monad (Either String) where + return v = Right v + fail s = Left s + (Left s) >>= _ = Left s + (Right v) >>= f = f v + + +fromXML' :: Data b => Element -> Either String b +fromXML' x = result + where + result = maybe (Left errorMsg) res const + res con = case dataTypeRep myDataType of + AlgRep _ -> evalStateT ( fromConstrM f con ) children + where f :: (Data a) => StateT [Element] (Either String) a + f = do es <- get + case es of [] -> lift $ Left $ "No constructor for DataType " ++ show myDataType + e' : es' -> do put es'; lift $ fromXML e' + CharRep -> maybe (Left "No content") (Right . fromConstr . (mkCharConstr myDataType)) content + where content = listToMaybe (showContent $ head $ elContent x) + NoRep -> Left $ "NoRep in fromXML' for DataType " ++ show myDataType + _ -> Left $ "This case should not occur in fromXML' for DataType " ++ show myDataType + + -- FIX! I need to sort the children in the order con needs them! + children :: [Element] + children = [e | Elem e <- elContent x] + + const :: Maybe Constr + const = readConstr myDataType qname + + errorMsg = "No Constr by name " ++ qname ++ " and DataType " ++ (show myDataType) + + qname = q + where + qname' = qName $ elName x + q = if qname' == "Tuple" + then "(" ++ replicate (-1 + length children) ',' ++ ")" + else qname' + + resType :: Either String b -> b + resType _ = error "resType" + + myDataType :: DataType + myDataType = dataTypeOf $ resType result + + +-------------------------------------------------------------------------- +-- ** Encode + +-- \ Encode a Data into a String. +-- . +-- E.g. +-- . +-- > encodeXML 54 +-- > 54 +-- +-- > encodeXML User { age = 34, name = "Pelle" } +-- > 34Pelle +-- +-- > Fullname "Pelle" "Larsson" +-- > PelleLarsson +-- +-- > encodeXML "test" +-- > test +-- +-- > encodeXML ["yes", "no"] +-- > yesno +-- +-- > encodeXML ("answer", 42) +-- > answer42 +encodeXML :: Data a => a -> String +encodeXML = showElement . toXML + +type T a = a -> Element + +-- | Serialize to XML. +toXML :: Data a => a -> Element +toXML = toXMLgeneric + `ext1Q` xmlList + `extQ` (showXmlString :: T String) + `extQ` (showXmlUnit :: T ()) + `extQ` (showXml :: T Bool) + `extQ` (showXml :: T Integer) + `extQ` (showXml :: T Int) + `extQ` (showXml :: T Char) + `extQ` (showXml :: T Word8) + `extQ` (showXml :: T Word16) + `extQ` (showXml :: T Word32) + `extQ` (showXml :: T Word64) + `extQ` (showXml :: T Int8) + `extQ` (showXml :: T Int16) + `extQ` (showXml :: T Int32) + `extQ` (showXml :: T Int64) + `extQ` (showXml :: T Double) + `extQ` (showXml :: T Float) + -- More special cases. + `extQ` (showXml :: T I.IntSet) + `extQ` (showXml :: T S.ByteString) + `extQ` (showXml :: T L.ByteString) + + +toXMLgeneric :: (Data a) => a -> Element +toXMLgeneric x = + let dtr = dataTypeRep $ dataTypeOf x + in case dtr of + AlgRep _ -> element algName $ baker $ map Elem $ gmapQ toXML x + where name = splitWhen (== '.') $ dataTypeName $ dataTypeOf x + algName = typeName x + fields :: [String] + fields = constrFields $ toConstr x + baker :: [Content] -> [Content] + baker conts = if fields == [] + then conts + else map (\(f,c) -> Elem (element f [c]) ) (zip fields conts) + _ -> error "Only AlgRep should get here!" + +typeName :: Data a =>a -> String +typeName x = name + where + n = toString $ toConstr x + name = if n `elem` ["(,)", "(,,)", "(,,,)", "(,,,,)", "(,,,,,)", "(,,,,,,)", "(,,,,,,,)"] + then "Tuple" + else n + +xmlList :: Data a => [a] -> Element +xmlList xs = Element (QName "List" Nothing Nothing) [] (map (Elem . toXML) xs) Nothing + +showXmlTuple2 :: (Data a, Data b) => (a, b) -> Element +showXmlTuple2 x = element "Tuple" [Elem $ toXML (fst x), Elem $ toXML (snd x)] + +showXmlString x = element "String" (contentText x) + +showXmlUnit x = element "Unit" [] + +showXml x = element elemName $ contentText (toString x) + where name = splitWhen (== '.') $ dataTypeName $ dataTypeOf x + elemName = last name + +element name content = + Element { + elName = QName {qName = name, qURI = Nothing, qPrefix = Nothing} + , elAttribs = [] + , elContent = content + , elLine = Nothing + } + +contentText c = [Text (CData CDataText c Nothing)] diff --git a/text-xml-generic.cabal b/text-xml-generic.cabal new file mode 100644 --- /dev/null +++ b/text-xml-generic.cabal @@ -0,0 +1,47 @@ +name: text-xml-generic +version: 0.1.1 +cabal-version: -any +build-type: Simple +license: OtherLicense +license-file: "COPYING.txt" +copyright: +maintainer: Oscar Finnsson +build-depends: base >= 4.2 && < 5, not-in-base >= 0.1.1, template-haskell, haskell98, xml >= 1.3.4, syb >= 0.1.0.2, split >= 0.1.2, containers >= 0.3, bytestring >= 0.9.1.5, mtl >= 1.1 +stability: +homepage: http://github.com/finnsson/Text.XML.Generic +package-url: +bug-reports: +synopsis: Serialize Data to XML (strings). +description: + @Text.XML.Generic@ can automatically serialize from the Data-type class to XML-strings. +category: XML +author: Oscar Finnsson +tested-with: +data-files: +data-dir: "" +extra-source-files: +extra-tmp-files: +exposed-modules: Text.XML.Generic +exposed: True +buildable: True +build-tools: +cpp-options: +cc-options: +ld-options: +pkgconfig-depends: +frameworks: +c-sources: +extensions: +extra-libraries: +extra-lib-dirs: +includes: +install-includes: +include-dirs: +hs-source-dirs: src +other-modules: +ghc-prof-options: +ghc-shared-options: +ghc-options: +hugs-options: +nhc98-options: +jhc-options: