module Text.XML.HaXml.XmlContent.Haskell
(
module Text.XML.HaXml.XmlContent.Parser
, toXml, fromXml
, readXml, showXml, fpsShowXml
, fReadXml, fWriteXml, fpsWriteXml
, hGetXml, hPutXml, fpsHPutXml
) where
import IO
import List (isPrefixOf, isSuffixOf)
import qualified Text.XML.HaXml.ByteStringPP as FPS (document)
import qualified Data.ByteString.Lazy.Char8 as FPS
import Text.PrettyPrint.HughesPJ (render)
import Text.ParserCombinators.Poly
import Text.XML.HaXml.Types
import Text.XML.HaXml.TypeMapping
import Text.XML.HaXml.Posn (Posn, posInNewCxt)
import Text.XML.HaXml.Pretty (document)
import Text.XML.HaXml.Parse (xmlParse)
import Text.XML.HaXml.Verbatim (Verbatim(verbatim))
import Text.XML.HaXml.XmlContent.Parser
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
y' = CElem y (posInNewCxt fp Nothing)
either fail return (fst (runParser parseContents [y']))
fWriteXml :: XmlContent a => FilePath -> a -> IO ()
fWriteXml fp x = do
f <- ( if fp=="-" then return stdout
else openFile fp WriteMode )
hPutXml f False x
hClose f
fpsWriteXml :: XmlContent a => FilePath -> a -> IO ()
fpsWriteXml fp x = do
f <- ( if fp=="-" then return stdout
else openFile fp WriteMode )
fpsHPutXml f False x
hClose f
readXml :: XmlContent a => String -> Either String a
readXml s =
let (Document _ _ y _) = xmlParse "string input" s in
fst (runParser parseContents
[CElem y (posInNewCxt "string input" Nothing)])
showXml :: XmlContent a => Bool -> a -> String
showXml dtd x =
case toContents x of
[CElem _ _] -> (render . document . toXml dtd) x
_ -> ""
fpsShowXml :: XmlContent a => Bool -> a -> FPS.ByteString
fpsShowXml dtd x =
case toContents x of
[CElem _ _] -> (FPS.document . toXml dtd) x
_ -> FPS.empty
toXml :: XmlContent a => Bool -> a -> Document ()
toXml dtd value =
let ht = toHType value in
Document (Prolog (Just (XMLDecl "1.0" Nothing Nothing))
[] (if dtd then Just (toDTD ht) else Nothing) [])
emptyST
( case (ht, toContents value) of
(Tuple _, cs) -> Elem (showHType ht "") [] cs
(Defined _ _ _, cs) -> Elem (showHType ht "-XML") [] cs
(_, [CElem e ()]) -> e )
[]
fromXml :: XmlContent a => Document Posn -> Either String a
fromXml (Document _ _ e@(Elem n _ cs) _)
| "tuple" `isPrefixOf` n = fst (runParser parseContents cs)
| "-XML" `isSuffixOf` n = fst (runParser parseContents cs)
| otherwise = fst (runParser parseContents
[CElem e (posInNewCxt "document" Nothing)])
hGetXml :: XmlContent a => Handle -> IO a
hGetXml h = do
x <- hGetContents h
let (Document _ _ y _) = xmlParse "file handle" x
either fail return
(fst (runParser parseContents
[CElem y (posInNewCxt "file handle" Nothing)]))
hPutXml :: XmlContent a => Handle -> Bool -> a -> IO ()
hPutXml h dtd x = do
(hPutStrLn h . render . document . toXml dtd) x
fpsHPutXml :: XmlContent a => Handle -> Bool -> a -> IO ()
fpsHPutXml h dtd x = do
(FPS.hPut h . FPS.document . toXml dtd) x
instance XmlContent Bool where
toContents b = [CElem (Elem "bool" [mkAttr "value" (show b)] []) ()]
parseContents = do { e <- element ["bool"] ; return (attval e) }
instance XmlContent Int where
toContents i = [CElem (Elem "int" [mkAttr "value" (show i)] []) ()]
parseContents = do { e <- element ["int"] ; return (attval e) }
instance XmlContent Integer where
toContents i = [CElem (Elem "integer" [mkAttr "value" (show i)] []) ()]
parseContents = do { e <- element ["integer"] ; return (attval e) }
instance XmlContent Float where
toContents i = [CElem (Elem "float" [mkAttr "value" (show i)] []) ()]
parseContents = do { e <- element ["float"] ; return (attval e) }
instance XmlContent Double where
toContents i = [CElem (Elem "double" [mkAttr "value" (show i)] []) ()]
parseContents = do { e <- element ["double"] ; return (attval e) }
instance XmlContent Char where
toContents c = [CElem (Elem "char" [mkAttr "value" [c]] []) ()]
parseContents = do { (Elem _ [("value",(AttValue [Left [c]]))] [])
<- element ["char"]
; return c
}
xToChar = id
xFromChar = id
instance XmlContent a => XmlContent [a] where
toContents xs = case toHType x of
(Prim "Char" _) ->
[mkElem "string" [CString True (map xToChar xs) ()]]
_ -> [mkElem xs (concatMap toContents xs)]
where (x:_) = xs
parseContents = P (\x ->
case x of
(CString _ s _:cs)
-> (Right (map xFromChar s), cs)
(CElem (Elem "string" [] [CString _ s _]) _:cs)
-> (Right (map xFromChar s), cs)
(CElem (Elem e [] xs) _:cs) | "list" `isPrefixOf` e
-> scanElements xs
where
scanElements [] = (Right [], cs)
scanElements es =
case runParser parseContents es of
(Left msg, es') -> (Left (False,msg), es')
(Right y, es') ->
case scanElements es' of
(Left msg, ds) -> (Left msg, ds)
(Right ys, ds) -> (Right (y:ys), ds)
(CElem (Elem e _ _) pos: cs)
-> (Left (False
,"Expected a <list-...>, but found a <"++e++"> at\n"
++ show pos), cs)
(CRef r pos: cs)
-> (Left (False
,"Expected a <list-...>, but found a ref "
++verbatim r++" at\n"++ show pos), cs)
(_:cs) -> ((\ (P p)-> p) parseContents) cs
[] -> (Left (False
,"Ran out of input XML whilst secondary parsing")
, [])
)
instance XmlContent () where
toContents () = [CElem (Elem "unit" [] []) ()]
parseContents = do { element ["unit"]; return () }
instance (XmlContent a) => XmlContent (Maybe a) where
toContents m = [mkElem m (maybe [] toContents m)]
parseContents = do
{ e <- elementWith (flip isPrefixOf) ["maybe"]
; case e of (Elem _ [] []) -> return Nothing
(Elem _ [] _) -> fmap Just (interior e parseContents)
}
instance (XmlContent a, XmlContent b) => XmlContent (Either a b) where
toContents v@(Left aa) =
[mkElemC (showConstr 0 (toHType v)) (toContents aa)]
toContents v@(Right ab) =
[mkElemC (showConstr 1 (toHType v)) (toContents ab)]
parseContents =
(inElementWith (flip isPrefixOf) "Left" $ fmap Left parseContents)
`onFail`
(inElementWith (flip isPrefixOf) "Right" $ fmap Right parseContents)