-- | The class 'Haskell2Xml' is a replacement for Read and Show: it provides
--   textual conversions (to and from an XML representation) for your
--   Haskell data values.  Use the tool
--   DrIFT to derive this class for your own datatypes, then
--   include this module where you want to use the facilities.
--
--   The methods 'toContents' and 'fromContents' convert a value to and from
--   a generic internal representation of an XML document /without/ a DTD.
--   The functions 'toXml' and 'fromXml' convert a value to and from a generic
--   internal representation of an XML document /including/ a DTD.
--   The functions 'readXml' and 'showXml' convert to and from Strings.
--   The functions 'fReadXml' and 'fWriteXml' do the conversion to and from
--   the given filenames.
--   The functions 'hGetXml' and 'hPutXml' do the conversion to and from
--   the given file handles.
--   (See the type signatures.)

module Text.XML.HaXml.Haskell2Xml
  ( -- * Re-export the entire set of XML type definitions
    module Text.XML.HaXml.Types
  -- * The class Haskell2Xml
  , Haskell2Xml(..)
  -- ** Conversion functions
  , toXml, toDTD, fromXml
  , readXml, showXml
  -- ** IO conversion functions
  , fReadXml, fWriteXml
  , hGetXml,  hPutXml
  -- * Auxiliary types
  , HType(..)
  , Constr(..)
  -- Convenience functions
  , mkElem , mkElemC
  , showConstr
  , isPrefixOf
  ) where

import IO

import Text.XML.HaXml.Types
import Text.XML.HaXml.Parse (xmlParse)
import Text.PrettyPrint.HughesPJ (render)
import qualified Text.XML.HaXml.Pretty as PP
import List(intersperse,isPrefixOf,isSuffixOf,partition)
import Char (ord)

-- | A concrete representation of any Haskell type.
data HType =
      Maybe HType
    | List HType
    | Tuple [HType]
    | Prim String String	-- ^ separate Haskell name and Xml name
    | String
    | Defined String [HType] [Constr]
	-- ^ A user-defined type has a name, a sequence of type variables,
	--   and a set of constructors.
    deriving (Show)

instance Eq HType where
    (Maybe x)  == (Maybe y)  =  x==y
    (List x)   == (List y)   =  x==y
    (Tuple xs) == (Tuple ys) =  xs==ys
    (Prim x _) == (Prim y _) =  x==y
    String     == String     =  True
    (Defined n xs _) == (Defined m ys _)  =  n==m && xs==ys
    _          == _          =  False

-- | A concrete representation of any user-defined Haskell constructor.
--   The constructor has a name, and a sequence of component types.  The
--   first sequence of types represents the minimum set of free type
--   variables occurring in the (second) list of real component types.
data Constr = Constr String [HType] [HType]
    deriving (Eq,Show)

attval :: (Read a) => AttValue -> a
attval (AttValue [Left s]) = read s

mkAttr :: String -> String -> Attribute
mkAttr n v = (n, AttValue [Left v])

atoi :: String -> Int
atoi = foldl (\x y-> x*10 + ord y - ord '0') 0

atoI :: String -> Integer
atoI = foldl (\x y-> x*10 + toInteger (ord y) - toInteger (ord '0')) 0

-- | A class to convert any Haskell value to and from an XML representation.
class Haskell2Xml a where
    -- | Determine the type of the Haskell value (to create a DTD).
    toHType      :: a -> HType
    -- | Convert the Haskell value to a generic XML value.
    toContents   :: a -> [Content]
    -- | Parse a Haskell value from a generic XML representation, returning
    --   the value and the remainder of the XML.
    fromContents :: [Content] -> (a,[Content])

    -- | This function is a dummy for most types: it is used /only/ in
    --   the Char instance for coercing lists of Char into String.
    xToChar      :: a -> Char
    xToChar       = error "Haskell2Xml.xToChar used in error"
    -- | This function is a dummy for most types: it is used /only/ in
    --   the Char instance for coercing lists of Char into String.
    xFromChar    :: Char -> a
    xFromChar     = error "Haskell2Xml.xFromChar used in error"

instance Haskell2Xml Bool where
    toHType   _    = Prim "Bool" "bool"
    toContents b   = [CElem (Elem "bool" [mkAttr "value" (show b)] [])]
    fromContents (CElem (Elem "bool" [("value",b)] []):cs) = (attval b, cs)
    fromContents (_:cs) = fromContents cs

instance Haskell2Xml Int where
    toHType   _    = Prim "Int" "int"
    toContents i   = [CElem (Elem "int" [mkAttr "value" (show i)] [])]
    fromContents (CElem (Elem "int" [("value",(AttValue [Left s]))] []):cs)
                   = (atoi s, cs)
    fromContents (_:cs) = fromContents cs

instance Haskell2Xml Integer where
    toHType   _    = Prim "Integer" "integer"
    toContents i   = [CElem (Elem "integer" [mkAttr "value" (show i)] [])]
    fromContents (CElem (Elem "integer" [("value",(AttValue [Left s]))] []):cs)
                   = (atoI s, cs)
    fromContents (_:cs) = fromContents cs

instance Haskell2Xml Float where
    toHType   _    = Prim "Float" "float"
    toContents i   = [CElem (Elem "float" [mkAttr "value" (show i)] [])]
    fromContents (CElem (Elem "float" [("value",(AttValue [Left s]))] []):cs)
                   = (read s, cs)
    fromContents (_:cs) = fromContents cs

instance Haskell2Xml Double where
    toHType   _    = Prim "Double" "double"
    toContents i   = [CElem (Elem "double" [mkAttr "value" (show i)] [])]
    fromContents (CElem (Elem "double" [("value",(AttValue [Left s]))] []):cs)
                   = (read s, cs)
    fromContents (_:cs) = fromContents cs

instance Haskell2Xml Char where
    -- NOT in a string
    toHType   _    = Prim "Char" "char"
    toContents c   = [CElem (Elem "char" [mkAttr "value" [c]] [])]
    fromContents (CElem (Elem "char" [("value",(AttValue [Left [c]]))] []):cs) = (c, cs)
    fromContents (_:cs) = fromContents cs

    -- Only defined for Char and no other types:
    xToChar   = id
    xFromChar = id

instance Haskell2Xml a => Haskell2Xml [a] where
    toHType xs     = case toHType x of
                       (Prim "Char" _) -> String
                       _ -> List (toHType x)
                   where   (x:_) = xs
    toContents xs  = case toHType x of
                       (Prim "Char" _) ->
                            [mkElem "string" [CString False (map xToChar xs)]]
                       _ -> [mkElem xs (concatMap toContents xs)]
                   where   (x:_) = xs
    fromContents (CString _ s:cs) =
                   (map xFromChar s,cs)
    fromContents (CElem (Elem _ [] [CString _ s]):cs) =
                   (map xFromChar s,cs) --fromContents cs 
    fromContents (CElem (Elem _ [] xs):cs) =
                   (fst (scanElements xs), cs)
                   where
                 --scanElements :: Haskell2Xml a => [Content] -> ([a],[Content])
                   scanElements [] = ([],[])
                   scanElements els =
                     (\(x,els0)-> (\(xs,els1)-> (x:xs,els1))
                                  (scanElements els0))
                       (fromContents els)
                   --let (x,els0)  = fromContents els
                   --    (xs,els1) = scanElements els0
                   --in (x:xs, els1) 

instance (Haskell2Xml a, Haskell2Xml b) => Haskell2Xml (a,b) where
    toHType p        = Tuple [toHType a, toHType b]   where   (a,b) = p
    toContents (a,b) = toContents a ++ toContents b
    fromContents cs  = --let  (x,cs1) = fromContents cs
                       --     (y,cs2) = fromContents cs1
                       --in ((x,y),cs2)
                       (\(x,cs1)-> (\(y,cs2)-> ((x,y),cs2)) (fromContents cs1))
                         (fromContents cs)

instance (Haskell2Xml a) => Haskell2Xml (Maybe a) where
    toHType m      = Maybe (toHType x)   where   (Just x) = m
    toContents m   = [mkElem m (maybe [] toContents m)]
    fromContents (CElem (Elem _ [] []):cs) =
                     (Nothing,cs)
    fromContents (CElem (Elem _ [] cs0):cs) =
                   --let (x,[]) = fromContents cs0 in (Just x,cs)
                     (\(x,[])-> (Just x, cs)) (fromContents cs0)

instance (Haskell2Xml a, Haskell2Xml b) => Haskell2Xml (Either a b) where
    toHType m  = Defined "Either" [hx, hy]
                         [Constr "Left" [hx] [hx] ,Constr "Right" [hy] [hy]]
               where   (Left x)  = m
                       (Right y) = m
                       hx = toHType x
                       hy = toHType y
    fromContents (CElem (Elem constr [] cs):etc)
        | "Left" `isPrefixOf` constr =
            (\(aa,_)-> (Left aa, etc)) (fromContents cs)
        | "Right" `isPrefixOf` constr =
            (\(ab,_)-> (Right ab, etc)) (fromContents cs)
    toContents v@(Left aa) =
        [mkElemC (showConstr 0 (toHType v)) (toContents aa)]
    toContents v@(Right ab) =
        [mkElemC (showConstr 1 (toHType v)) (toContents ab)]

instance Haskell2Xml () where
    toHType _      = Prim "unit" "unit"
    toContents ()  = [CElem (Elem "unit" [] [])]
    fromContents (CElem (Elem "unit" [] []):cs) = ((),cs)  

mkElem x cs  = CElem (Elem (flat (toHType x) "") [] cs)
mkElemC x cs = CElem (Elem x [] cs)

-- | 'toDTD' converts a concrete representation of the Haskell type of
--   a value (obtained by the method 'toHType') into a real DocTypeDecl.
--   It ensures that PERefs are defined before they are used, and that no
--   element or attribute-list is declared more than once.
toDTD :: HType -> DocTypeDecl
toDTD ht =
  DTD (toplevel ht) Nothing (macrosFirst (reverse (h2d True [] [] [ht])))
  where
    macrosFirst :: [MarkupDecl] -> [MarkupDecl]
    macrosFirst decls = concat [p, p'] where (p, p') = partition f decls
                                             f (Entity _) = True
                                             f _ = False
    toplevel ht@(Defined _ _ _) = flat ht "-XML"
    toplevel ht@_               = flat ht ""
    c0 = False
    h2d :: Bool -> [HType] -> [Constr] -> [HType] -> [MarkupDecl]
    -- toplevel?   history    history   remainingwork     result
    h2d c history chist []       = []
    h2d c history chist (ht:hts) =
      if ht `elem` history then h2d c0 history chist hts
      else
        case ht of
          Maybe ht0  -> declelem ht: h2d c0 (ht:history) chist (ht0:hts)
          List ht0   -> declelem ht: h2d c0 (ht:history) chist (ht0:hts)
          Tuple hts0 -> (c ? (declelem ht:))
                                     (h2d c0 history chist (hts0++hts))
          Prim s t   -> declprim ht ++ h2d c0 (ht:history) chist hts
          String     -> declstring:    h2d c0 (ht:history) chist hts
          Defined s _ cs ->
               let hts0 = concatMap grab cs in
               (c ? (decltopelem ht:)) (declmacro ht chist)
               ++ h2d c0 (ht:history) (cs++chist) (hts0++hts)
    declelem ht =
      Element (ElementDecl (flat ht "") (ContentSpec (outerHtExpr ht)))
    decltopelem ht =	-- hack to avoid peref at toplevel
      Element (ElementDecl (flat ht "-XML") (ContentSpec (innerHtExpr ht None)))
    declmacro ht@(Defined _ _ cs) chist =
      Entity (EntityPEDecl (PEDecl (flat ht "") (PEDefEntityValue ev))):
      concatMap (declConstr chist) cs
      where ev = EntityValue [EVString (render (PP.cp (outerHtExpr ht)))]
    declConstr chist c@(Constr s fv hts)
      | c `notElem` chist =
          [Element (ElementDecl (cflat c "") (ContentSpec (constrHtExpr c)))]
      | otherwise = []
    declprim (Prim s t) =
      [ Element (ElementDecl t EMPTY)
      , AttList (AttListDecl t [AttDef "value" StringType REQUIRED])]
    declstring =
      Element (ElementDecl "string" (Mixed PCDATA))
    grab (Constr _ _ hts) = hts

(?) :: Bool -> (a->a) -> (a->a)
b ? f | b     = f
      | not b = id

flat :: HType -> ShowS
flat (Maybe ht)       = showString "maybe-" . flat ht
flat (List ht)        = showString "list-" . flat ht
flat (Tuple hts)      = showString "tuple" . shows (length hts) .
                        showChar '-' .
                        foldr1 (.) (intersperse (showChar '-') (map flat hts))
flat (Prim s t)       = showString t
flat String           = showString "string"
flat (Defined s fv _) = showString s . ((length fv > 0) ? (showChar '-')) .
                        foldr (.) id (intersperse (showChar '-') (map flat fv))
cflat :: Constr -> ShowS
cflat (Constr s fv _) = showString s . ((length fv > 0) ? (showChar '-')) .
                        foldr (.) id (intersperse (showChar '-') (map flat fv))

outerHtExpr :: HType -> CP
outerHtExpr (Maybe ht)      = innerHtExpr ht Query
outerHtExpr (List ht)       = innerHtExpr ht Star
outerHtExpr (Defined s fv cs) =
    Choice (map (\c->TagName (cflat c "") None) cs) None
outerHtExpr ht              = innerHtExpr ht None

innerHtExpr :: HType -> Modifier -> CP
innerHtExpr (Prim s t)  m = TagName t m
innerHtExpr (Tuple hts) m = Seq (map (\c-> innerHtExpr c None) hts) m
innerHtExpr ht@(Defined s hts cs) m = -- CPPE (flat ht "") (outerHtExpr ht)
                                      TagName ('%': flat ht ";") m
							--  ***HACK!!!***
innerHtExpr ht m = TagName (flat ht "") m

constrHtExpr (Constr s fv [])  = TagName "EMPTY" None	--  ***HACK!!!***
constrHtExpr (Constr s fv hts) = innerHtExpr (Tuple hts) None

---------------------------
-- Exported user functions.
---------------------------

-- | Convert any Haskell value to an XML document, including both DTD and
--   content.
toXml :: Haskell2Xml a => a -> Document
toXml value =
  let ht = toHType value in
  Document (Prolog Nothing [] (Just (toDTD ht)) [])
           emptyST
           (case (ht, toContents value) of
             (Tuple _, cs) -> (Elem (flat ht "") [] cs)
             (Defined _ _ _, cs) -> (Elem (flat ht "-XML") [] cs)
             (_,[CElem e]) -> e )
           []

-- | Read a Haskell value from an XML document, ignoring the DTD and
--   using the Haskell result type to determine how to parse it.
fromXml :: Haskell2Xml a => Document -> a
fromXml (Document _ _ e@(Elem n _ cs) _)
  | "tuple" `isPrefixOf` n = fst (fromContents cs)
  | "-XML"  `isSuffixOf` n = fst (fromContents cs)
  | otherwise = fst (fromContents [CElem e])

-- | Convert an XML document encoded as a String, into a Haskell value.
readXml :: Haskell2Xml a => String -> Maybe a
readXml = Just . fromXml . xmlParse "string input"
-- | Convert a Haskell value to an XML document, encoded as a String.
showXml :: Haskell2Xml a => a -> String
showXml = render . PP.document . toXml

-- | Read a Haskell value from an XML document stored in a file.
fReadXml  :: Haskell2Xml a => FilePath -> IO a
fReadXml fp = do
    f <- openFile fp ReadMode 
    content <- hGetContents f
    --hClose f
    return (fromXml (xmlParse fp content))

-- | Write a Haskell value to the given file as an XML document.
fWriteXml :: Haskell2Xml a => FilePath -> a -> IO ()
fWriteXml fp v = do
    f <- openFile fp WriteMode 
    (hPutStrLn f . render . PP.document . toXml) v
    hClose f

-- | Read a Haskell value from an XML document transmitted through the
--   given 'Handle'.
hGetXml  :: Haskell2Xml a => Handle -> IO a
hGetXml f = do
    content <- hGetContents f
    return (fromXml (xmlParse "file handle" content))

-- | Write a Haskell value to the given 'Handle' as an XML document.
hPutXml :: Haskell2Xml a => Handle -> a -> IO ()
hPutXml f v = (hPutStrLn f . render . PP.document . toXml) v

showConstr n (Defined _ _ cs) = cflat (cs!!n) ""
showConstr n _ = error "no constructors for builtin types"

-- END
