-- | This module provides the 'XmlContent' class and 'readXml' and 'writeXml'
-- functions that you will need if you generate a module of Haskell
-- datatype definitions from an XML DTD. Use the DtdToHaskell
-- program to generate both datatypes and instances of this class,
-- then import this module to read and write values to and from XML files.
module Text.XML.HaXml.Xml2Haskell
( -- * Reading and writing XML data into a typed Haskell representation.
readXml, showXml
, hGetXml, hPutXml
, fReadXml, fWriteXml
-- * The enabling classes.
, XmlContent(..)
, XmlAttributes(..)
, XmlAttrType(..)
-- * Parsing and printing helper functions
, choice, definite, many, fromText, toText
, List1(..), ANYContent(..)
, maybeToAttr, defaultToAttr
, definiteA, defaultA, possibleA, fromAttrToStr, toAttrFrStr
, Defaultable(..)
, str2attr, attr2str
-- * Re-exports
, Element(..), Content(..) -- from Text.Xml.HaXml.Types
, catMaybes -- from Maybe
) where
import IO
import Maybe (catMaybes)
import Char (chr)
import Text.PrettyPrint.HughesPJ (render)
import Text.XML.HaXml.Types
import Text.XML.HaXml.Pretty (document)
import Text.XML.HaXml.Parse (xmlParse)
-- | Read an XML document from a file and convert it to a fully-typed
-- Haskell value.
fReadXml :: XmlContent a => FilePath -> IO a
fReadXml fp = do
f <- ( if fp=="-" then return stdin
else openFile fp ReadMode )
x <- hGetContents f
let (Document _ _ y _) = xmlParse fp x
return (maybe (error "XML value not found") id (fst (fromElem [CElem y])))
-- | Write a fully-typed Haskell value to the given file as an XML
-- document.
fWriteXml :: XmlContent a => FilePath -> a -> IO ()
fWriteXml fp x = do
f <- ( if fp=="-" then return stdout
else openFile fp WriteMode )
hPutXml f x
hClose f
-- | Read a fully-typed XML document from a string.
readXml :: XmlContent a => String -> Maybe a
readXml s =
let (Document _ _ y _) = xmlParse "string input" s in
fst (fromElem [CElem y])
-- | Convert a fully-typed XML document to a string.
showXml :: XmlContent a => a -> String
showXml x =
case toElem x of
[CElem y] ->
(render . document) $
Document (Prolog (Just (XMLDecl "1.0" Nothing Nothing))
[] Nothing [])
emptyST y []
_ -> ""
-- | Read a fully-typed XML document from a file handle.
hGetXml :: XmlContent a => Handle -> IO a
hGetXml h = do
x <- hGetContents h
let (Document _ _ y _) = xmlParse "file handle" x
return (maybe (error "XML value not found") id (fst (fromElem [CElem y])))
-- | Write a fully-typed XML document to a file handle.
hPutXml :: XmlContent a => Handle -> a -> IO ()
hPutXml h x = do
( hPutStrLn h . render . document
. (\y-> Document (Prolog Nothing [] Nothing []) emptyST y [])
. deCont . toElem) x
where
deCont [CElem x] = x
deCont [] = error "no XML content generated"
deCont _ = error "too much XML content generated"
---- Conversion operations on generated types ----
-- | The XmlContent class promises that an XML content element can be
-- converted to and from a Haskell value.
class XmlContent a where
fromElem :: [Content] -> (Maybe a,[Content])
toElem :: a -> [Content]
-- | The XmlAttributes class promises that a list of XML tag attributes
-- can be converted to and from a Haskell value.
class XmlAttributes a where
fromAttrs :: [Attribute] -> a
toAttrs :: a -> [Attribute]
-- | The XmlAttrType class promises that an attribute taking an XML enumerated
-- type can be converted to and from a Haskell value.
class XmlAttrType a where
fromAttrToTyp :: String -> Attribute -> Maybe a
toAttrFrTyp :: String -> a -> Maybe Attribute
---- Useful variants of "fromElem" ----
choice :: XmlContent a
=> (a -> b) -- constructor
-> ([Content]->(Maybe b,[Content])) -- continuation
-> [Content] -> (Maybe b,[Content])
choice cons other input =
case fromElem input of
(Just x, rest) -> (Just (cons x), rest)
(Nothing,rest) -> other input
definite :: ([Content]->(Maybe a,[Content])) -> String -> String ->
[Content] -> (a,[Content])
definite from inner tag cs =
let (m,cs0) = from cs
in case m of
Nothing -> error ("content error: expected "++inner++" inside <"
++tag++"> element\n")
(Just a)-> (a,cs0)
many :: ([Content]->(Maybe a,[Content])) -> [Content] -> ([a], [Content])
many from [] = ([],[])
many from cs =
let (m,cs0) = from cs
in case m of
Nothing -> ([],cs0)
(Just a)-> let (as,cs1) = many from cs0
in (a:as, cs1)
fromText :: [Content] -> (Maybe String, [Content])
fromText c =
case c of
(CString _ s: cs) -> more s cs
(CRef (RefChar s): cs) -> more ("&#"++show s++";") cs
(CRef (RefEntity s): cs) -> more ('&':s++";") cs
(CMisc _: cs) -> more "" cs
[] -> (Just "",[])
_ -> (Nothing,c)
where more s cs = case fromText cs of
(Nothing, _) -> (Just s, cs)
(Just s', cs') -> (Just (s++s'), cs')
toText :: String -> [Content]
toText s = [CString False s]
---- Useful auxiliaries for "fromAttributes" ----
-- | If an attribute is defaultable, then it either takes the default
-- value (which is omitted from the output), or a non-default value
-- (which obviously must be printed).
data Defaultable a = Default a | NonDefault a deriving (Eq,Show)
searchMaybe :: (a -> Maybe b) -> [a] -> Maybe b
searchMaybe f [] = Nothing
searchMaybe f (x:xs) =
let fx = f x in
case fx of
Nothing -> searchMaybe f xs
(Just _) -> fx
maybeToAttr :: (String->a->Maybe Attribute) -> String -> Maybe a
-> Maybe Attribute
maybeToAttr to n Nothing = Nothing
maybeToAttr to n (Just v) = to n v
defaultToAttr :: (String->a->Maybe Attribute) -> String -> Defaultable a
-> Maybe Attribute
defaultToAttr to n (Default v) = Nothing
defaultToAttr to n (NonDefault v) = to n v
definiteA :: (String->Attribute->Maybe a) -> String -> String
-> [Attribute] -> a
definiteA from tag at as =
case searchMaybe (from at) as of
Nothing -> error ("missing attribute "++at++" in tag <"++tag++">")
(Just a) -> a
defaultA :: (String->Attribute->Maybe a) -> a -> String
-> [Attribute] -> Defaultable a
defaultA from def at as =
case searchMaybe (from at) as of
Nothing -> Default def
(Just a) -> NonDefault a
possibleA :: (String->Attribute->Maybe a) -> String -> [Attribute] -> Maybe a
possibleA from at as = searchMaybe (from at) as
fromAttrToStr :: String -> Attribute -> Maybe String
fromAttrToStr n (n0,v)
| n == n0 = Just (attr2str v)
| otherwise = Nothing
toAttrFrStr :: String -> String -> Maybe Attribute
toAttrFrStr n v = Just (n, str2attr v)
str2attr :: String -> AttValue
str2attr s =
let f s =
let (l,r) = span (\c-> not (elem c "\"&<>'")) s
in if null r then [Left l]
else Left l: Right (g (head r)): f (tail r)
g '"' = RefEntity "quot"
g '&' = RefEntity "amp"
g '<' = RefEntity "lt"
g '>' = RefEntity "gt"
g '\'' = RefEntity "apos"
in AttValue (f s)
attr2str :: AttValue -> String -- really needs symbol table
attr2str (AttValue xs) =
let f (Left s) = s
f (Right (RefChar i)) = [chr i]
f (Right (RefEntity "quot")) = "\""
f (Right (RefEntity "amp")) = "&"
f (Right (RefEntity "lt")) = "<"
f (Right (RefEntity "gt")) = ">"
f (Right (RefEntity "apos")) = "'"
f (Right _) = "*" -- Ooops, ST needed here.
in concatMap f xs
---- New types ----
{-
data OneOf2 a b
data OneOf3 a b c
data OneOf4 a b c d
... etc are now defined (with instances) in module OneOfN.
-}
-- | A type corresponding to XML's ANY contentspec
--data ANYContent = forall a . XmlContent a => ANYContent a
data ANYContent = ANYContent deriving (Eq,Show)
-- | The List1 type represents lists with at least one element.
-- It is required for DTD content models that use + as a modifier.
data List1 a = NonEmpty [a] deriving (Eq, Show)
---- Needed instances ----
instance (XmlContent a, XmlContent b) => XmlContent (a,b) where
fromElem c0 =
case (\(a,ca)->
(\(b,cb)->
(a,b,cb))
(fromElem ca))
(fromElem c0) of
(Just x, Just y, cn) -> (Just (x,y), cn)
(_,_,_) -> (Nothing,c0)
toElem (x,y) = toElem x ++ toElem y
instance (XmlContent a, XmlContent b, XmlContent c) => XmlContent (a,b,c) where
fromElem c0 =
case (\(a,ca)->
(\(b,cb)->
(\(c,cc)->
(a,b,c,cc))
(fromElem cb))
(fromElem ca))
(fromElem c0) of
(Just x, Just y, Just z,cn) -> (Just (x,y,z), cn)
(_,_,_,_) -> (Nothing,c0)
toElem (x,y,z) = toElem x ++ toElem y ++ toElem z
instance (XmlContent a) => XmlContent [a] where
fromElem c0 = (\(a,cn)-> (Just a,cn)) (many fromElem c0)
toElem xs = concatMap toElem xs
instance (XmlContent a) => XmlContent (Maybe a) where
fromElem c0 =
case fromElem c0 of
(Just x, cn) -> (Just (Just x), cn)
(Nothing,cn) -> (Just Nothing, cn)
toElem (Just x) = toElem x
toElem Nothing = [] -- this clause not actually required
instance (XmlContent a) => XmlContent (List1 a) where
fromElem c0 =
case many fromElem c0 of
([], _) -> (Nothing, c0)
(xs, cn) -> (Just (NonEmpty xs), cn)
toElem (NonEmpty xs) = concatMap toElem xs
instance XmlContent ANYContent where
fromElem c0 = (Just ANYContent, [])
toElem ANYContent = []
{-
instance (XmlContent a, XmlContent b) => XmlContent (OneOf2 a b) where
fromElem c0 =
case fromElem c0 of
(Just x, cn) -> (Just (OneOfTwo x), cn)
(Nothing,cn) ->
case fromElem c0 of
(Just y, cn) -> (Just (TwoOfTwo y), cn)
(Nothing,cn) -> (Nothing, c0)
toElem (OneOfTwo x) = toElem x
toElem (TwoOfTwo y) = toElem y
instance (XmlContent a, XmlContent b, XmlContent c) =>
XmlContent (OneOf3 a b c) where
fromElem c0 =
case fromElem c0 of
(Just x, cn) -> (Just (OneOfThree x), cn)
(Nothing,cn) ->
case fromElem c0 of
(Just y, cn) -> (Just (TwoOfThree y), cn)
(Nothing,cn) ->
case fromElem c0 of
(Just z, cn) -> (Just (ThreeOfThree z), cn)
(Nothing,cn) -> (Nothing, c0)
toElem (OneOfThree x) = toElem x
toElem (TwoOfThree y) = toElem y
toElem (ThreeOfThree z) = toElem z
instance (XmlContent a, XmlContent b, XmlContent c, XmlContent d) =>
XmlContent (OneOf4 a b c d) where
fromElem c0 =
case fromElem c0 of
(Just x, cn) -> (Just (OneOfFour x), cn)
(Nothing,cn) ->
case fromElem c0 of
(Just y, cn) -> (Just (TwoOfFour y), cn)
(Nothing,cn) ->
case fromElem c0 of
(Just z, cn) -> (Just (ThreeOfFour z), cn)
(Nothing,cn) ->
case fromElem c0 of
(Just t, cn) -> (Just (FourOfFour t), cn)
(Nothing,cn) -> (Nothing, c0)
toElem (OneOfFour x) = toElem x
toElem (TwoOfFour y) = toElem y
toElem (ThreeOfFour z) = toElem z
toElem (FourOfFour t) = toElem t
-}
{-
---- Example instances (e.g. generated with DtdToHaskell) ----
data X = X Y
instance XmlContent X where
fromElem (CElem (Elem "x" as cs): rest) =
let y = (\(a,c0)-> a) (definite fromElem "x" cs)
in (Just (X y), rest)
fromElem rest = (Nothing,rest)
toElem (X y) = [CElem (Elem "x" [] (toElem y))]
data X = X [Y]
instance XmlContent X where
fromElem (CElem (Elem "x" as cs): rest) =
let ys = (\(a,c0)-> a) (many fromElem cs)
in (Just (X ys), rest)
fromElem rest = (Nothing, rest)
toElem (X ys) = [CElem (Elem "x" [] (concatMap toElem ys))]
data X = X (Maybe Y)
instance XmlContent X where
fromElem (CElem (Elem "x" as cs): rest) =
let my = (\(a,c0)-> a) (fromElem cs)
in (Just (X my), rest)
fromElem rest = (Nothing, rest)
toElem (X my) = [CElem (Elem "x" [] (maybe [] toElem my))]
data X = X [Y] (Maybe Z) T
instance XmlContent X where
fromElem (CElem (Elem "x" as cs): rest) =
let (ys,z,t) = (\(a,c0)->
(\(b,c1)->
(\(c,c2)-> (a,b,c))
(definite fromElem c1))
(fromElem c0))
(many fromElem cs)
in (Just (X ys z t), rest)
fromElem rest = (Nothing, rest)
toElem (X ys z t) = [CElem (Elem "x" [] (concatMap toElem ys ++
maybe [] toElem z ++
toElem t))]
-- <!ELEMENT x ((p?,q) | (t?,u*) | (r+,s))*>
data X = X [X_]
data X_ = X_P_Q (Maybe P) Q
| X_T_U (Maybe T) [U]
| X_R_S [R] S
instance XmlContent X_ where
fromElem c0 =
case (\(a,ca)->
(\(b,cb)->
(a,b,cb))
(fromElem ca))
(fromElem c0) of
(Nothing,Nothing,_) ->
case (\(a,ca)->
(\(b,cb)->
(a,b,cb))
(fromElem ca))
(many fromElem c0) of
(Nothing,[],_) ->
case (\(a,ca)->
(\(b,cb)->
(a,b,cb))
(many fromElem ca))
(fromElem c0) of
([],Nothing,rest) -> (Nothing, rest)
(a, Just b, rest) -> (Just (X_R_S a b), rest)
(a, b, rest) -> (Just (X_T_U a b), rest)
(a, Just b, rest) -> (Just (X_P_Q a b), rest)
toElem (X_P_Q mp q) = maybe [] toElem mp ++ toElem q
toElem (X_R_S mt us) = maybe [] toElem rs ++ concatMap toElem s
toElem (X_R_S rs s) = concatMap toElem rs ++ toElem s
---- Example instances with attributes ----
instance XmlAttributes Match_Attrs where
fromAttrs as =
Match_Attrs -- note: defaults can be handled with fromMaybe
{ opposition = definiteA fromStrAttr "match" "opposition" as
, date = definiteA fromStrAttr "match" "date" as
, location = definiteA fromAttr) "match" "location" as
, ourgoals = possibleA fromStrAttr "ourgoals" as
, theirgoals = possibleA fromStrAttr "theirgoals" as
, status = definiteA fromStrAttr "match" "status" as
}
toAttrs v = catMaybes
[ toAttrFrStr "opposition" (opposition v)
, toAttrFrStr "date" (date v)
, toAttrFrTyp "location" (location v)
, maybeA toAttrFrStr "ourgoals" (ourgoals v)
, maybeA toAttrFrStr "theirgoals" (theirgoals v)
, toAttrFrTyp "status" (status v)
]
instance XmlAttrType Location where
fromAttrToTyp n (n0,v)
| n == n0 = translate (attr2str v)
| otherwise = Nothing
where translate "VarsityCentre" = Just VarsityCentre
translate "KingsManor" = Just KingsManor
translate _ = Nothing
toAttrFrTyp n VarsityCentre = Just (n, str2attr "VarsityCentre")
toAttrFrTyp n KingsManor = Just (n, str2attr "KingsManor")
instance XmlAttrType Status where
fromAttrToTyp n (n0,v)
| n == n0 = translate (attr2str v)
| otherwise = Nothing
where translate "planned" = Just Planned
translate "played" = Just Played
translate "rescheduled" = Just Rescheduled
translate _ = Nothing
toAttrFrTyp n Planned = Just (n, str2attr "planned")
toAttrFrTyp n Played = Just (n, str2attr "played")
toAttrFrTyp n Rescheduled = Just (n, str2attr "rescheduled")
-}