-- | 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
  -- * 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 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 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']))

-- | 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 False x
    hClose 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 fp x = do
    f <- ( if fp=="-" then return stdout
           else openFile fp WriteMode )
    fpsHPutXml f False x
    hClose f

-- | Read a fully-typed XML document from a string.
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)])

-- | Convert a fully-typed XML document to a string (without DTD).
showXml :: XmlContent a => Bool -> a -> String
showXml dtd x =
    case toContents x of
      [CElem _ _] -> (render . document . toXml dtd) x
      _ -> ""

-- | Convert a fully-typed XML document to a ByteString (without DTD).
fpsShowXml :: XmlContent a => Bool -> a -> FPS.ByteString
fpsShowXml dtd x =
    case toContents x of
      [CElem _ _] -> (FPS.document . toXml dtd) x
      _ -> FPS.empty


-- | Convert a fully-typed XML document to a string (with or without DTD).
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 toContents value of
                 []             -> Elem "empty" [] []
                 [CElem e ()]   -> e
                 (CElem e ():_) -> error "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 _ _ e@(Elem n _ cs) _) =
  fst (runParser parseContents [CElem e (posInNewCxt "document" Nothing)])


-- | 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
    either fail return
           (fst (runParser parseContents
                           [CElem y (posInNewCxt "file handle" Nothing)]))

-- | Write a fully-typed XML document to a file handle.
hPutXml :: XmlContent a => Handle -> Bool -> a -> IO ()
hPutXml h dtd x = do
    (hPutStrLn h . render . document . toXml dtd) 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 h dtd x = do
    (FPS.hPut h . FPS.document . toXml dtd) 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 c  = error "Text.XML.HaXml.XmlContent.toContents used on a Haskell Char"
    parseContents = fail "Text.XML.HaXml.XmlContent.parseContents used on a Haskell Char "
    -- Only defined for Char and no other types:
    xToChar   = id
    xFromChar = id

instance XmlContent a => XmlContent [a] where
    toContents xs  = case toHType x of
                       (Prim "Char" _) ->
                            [CString True (map xToChar xs) ()]
                       _ -> concatMap toContents xs
                   where   (x:_) = xs
    parseContents = let (Right (x:_),_) = runParser p [] -- for type of x only
                        p = case toHType x of
                              (Prim "Char" _) -> fmap (map xFromChar) $ text
                              _ -> many parseContents
                    in p
        -- comments, PIs, etc, are skipped in the individual element parser.

instance (XmlContent a) => XmlContent (Maybe a) where
    toContents m  = maybe [] toContents m
    parseContents = optional parseContents

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