-- | The class 'Haskell2Xml' is a replacement for Read and Show: it provides
-- textual conversions (to and from an XML representation) for your
-- Haskell data values. Use the tool
-- DrIFT to derive this class for your own datatypes, then
-- include this module where you want to use the facilities.
--
-- The methods 'toContents' and 'fromContents' convert a value to and from
-- a generic internal representation of an XML document /without/ a DTD.
-- The functions 'toXml' and 'fromXml' convert a value to and from a generic
-- internal representation of an XML document /including/ a DTD.
-- The functions 'readXml' and 'showXml' convert to and from Strings.
-- The functions 'fReadXml' and 'fWriteXml' do the conversion to and from
-- the given filenames.
-- The functions 'hGetXml' and 'hPutXml' do the conversion to and from
-- the given file handles.
-- (See the type signatures.)
module Text.XML.HaXml.Haskell2Xml
( -- * Re-export the entire set of XML type definitions
module Text.XML.HaXml.Types
-- * The class Haskell2Xml
, Haskell2Xml(..)
-- ** Conversion functions
, toXml, toDTD, fromXml
, readXml, showXml
-- ** IO conversion functions
, fReadXml, fWriteXml
, hGetXml, hPutXml
-- * Auxiliary types
, HType(..)
, Constr(..)
-- Convenience functions
, mkElem , mkElemC
, showConstr
, isPrefixOf
) where
import IO
import Text.XML.HaXml.Types
import Text.XML.HaXml.Parse (xmlParse)
import Text.PrettyPrint.HughesPJ (render)
import qualified Text.XML.HaXml.Pretty as PP
import List(intersperse,isPrefixOf,isSuffixOf,partition)
import Char (ord)
-- | A concrete representation of any Haskell type.
data HType =
Maybe HType
| List HType
| Tuple [HType]
| Prim String String -- ^ separate Haskell name and Xml name
| String
| Defined String [HType] [Constr]
-- ^ A user-defined type has a name, a sequence of type variables,
-- and a set of constructors.
deriving (Show)
instance Eq HType where
(Maybe x) == (Maybe y) = x==y
(List x) == (List y) = x==y
(Tuple xs) == (Tuple ys) = xs==ys
(Prim x _) == (Prim y _) = x==y
String == String = True
(Defined n xs _) == (Defined m ys _) = n==m && xs==ys
_ == _ = False
-- | A concrete representation of any user-defined Haskell constructor.
-- The constructor has a name, and a sequence of component types. The
-- first sequence of types represents the minimum set of free type
-- variables occurring in the (second) list of real component types.
data Constr = Constr String [HType] [HType]
deriving (Eq,Show)
attval :: (Read a) => AttValue -> a
attval (AttValue v) = read (concatMap decode v)
where
decode (Left v) = v
decode (Right (RefEntity ent)) = "&"++ent++";"
decode (Right (RefChar cref)) = "&"++show cref++";"
mkAttr :: String -> String -> Attribute
mkAttr n v = (n, AttValue [Left v])
atoi :: String -> Int
atoi = foldl (\x y-> x*10 + ord y - ord '0') 0
atoI :: String -> Integer
atoI = foldl (\x y-> x*10 + toInteger (ord y) - toInteger (ord '0')) 0
-- | A class to convert any Haskell value to and from an XML representation.
class Haskell2Xml a where
-- | Determine the type of the Haskell value (to create a DTD).
toHType :: a -> HType
-- | Convert the Haskell value to a generic XML value.
toContents :: a -> [Content]
-- | Parse a Haskell value from a generic XML representation, returning
-- the value and the remainder of the XML.
fromContents :: [Content] -> (a,[Content])
-- | This function is a dummy for most types: it is used /only/ in
-- the Char instance for coercing lists of Char into String.
xToChar :: a -> Char
xToChar = error "Haskell2Xml.xToChar used in error"
-- | This function is a dummy for most types: it is used /only/ in
-- the Char instance for coercing lists of Char into String.
xFromChar :: Char -> a
xFromChar = error "Haskell2Xml.xFromChar used in error"
instance Haskell2Xml Bool where
toHType _ = Prim "Bool" "bool"
toContents b = [CElem (Elem "bool" [mkAttr "value" (show b)] [])]
fromContents (CElem (Elem "bool" [("value",b)] []):cs) = (attval b, cs)
fromContents (_:cs) = fromContents cs
instance Haskell2Xml Int where
toHType _ = Prim "Int" "int"
toContents i = [CElem (Elem "int" [mkAttr "value" (show i)] [])]
fromContents (CElem (Elem "int" [("value",(AttValue [Left s]))] []):cs)
= (atoi s, cs)
fromContents (_:cs) = fromContents cs
instance Haskell2Xml Integer where
toHType _ = Prim "Integer" "integer"
toContents i = [CElem (Elem "integer" [mkAttr "value" (show i)] [])]
fromContents (CElem (Elem "integer" [("value",(AttValue [Left s]))] []):cs)
= (atoI s, cs)
fromContents (_:cs) = fromContents cs
instance Haskell2Xml Float where
toHType _ = Prim "Float" "float"
toContents i = [CElem (Elem "float" [mkAttr "value" (show i)] [])]
fromContents (CElem (Elem "float" [("value",(AttValue [Left s]))] []):cs)
= (read s, cs)
fromContents (_:cs) = fromContents cs
instance Haskell2Xml Double where
toHType _ = Prim "Double" "double"
toContents i = [CElem (Elem "double" [mkAttr "value" (show i)] [])]
fromContents (CElem (Elem "double" [("value",(AttValue [Left s]))] []):cs)
= (read s, cs)
fromContents (_:cs) = fromContents cs
instance Haskell2Xml Char where
-- NOT in a string
toHType _ = Prim "Char" "char"
toContents c = [CElem (Elem "char" [mkAttr "value" [c]] [])]
fromContents (CElem (Elem "char" [("value",(AttValue [Left [c]]))] []):cs) = (c, cs)
fromContents (_:cs) = fromContents cs
-- Only defined for Char and no other types:
xToChar = id
xFromChar = id
instance Haskell2Xml a => Haskell2Xml [a] where
toHType xs = case toHType x of
(Prim "Char" _) -> String
_ -> List (toHType x)
where (x:_) = xs
toContents xs = case toHType x of
(Prim "Char" _) ->
[mkElem "string" [CString False (map xToChar xs)]]
_ -> [mkElem xs (concatMap toContents xs)]
where (x:_) = xs
fromContents (CString _ s:cs) =
(map xFromChar s,cs)
fromContents (CElem (Elem _ [] [CString _ s]):cs) =
(map xFromChar s,cs) --fromContents cs
fromContents (CElem (Elem _ [] xs):cs) =
(fst (scanElements xs), cs)
where
--scanElements :: Haskell2Xml a => [Content] -> ([a],[Content])
scanElements [] = ([],[])
scanElements els =
(\(x,els0)-> (\(xs,els1)-> (x:xs,els1))
(scanElements els0))
(fromContents els)
--let (x,els0) = fromContents els
-- (xs,els1) = scanElements els0
--in (x:xs, els1)
instance (Haskell2Xml a, Haskell2Xml b) => Haskell2Xml (a,b) where
toHType p = Tuple [toHType a, toHType b] where (a,b) = p
toContents (a,b) = toContents a ++ toContents b
fromContents cs = --let (x,cs1) = fromContents cs
-- (y,cs2) = fromContents cs1
--in ((x,y),cs2)
(\(x,cs1)-> (\(y,cs2)-> ((x,y),cs2)) (fromContents cs1))
(fromContents cs)
instance (Haskell2Xml a) => Haskell2Xml (Maybe a) where
toHType m = Maybe (toHType x) where (Just x) = m
toContents m = [mkElem m (maybe [] toContents m)]
fromContents (CElem (Elem _ [] []):cs) =
(Nothing,cs)
fromContents (CElem (Elem _ [] cs0):cs) =
--let (x,[]) = fromContents cs0 in (Just x,cs)
(\(x,[])-> (Just x, cs)) (fromContents cs0)
instance (Haskell2Xml a, Haskell2Xml b) => Haskell2Xml (Either a b) where
toHType m = Defined "Either" [hx, hy]
[Constr "Left" [hx] [hx] ,Constr "Right" [hy] [hy]]
where (Left x) = m
(Right y) = m
hx = toHType x
hy = toHType y
fromContents (CElem (Elem constr [] cs):etc)
| "Left" `isPrefixOf` constr =
(\(aa,_)-> (Left aa, etc)) (fromContents cs)
| "Right" `isPrefixOf` constr =
(\(ab,_)-> (Right ab, etc)) (fromContents cs)
toContents v@(Left aa) =
[mkElemC (showConstr 0 (toHType v)) (toContents aa)]
toContents v@(Right ab) =
[mkElemC (showConstr 1 (toHType v)) (toContents ab)]
instance Haskell2Xml () where
toHType _ = Prim "unit" "unit"
toContents () = [CElem (Elem "unit" [] [])]
fromContents (CElem (Elem "unit" [] []):cs) = ((),cs)
mkElem x cs = CElem (Elem (flat (toHType x) "") [] cs)
mkElemC x cs = CElem (Elem x [] cs)
-- | 'toDTD' converts a concrete representation of the Haskell type of
-- a value (obtained by the method 'toHType') into a real DocTypeDecl.
-- It ensures that PERefs are defined before they are used, and that no
-- element or attribute-list is declared more than once.
toDTD :: HType -> DocTypeDecl
toDTD ht =
DTD (toplevel ht) Nothing (macrosFirst (reverse (h2d True [] [] [ht])))
where
macrosFirst :: [MarkupDecl] -> [MarkupDecl]
macrosFirst decls = concat [p, p'] where (p, p') = partition f decls
f (Entity _) = True
f _ = False
toplevel ht@(Defined _ _ _) = flat ht "-XML"
toplevel ht@_ = flat ht ""
c0 = False
h2d :: Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
-- toplevel? history history remainingwork result
h2d c history chist [] = []
h2d c history chist (ht:hts) =
if ht `elem` history then h2d c0 history chist hts
else
case ht of
Maybe ht0 -> declelem ht: h2d c0 (ht:history) chist (ht0:hts)
List ht0 -> declelem ht: h2d c0 (ht:history) chist (ht0:hts)
Tuple hts0 -> (c ? (declelem ht:))
(h2d c0 history chist (hts0++hts))
Prim s t -> declprim ht ++ h2d c0 (ht:history) chist hts
String -> declstring: h2d c0 (ht:history) chist hts
Defined s _ cs ->
let hts0 = concatMap grab cs in
(c ? (decltopelem ht:)) (declmacro ht chist)
++ h2d c0 (ht:history) (cs++chist) (hts0++hts)
declelem ht =
Element (ElementDecl (flat ht "") (ContentSpec (outerHtExpr ht)))
decltopelem ht = -- hack to avoid peref at toplevel
Element (ElementDecl (flat ht "-XML") (ContentSpec (innerHtExpr ht None)))
declmacro ht@(Defined _ _ cs) chist =
Entity (EntityPEDecl (PEDecl (flat ht "") (PEDefEntityValue ev))):
concatMap (declConstr chist) cs
where ev = EntityValue [EVString (render (PP.cp (outerHtExpr ht)))]
declConstr chist c@(Constr s fv hts)
| c `notElem` chist =
[Element (ElementDecl (cflat c "") (ContentSpec (constrHtExpr c)))]
| otherwise = []
declprim (Prim s t) =
[ Element (ElementDecl t EMPTY)
, AttList (AttListDecl t [AttDef "value" StringType REQUIRED])]
declstring =
Element (ElementDecl "string" (Mixed PCDATA))
grab (Constr _ _ hts) = hts
(?) :: Bool -> (a->a) -> (a->a)
b ? f | b = f
| not b = id
flat :: HType -> ShowS
flat (Maybe ht) = showString "maybe-" . flat ht
flat (List ht) = showString "list-" . flat ht
flat (Tuple hts) = showString "tuple" . shows (length hts) .
showChar '-' .
foldr1 (.) (intersperse (showChar '-') (map flat hts))
flat (Prim s t) = showString t
flat String = showString "string"
flat (Defined s fv _) = showString s . ((length fv > 0) ? (showChar '-')) .
foldr (.) id (intersperse (showChar '-') (map flat fv))
cflat :: Constr -> ShowS
cflat (Constr s fv _) = showString s . ((length fv > 0) ? (showChar '-')) .
foldr (.) id (intersperse (showChar '-') (map flat fv))
outerHtExpr :: HType -> CP
outerHtExpr (Maybe ht) = innerHtExpr ht Query
outerHtExpr (List ht) = innerHtExpr ht Star
outerHtExpr (Defined s fv cs) =
Choice (map (\c->TagName (cflat c "") None) cs) None
outerHtExpr ht = innerHtExpr ht None
innerHtExpr :: HType -> Modifier -> CP
innerHtExpr (Prim s t) m = TagName t m
innerHtExpr (Tuple hts) m = Seq (map (\c-> innerHtExpr c None) hts) m
innerHtExpr ht@(Defined s hts cs) m = -- CPPE (flat ht "") (outerHtExpr ht)
TagName ('%': flat ht ";") m
-- ***HACK!!!***
innerHtExpr ht m = TagName (flat ht "") m
constrHtExpr (Constr s fv []) = TagName "EMPTY" None -- ***HACK!!!***
constrHtExpr (Constr s fv hts) = innerHtExpr (Tuple hts) None
---------------------------
-- Exported user functions.
---------------------------
-- | Convert any Haskell value to an XML document, including both DTD and
-- content.
toXml :: Haskell2Xml a => a -> Document
toXml value =
let ht = toHType value in
Document (Prolog Nothing [] (Just (toDTD ht)) [])
emptyST
(case (ht, toContents value) of
(Tuple _, cs) -> (Elem (flat ht "") [] cs)
(Defined _ _ _, cs) -> (Elem (flat ht "-XML") [] cs)
(_,[CElem e]) -> e )
[]
-- | Read a Haskell value from an XML document, ignoring the DTD and
-- using the Haskell result type to determine how to parse it.
fromXml :: Haskell2Xml a => Document -> a
fromXml (Document _ _ e@(Elem n _ cs) _)
| "tuple" `isPrefixOf` n = fst (fromContents cs)
| "-XML" `isSuffixOf` n = fst (fromContents cs)
| otherwise = fst (fromContents [CElem e])
-- | Convert an XML document encoded as a String, into a Haskell value.
readXml :: Haskell2Xml a => String -> Maybe a
readXml = Just . fromXml . xmlParse "string input"
-- | Convert a Haskell value to an XML document, encoded as a String.
showXml :: Haskell2Xml a => a -> String
showXml = render . PP.document . toXml
-- | Read a Haskell value from an XML document stored in a file.
fReadXml :: Haskell2Xml a => FilePath -> IO a
fReadXml fp = do
f <- openFile fp ReadMode
content <- hGetContents f
--hClose f
return (fromXml (xmlParse fp content))
-- | Write a Haskell value to the given file as an XML document.
fWriteXml :: Haskell2Xml a => FilePath -> a -> IO ()
fWriteXml fp v = do
f <- openFile fp WriteMode
(hPutStrLn f . render . PP.document . toXml) v
hClose f
-- | Read a Haskell value from an XML document transmitted through the
-- given 'Handle'.
hGetXml :: Haskell2Xml a => Handle -> IO a
hGetXml f = do
content <- hGetContents f
return (fromXml (xmlParse "file handle" content))
-- | Write a Haskell value to the given 'Handle' as an XML document.
hPutXml :: Haskell2Xml a => Handle -> a -> IO ()
hPutXml f v = (hPutStrLn f . render . PP.document . toXml) v
showConstr n (Defined _ _ cs) = cflat (cs!!n) ""
showConstr n _ = error "no constructors for builtin types"
-- END