-- | 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 :: forall a. XmlContent a => FilePath -> IO a
fReadXml FilePath
fp = do
    Handle
f <- ( if FilePath
fpforall a. Eq a => a -> a -> Bool
==FilePath
"-" then 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' = forall i. Element i -> i -> Content i
CElem Element Posn
y (FilePath -> Maybe Posn -> Posn
posInNewCxt FilePath
fp forall a. Maybe a
Nothing)
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a, b) -> a
fst (forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser 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 :: forall a. XmlContent a => FilePath -> a -> IO ()
fWriteXml FilePath
fp a
x = do
    Handle
f <- ( if FilePath
fpforall a. Eq a => a -> a -> Bool
==FilePath
"-" then forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
           else FilePath -> IOMode -> IO Handle
openFile FilePath
fp IOMode
WriteMode )
    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 :: forall a. XmlContent a => FilePath -> a -> IO ()
fpsWriteXml FilePath
fp a
x = do
    Handle
f <- ( if FilePath
fpforall a. Eq a => a -> a -> Bool
==FilePath
"-" then forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
           else FilePath -> IOMode -> IO Handle
openFile FilePath
fp IOMode
WriteMode )
    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 :: forall a. XmlContent a => 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
    forall a b. (a, b) -> a
fst (forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser forall a. XmlContent a => XMLParser a
parseContents
                   [forall i. Element i -> i -> Content i
CElem Element Posn
y (FilePath -> Maybe Posn -> Posn
posInNewCxt FilePath
"string input" forall a. Maybe a
Nothing)])

-- | Convert a fully-typed XML document to a string (without DTD).
showXml :: XmlContent a => Bool -> a -> String
showXml :: forall a. XmlContent a => Bool -> a -> FilePath
showXml Bool
dtd a
x =
    case forall a. XmlContent a => a -> [Content ()]
toContents a
x of
      [CElem Element ()
_ ()
_] -> (Doc -> FilePath
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Document i -> Doc
document forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. XmlContent a => Bool -> a -> ByteString
fpsShowXml Bool
dtd a
x =
    case forall a. XmlContent a => a -> [Content ()]
toContents a
x of
      [CElem Element ()
_ ()
_] -> (forall i. Document i -> ByteString
FPS.document forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. XmlContent a => Bool -> a -> Document ()
toXml Bool
dtd a
value =
    let ht :: HType
ht = forall a. HTypeable a => a -> HType
toHType a
value in
    forall i.
Prolog -> SymTab EntityDef -> Element i -> [Misc] -> Document i
Document (Maybe XMLDecl -> [Misc] -> Maybe DocTypeDecl -> [Misc] -> Prolog
Prolog (forall a. a -> Maybe a
Just (FilePath -> Maybe EncodingDecl -> Maybe Bool -> XMLDecl
XMLDecl FilePath
"1.0" forall a. Maybe a
Nothing forall a. Maybe a
Nothing))
                     [] (if Bool
dtd then forall a. a -> Maybe a
Just (HType -> DocTypeDecl
toDTD HType
ht) else forall a. Maybe a
Nothing) [])
             forall a. SymTab a
emptyST
             ( case forall a. XmlContent a => a -> [Content ()]
toContents a
value of
                 []             -> forall i. QName -> [Attribute] -> [Content i] -> Element i
Elem (FilePath -> QName
N FilePath
"empty") [] []
                 [CElem Element ()
e ()]   -> Element ()
e
                 (CElem Element ()
_ ():[Content ()]
_) -> 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 :: forall a. XmlContent a => Document Posn -> Either FilePath a
fromXml (Document Prolog
_ SymTab EntityDef
_ e :: Element Posn
e@(Elem QName
_ [Attribute]
_ [Content Posn]
_) [Misc]
_) =
  forall a b. (a, b) -> a
fst (forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser forall a. XmlContent a => XMLParser a
parseContents [forall i. Element i -> i -> Content i
CElem Element Posn
e (FilePath -> Maybe Posn -> Posn
posInNewCxt FilePath
"document" forall a. Maybe a
Nothing)])


-- | Read a fully-typed XML document from a file handle.
hGetXml :: XmlContent a => Handle -> IO a
hGetXml :: forall a. XmlContent a => 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
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall (m :: * -> *) a. Monad m => a -> m a
return
           (forall a b. (a, b) -> a
fst (forall t a. Parser t a -> [t] -> (Either FilePath a, [t])
runParser forall a. XmlContent a => XMLParser a
parseContents
                           [forall i. Element i -> i -> Content i
CElem Element Posn
y (FilePath -> Maybe Posn -> Posn
posInNewCxt FilePath
"file handle" forall a. Maybe a
Nothing)]))

-- | Write a fully-typed XML document to a file handle.
hPutXml :: XmlContent a => Handle -> Bool -> a -> IO ()
hPutXml :: forall a. XmlContent a => Handle -> Bool -> a -> IO ()
hPutXml Handle
h Bool
dtd a
x = do
    (Handle -> FilePath -> IO ()
hPutStrLn Handle
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> FilePath
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Document i -> Doc
document forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. XmlContent a => Handle -> Bool -> a -> IO ()
fpsHPutXml Handle
h Bool
dtd a
x = do
    (Handle -> ByteString -> IO ()
FPS.hPut Handle
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Document i -> ByteString
FPS.document forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
_  = forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"Text.XML.HaXml.XmlContent.toContents "forall a. [a] -> [a] -> [a]
++
                            FilePath
" used on a Haskell Char"
    parseContents :: XMLParser Char
parseContents = forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail  forall a b. (a -> b) -> a -> b
$ FilePath
"Text.XML.HaXml.XmlContent.parseContents "forall a. [a] -> [a] -> [a]
++
                            FilePath
" used on a Haskell Char "
    -- Only defined for Char and no other types:
    xToChar :: Char -> Char
xToChar   = forall a. a -> a
id
    xFromChar :: Char -> Char
xFromChar = forall a. a -> a
id

instance XmlContent a => XmlContent [a] where
    toContents :: [a] -> [Content ()]
toContents [a]
xs  = case forall a. HTypeable a => a -> HType
toHType a
x of
                       (Prim FilePath
"Char" FilePath
_) ->
                            [forall i. Bool -> FilePath -> i -> Content i
CString Bool
True (forall a b. (a -> b) -> [a] -> [b]
map forall a. XmlContent a => a -> Char
xToChar [a]
xs) ()]
                       HType
_ -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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 = 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 (forall a. HTypeable a => a -> HType
toHType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ (Right [a]
x)->[a]
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
                                 (Either FilePath [a], [Content Posn])
result of
                              (Prim FilePath
"Char" FilePath
_) -> forall a b. (a -> b) -> [a] -> [b]
map forall a. XmlContent a => Char -> a
xFromChar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XMLParser FilePath
text
                              HType
_ -> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many 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  = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. XmlContent a => a -> [Content ()]
toContents Maybe a
m
    parseContents :: XMLParser (Maybe a)
parseContents = forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a. XmlContent a => XMLParser a
parseContents

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