-- | The class 'XmlContent' is a kind of replacement for Read and Show:
--   it provides conversions between a generic XML tree representation
--   and your own more specialised typeful Haskell data trees.
--
--   If you are starting with an XML DTD, use HaXml's tool DtdToHaskell
--   to generate both the Haskell types and the corresponding instances.
--   
--   If you are starting with a set of Haskell datatypes, use DrIFT to
--   derive instances of this class for you:
--       http:\/\/repetae.net\/john\/computer\/haskell\/DrIFT
--   and _do_not_ use the current module, but rather
--   Text.XML.HaXml.XmlContent.Haskell, for the correct matching
--   instances for standard Haskell datatypes.

module Text.XML.HaXml.XmlContent
  (
  -- * Re-export everything from Text.XML.HaXml.XmlContent.Parser.
    module Text.XML.HaXml.XmlContent.Parser
  , module Text.XML.HaXml.TypeMapping
  -- * Contains instances of the XmlContent classes,
  --   for the basic Haskell datatypes list and Maybe,
  --   intended for use with DtdToHaskell-generated datatypes.
  --   See the alternative instances in Text.XML.HaXml.XmlContent.Haskell
  --   if your datatypes originate in Haskell instead.
--  , module Text.XML.HaXml.XmlContent

  -- * Whole-document conversion functions
  , 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.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.XmlContent.Parser


------------------------------------------------------------------------

        -- probably want to write DTD separately from value, and have
        -- easy ways to combine DTD + value into a document, or write
        -- them to separate files.

-- | Read an XML document from a file and convert it to a fully-typed
--   Haskell value.
fReadXml  :: XmlContent a => FilePath -> IO a
fReadXml :: FilePath -> IO a
fReadXml FilePath
fp = do
    Handle
f <- ( if FilePath
fpFilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath
"-" 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 Prolog
_ SymTab EntityDef
_ Element Posn
y [Misc]
_) = 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']))

-- | Write a fully-typed Haskell value to the given file as an XML
--   document.
fWriteXml :: XmlContent a => FilePath -> a -> IO ()
fWriteXml :: FilePath -> a -> IO ()
fWriteXml FilePath
fp a
x = do
    Handle
f <- ( if FilePath
fpFilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath
"-" 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

-- | Write any Haskell value to the given file as an XML document,
--   using the FastPackedString interface (output will not be prettified).
fpsWriteXml :: XmlContent a => FilePath -> a -> IO ()
fpsWriteXml :: FilePath -> a -> IO ()
fpsWriteXml FilePath
fp a
x = do
    Handle
f <- ( if FilePath
fpFilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath
"-" 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

-- | Read a fully-typed XML document from a string.
readXml :: XmlContent a => String -> Either String a
readXml :: FilePath -> Either FilePath a
readXml FilePath
s =
    let (Document Prolog
_ SymTab EntityDef
_ Element Posn
y [Misc]
_) = FilePath -> FilePath -> Document Posn
xmlParse FilePath
"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 FilePath
"string input" Maybe Posn
forall a. Maybe a
Nothing)])

-- | Convert a fully-typed XML document to a string (without DTD).
showXml :: XmlContent a => Bool -> a -> String
showXml :: Bool -> a -> FilePath
showXml Bool
dtd a
x =
    case a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents a
x of
      [CElem Element ()
_ ()
_] -> (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
      [Content ()]
_ -> FilePath
""

-- | Convert a fully-typed XML document to a ByteString (without DTD).
fpsShowXml :: XmlContent a => Bool -> a -> FPS.ByteString
fpsShowXml :: Bool -> a -> ByteString
fpsShowXml Bool
dtd a
x =
    case a -> [Content ()]
forall a. XmlContent a => a -> [Content ()]
toContents a
x of
      [CElem Element ()
_ ()
_] -> (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
      [Content ()]
_ -> ByteString
FPS.empty


-- | Convert a fully-typed XML document to a string (with or without DTD).
toXml :: XmlContent a => Bool -> a -> Document ()
toXml :: Bool -> a -> Document ()
toXml Bool
dtd 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 FilePath
"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 FilePath
"empty") [] []
                 [CElem Element ()
e ()]   -> Element ()
e
                 (CElem Element ()
_ ():[Content ()]
_) -> FilePath -> Element ()
forall a. HasCallStack => FilePath -> a
error FilePath
"too many XML elements in document" )
             []

-- | Read a Haskell value from an XML document, ignoring the DTD and
--   using the Haskell result type to determine how to parse it.
fromXml :: XmlContent a => Document Posn -> Either String a
fromXml :: Document Posn -> Either FilePath a
fromXml (Document Prolog
_ SymTab EntityDef
_ e :: Element Posn
e@(Elem QName
_ [Attribute]
_ [Content Posn]
_) [Misc]
_) =
  (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 FilePath
"document" Maybe Posn
forall a. Maybe a
Nothing)])


-- | Read a fully-typed XML document from a file handle.
hGetXml :: XmlContent a => Handle -> IO a
hGetXml :: Handle -> IO a
hGetXml Handle
h = do
    FilePath
x <- Handle -> IO FilePath
hGetContents Handle
h
    let (Document Prolog
_ SymTab EntityDef
_ Element Posn
y [Misc]
_) = FilePath -> FilePath -> Document Posn
xmlParse FilePath
"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 FilePath
"file handle" Maybe Posn
forall a. Maybe a
Nothing)]))

-- | Write a fully-typed XML document to a file handle.
hPutXml :: XmlContent a => Handle -> Bool -> a -> IO ()
hPutXml :: Handle -> Bool -> a -> IO ()
hPutXml Handle
h Bool
dtd 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

-- | Write a fully-typed XML document to a file handle, using the
--   FastPackedString interface (output will not be prettified).
fpsHPutXml :: XmlContent a => Handle -> Bool -> a -> IO ()
fpsHPutXml :: Handle -> Bool -> a -> IO ()
fpsHPutXml Handle
h Bool
dtd 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


------------------------------------------------------------------------
-- Instances for all the standard basic datatypes.
-- DtdToHaskell uses only a small number of standard datatypes.
------------------------------------------------------------------------

instance XmlContent Char where
    -- NOT in a string
    toContents :: Char -> [Content ()]
toContents Char
_  = FilePath -> [Content ()]
forall a. HasCallStack => FilePath -> a
error (FilePath -> [Content ()]) -> FilePath -> [Content ()]
forall a b. (a -> b) -> a -> b
$ FilePath
"Text.XML.HaXml.XmlContent.toContents "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                            FilePath
" 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
$ FilePath
"Text.XML.HaXml.XmlContent.parseContents "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                            FilePath
" used on a Haskell Char "
    -- Only defined for Char and no other types:
    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 [a]
xs  = case a -> HType
forall a. HTypeable a => a -> HType
toHType a
x of
                       (Prim FilePath
"Char" FilePath
_) ->
                            [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) ()]
                       HType
_ -> (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   (a
x:[a]
_) = [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 [] -- for type of result only
                        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 [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 FilePath
"Char" FilePath
_) -> (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
                              HType
_ -> 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
        -- comments, PIs, etc, are skipped in the individual element parser.

instance (XmlContent a) => XmlContent (Maybe a) where
    toContents :: Maybe a -> [Content ()]
toContents 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

------------------------------------------------------------------------