module Text.XML.HaXml.XmlContent
(
module Text.XML.HaXml.XmlContent.Parser
, module Text.XML.HaXml.TypeMapping
, toXml, fromXml
, readXml, showXml, fpsShowXml
, fReadXml, fWriteXml, fpsWriteXml
, hGetXml, hPutXml, fpsHPutXml
) where
import System.IO
import qualified Text.XML.HaXml.ByteStringPP as FPS (document)
import qualified Data.ByteString.Lazy.Char8 as FPS
import Text.PrettyPrint.HughesPJ (render)
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.XmlContent.Parser
fReadXml :: XmlContent a => FilePath -> IO a
fReadXml :: FilePath -> IO a
fReadXml fp :: FilePath
fp = do
Handle
f <- ( if FilePath
fpFilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
=="-" then Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdin
else FilePath -> IOMode -> IO Handle
openFile FilePath
fp IOMode
ReadMode )
FilePath
x <- Handle -> IO FilePath
hGetContents Handle
f
let (Document _ _ y :: Element Posn
y _) = FilePath -> FilePath -> Document Posn
xmlParse FilePath
fp FilePath
x
y' :: Content Posn
y' = Element Posn -> Posn -> Content Posn
forall i. Element i -> i -> Content i
CElem Element Posn
y (FilePath -> Maybe Posn -> Posn
posInNewCxt FilePath
fp Maybe Posn
forall a. Maybe a
Nothing)
(FilePath -> IO a) -> (a -> IO a) -> Either FilePath a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Either FilePath a, [Content Posn]) -> Either FilePath a
forall a b. (a, b) -> a
fst (Parser (Content Posn) a
-> [Content Posn] -> (Either FilePath a, [Content Posn])
forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser Parser (Content Posn) a
forall a. XmlContent a => XMLParser a
parseContents [Content Posn
y']))
fWriteXml :: XmlContent a => FilePath -> a -> IO ()
fWriteXml :: FilePath -> a -> IO ()
fWriteXml fp :: FilePath
fp x :: a
x = do
Handle
f <- ( if FilePath
fpFilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
=="-" then Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
else FilePath -> IOMode -> IO Handle
openFile FilePath
fp IOMode
WriteMode )
Handle -> Bool -> a -> IO ()
forall a. XmlContent a => Handle -> Bool -> a -> IO ()
hPutXml Handle
f Bool
False a
x
Handle -> IO ()
hClose Handle
f
fpsWriteXml :: XmlContent a => FilePath -> a -> IO ()
fpsWriteXml :: FilePath -> a -> IO ()
fpsWriteXml fp :: FilePath
fp x :: a
x = do
Handle
f <- ( if FilePath
fpFilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
=="-" then Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
else FilePath -> IOMode -> IO Handle
openFile FilePath
fp IOMode
WriteMode )
Handle -> Bool -> a -> IO ()
forall a. XmlContent a => Handle -> Bool -> a -> IO ()
fpsHPutXml Handle
f Bool
False a
x
Handle -> IO ()
hClose Handle
f
readXml :: XmlContent a => String -> Either String a
readXml :: FilePath -> Either FilePath a
readXml s :: FilePath
s =
let (Document _ _ y :: Element Posn
y _) = FilePath -> FilePath -> Document Posn
xmlParse "string input" FilePath
s in
(Either FilePath a, [Content Posn]) -> Either FilePath a
forall a b. (a, b) -> a
fst (Parser (Content Posn) a
-> [Content Posn] -> (Either FilePath a, [Content Posn])
forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser Parser (Content Posn) a
forall a. XmlContent a => XMLParser a
parseContents
[Element Posn -> Posn -> Content Posn
forall i. Element i -> i -> Content i
CElem Element Posn
y (FilePath -> Maybe Posn -> Posn
posInNewCxt "string input" Maybe Posn
forall a. Maybe a
Nothing)])
showXml :: XmlContent a => Bool -> a -> String
showXml :: Bool -> a -> FilePath
showXml dtd :: Bool
dtd x :: a
x =
case a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents a
x of
[CElem _ _] -> (Doc -> FilePath
render (Doc -> FilePath) -> (a -> Doc) -> a -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document () -> Doc
forall i. Document i -> Doc
document (Document () -> Doc) -> (a -> Document ()) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> Document ()
forall a. XmlContent a => Bool -> a -> Document ()
toXml Bool
dtd) a
x
_ -> ""
fpsShowXml :: XmlContent a => Bool -> a -> FPS.ByteString
fpsShowXml :: Bool -> a -> ByteString
fpsShowXml dtd :: Bool
dtd x :: a
x =
case a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents a
x of
[CElem _ _] -> (Document () -> ByteString
forall i. Document i -> ByteString
FPS.document (Document () -> ByteString)
-> (a -> Document ()) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> Document ()
forall a. XmlContent a => Bool -> a -> Document ()
toXml Bool
dtd) a
x
_ -> ByteString
FPS.empty
toXml :: XmlContent a => Bool -> a -> Document ()
toXml :: Bool -> a -> Document ()
toXml dtd :: Bool
dtd value :: a
value =
let ht :: HType
ht = a -> HType
forall a. HTypeable a => a -> HType
toHType a
value in
Prolog -> SymTab EntityDef -> Element () -> [Misc] -> Document ()
forall i.
Prolog -> SymTab EntityDef -> Element i -> [Misc] -> Document i
Document (Maybe XMLDecl -> [Misc] -> Maybe DocTypeDecl -> [Misc] -> Prolog
Prolog (XMLDecl -> Maybe XMLDecl
forall a. a -> Maybe a
Just (FilePath -> Maybe EncodingDecl -> Maybe Bool -> XMLDecl
XMLDecl "1.0" Maybe EncodingDecl
forall a. Maybe a
Nothing Maybe Bool
forall a. Maybe a
Nothing))
[] (if Bool
dtd then DocTypeDecl -> Maybe DocTypeDecl
forall a. a -> Maybe a
Just (HType -> DocTypeDecl
toDTD HType
ht) else Maybe DocTypeDecl
forall a. Maybe a
Nothing) [])
SymTab EntityDef
forall a. SymTab a
emptyST
( case a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents a
value of
[] -> QName -> [Attribute] -> [Content ()] -> Element ()
forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (FilePath -> QName
N "empty") [] []
[CElem e :: Element ()
e ()] -> Element ()
e
(CElem _ ():_) -> FilePath -> Element ()
forall a. HasCallStack => FilePath -> a
error "too many XML elements in document" )
[]
fromXml :: XmlContent a => Document Posn -> Either String a
fromXml :: Document Posn -> Either FilePath a
fromXml (Document _ _ e :: Element Posn
e@(Elem _ _ _) _) =
(Either FilePath a, [Content Posn]) -> Either FilePath a
forall a b. (a, b) -> a
fst (Parser (Content Posn) a
-> [Content Posn] -> (Either FilePath a, [Content Posn])
forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser Parser (Content Posn) a
forall a. XmlContent a => XMLParser a
parseContents [Element Posn -> Posn -> Content Posn
forall i. Element i -> i -> Content i
CElem Element Posn
e (FilePath -> Maybe Posn -> Posn
posInNewCxt "document" Maybe Posn
forall a. Maybe a
Nothing)])
hGetXml :: XmlContent a => Handle -> IO a
hGetXml :: Handle -> IO a
hGetXml h :: Handle
h = do
FilePath
x <- Handle -> IO FilePath
hGetContents Handle
h
let (Document _ _ y :: Element Posn
y _) = FilePath -> FilePath -> Document Posn
xmlParse "file handle" FilePath
x
(FilePath -> IO a) -> (a -> IO a) -> Either FilePath a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
((Either FilePath a, [Content Posn]) -> Either FilePath a
forall a b. (a, b) -> a
fst (Parser (Content Posn) a
-> [Content Posn] -> (Either FilePath a, [Content Posn])
forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser Parser (Content Posn) a
forall a. XmlContent a => XMLParser a
parseContents
[Element Posn -> Posn -> Content Posn
forall i. Element i -> i -> Content i
CElem Element Posn
y (FilePath -> Maybe Posn -> Posn
posInNewCxt "file handle" Maybe Posn
forall a. Maybe a
Nothing)]))
hPutXml :: XmlContent a => Handle -> Bool -> a -> IO ()
hPutXml :: Handle -> Bool -> a -> IO ()
hPutXml h :: Handle
h dtd :: Bool
dtd x :: a
x = do
(Handle -> FilePath -> IO ()
hPutStrLn Handle
h (FilePath -> IO ()) -> (a -> FilePath) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> FilePath
render (Doc -> FilePath) -> (a -> Doc) -> a -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document () -> Doc
forall i. Document i -> Doc
document (Document () -> Doc) -> (a -> Document ()) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> Document ()
forall a. XmlContent a => Bool -> a -> Document ()
toXml Bool
dtd) a
x
fpsHPutXml :: XmlContent a => Handle -> Bool -> a -> IO ()
fpsHPutXml :: Handle -> Bool -> a -> IO ()
fpsHPutXml h :: Handle
h dtd :: Bool
dtd x :: a
x = do
(Handle -> ByteString -> IO ()
FPS.hPut Handle
h (ByteString -> IO ()) -> (a -> ByteString) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Document () -> ByteString
forall i. Document i -> ByteString
FPS.document (Document () -> ByteString)
-> (a -> Document ()) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> Document ()
forall a. XmlContent a => Bool -> a -> Document ()
toXml Bool
dtd) a
x
instance XmlContent Char where
toContents :: Char -> [Content ()]
toContents _ = FilePath -> [Content ()]
forall a. HasCallStack => FilePath -> a
error (FilePath -> [Content ()]) -> FilePath -> [Content ()]
forall a b. (a -> b) -> a -> b
$ "Text.XML.HaXml.XmlContent.toContents "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
" used on a Haskell Char"
parseContents :: XMLParser Char
parseContents = FilePath -> XMLParser Char
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> XMLParser Char) -> FilePath -> XMLParser Char
forall a b. (a -> b) -> a -> b
$ "Text.XML.HaXml.XmlContent.parseContents "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
" used on a Haskell Char "
xToChar :: Char -> Char
xToChar = Char -> Char
forall a. a -> a
id
xFromChar :: Char -> Char
xFromChar = Char -> Char
forall a. a -> a
id
instance XmlContent a => XmlContent [a] where
toContents :: [a] -> [Content ()]
toContents xs :: [a]
xs = case a -> HType
forall a. HTypeable a => a -> HType
toHType a
x of
(Prim "Char" _) ->
[Bool -> FilePath -> () -> Content ()
forall i. Bool -> FilePath -> i -> Content i
CString Bool
True ((a -> Char) -> [a] -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map a -> Char
forall a. XmlContent a => a -> Char
xToChar [a]
xs) ()]
_ -> (a -> [Content ()]) -> [a] -> [Content ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents [a]
xs
where (x :: a
x:_) = [a]
xs
parseContents :: XMLParser [a]
parseContents = let result :: (Either FilePath [a], [Content Posn])
result = XMLParser [a]
-> [Content Posn] -> (Either FilePath [a], [Content Posn])
forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser XMLParser [a]
p []
p :: XMLParser [a]
p = case (a -> HType
forall a. HTypeable a => a -> HType
toHType (a -> HType)
-> ((Either FilePath [a], [Content Posn]) -> a)
-> (Either FilePath [a], [Content Posn])
-> HType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> a
forall a. [a] -> a
head ([a] -> a)
-> ((Either FilePath [a], [Content Posn]) -> [a])
-> (Either FilePath [a], [Content Posn])
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ (Right x :: [a]
x)->[a]
x) (Either FilePath [a] -> [a])
-> ((Either FilePath [a], [Content Posn]) -> Either FilePath [a])
-> (Either FilePath [a], [Content Posn])
-> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either FilePath [a], [Content Posn]) -> Either FilePath [a]
forall a b. (a, b) -> a
fst)
(Either FilePath [a], [Content Posn])
result of
(Prim "Char" _) -> (FilePath -> [a])
-> Parser (Content Posn) FilePath -> XMLParser [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> a) -> FilePath -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Char -> a
forall a. XmlContent a => Char -> a
xFromChar) (Parser (Content Posn) FilePath -> XMLParser [a])
-> Parser (Content Posn) FilePath -> XMLParser [a]
forall a b. (a -> b) -> a -> b
$ Parser (Content Posn) FilePath
text
_ -> Parser (Content Posn) a -> XMLParser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (Content Posn) a
forall a. XmlContent a => XMLParser a
parseContents
in XMLParser [a]
p
instance (XmlContent a) => XmlContent (Maybe a) where
toContents :: Maybe a -> [Content ()]
toContents m :: Maybe a
m = [Content ()] -> (a -> [Content ()]) -> Maybe a -> [Content ()]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents Maybe a
m
parseContents :: XMLParser (Maybe a)
parseContents = Parser (Content Posn) a -> XMLParser (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser (Content Posn) a
forall a. XmlContent a => XMLParser a
parseContents