{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-}
----------------------------------------------------------------------------
-- |
-- Module      :  Text.XML.Serializer.Core
-- Copyright   :  (c) Simon Foster 2005
-- License     :  GPL version 2 (see COPYING)
-- 
-- Maintainer  :  aca01sdf@shef.ac.uk
-- Stability   :  experimental
-- Portability :  non-portable (ghc >= 6 only)
--
-- A Generic XML Serializer using HXT and the Generics package (SYB3). This new version of
-- GXS is based on type classes, and thus allows modular customization. More coming soon.
--
-- This is the core serializer, as such it is capable of doing very little, and needs propogating
-- with serialization rules. A set of basic rules can be found in Text.XML.Serializer.DefaultRules
--
-- @This file is part of HAIFA.@
--
-- @HAIFA is free software; you can redistribute it and\/or modify it under the terms of the 
-- GNU General Public License as published by the Free Software Foundation; either version 2 
-- of the License, or (at your option) any later version.@
--
-- @HAIFA is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without 
-- even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.@
--
-- @You should have received a copy of the GNU General Public License along with HAIFA; if not, 
-- write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA@
----------------------------------------------------------------------------
module Text.XML.Serializer.Core where

import Data.Generics2
import Data.Char
import Data.DynamicMap
import Data.List
import Data.Maybe
import Text.XML.HXT.Parser
import Network.URI
import Text.XML.Serializer.Datatypes
import Control.Monad.State


-- | Get the namespaces exported by an XML Hook.
getNamespaces :: InitXMLHook a => a -> [(String, URI)]
getNamespaces x = lookupDM_D nstKey $ hookDM x emptyDM

{- | Derive an XML Constructor for a data-type using SYB3 to generate the rules. Will either be based on field labels if presents or
     on internal defaults of the type being serialized.
-}


deriveXConsElem :: (Data (DictXMLData h) a, XMLNamespace a) => String -> h -> a -> XMLConstr
deriveXConsElem n = deriveXMLConstrPrim [n] Elem

deriveXConsAttr :: (Data (DictXMLData h) a, XMLNamespace a) => String -> h -> a -> XMLConstr
deriveXConsAttr n = deriveXMLConstrPrim [n] Attr


deriveXMLConstr (q::h) x = deriveXMLConstrPrim names Elem q x
  where names = if (isAlgType $ dataTypeOf ctx x) then (map showConstr $ dataTypeConstrs  $ dataTypeOf ctx x) else replicate (glength ctx x) "item"
        ctx = undefined::DictXMLData h ()

deriveXMLConstrPrim :: (Data (DictXMLData h) a, XMLNamespace a) => [String] -> (String -> Maybe URI -> FieldProp) -> h -> a -> XMLConstr
deriveXMLConstrPrim names f (q::h) x = 
      xmlConstr { xmlFields      = if (isAlgType $ dataTypeOf ctx x) then fieldElems else []
                , elementNames   = names
                , attributeNames = names
                , xmlNsURI       = namespaceURI x
                , xmlPrefix      = defaultPrefix x
                , defaultProp    = let l = map (\n -> f n (namespaceURI x)) names in
                                     case l of
                                       [] -> Nothing
                                       [x]  -> Just x
                                       y    -> Just $ Choice y
                }
  where fieldElems = if (null fields) then zipWith (\e -> \d -> fromMaybe d e) subFields subElements
                                      else (zipWith3 decideField subFields subDefault fields)
        fields = constrFields $ toConstr ctx x
        flength = glength ctx x
        ctx = undefined::DictXMLData h ()
        
        decideField sf d fn = if (d&&isJust sf) then (fromJust sf) else Elem fn (namespaceURI x)
        subConstrs = gmapQ ctx subConstr x
           where subConstr (x::a) = toXMLConstrA q x
                                    {-let dt = dataTypeOf ctx x in
                                      if (isAlgType dt) then map (toXMLConstrA q) ((map (fromConstr ctx) $ dataTypeConstrs dt)::[a])
                                                        else [toXMLConstrA q x]-}
        subFields = map defaultProp subConstrs
        subElements =  map (\c -> let es = elementNames c in
                                      case es of
                                        []  -> Elem "item" Nothing
                                        [x] -> Elem x (xmlNsURI c)
                                        y   -> Choice $ map (\x -> Elem x (xmlNsURI c)) y) subConstrs
        subDefault = map forceDefault subConstrs

-- | Get all the possible XML Constructors of a particular type.
getXMLConstrs :: Data (DictXMLData h) a => h -> a -> [XMLConstr]
getXMLConstrs (q::h) (x::a) = 
    let dt = dataTypeOf ctx x 
        ctx = undefined::DictXMLData h () in
             if (isAlgType dt) then map (toXMLConstrA q) ((map (fromConstr ctx) $ dataTypeConstrs dt)::[a])
                               else [toXMLConstrA q x]
        

-----------------------------------------------------------------------------------------------------
-- The Serialization Type-Classes
-----------------------------------------------------------------------------------------------------

-- | The XMLData class is an extension of Data which allows customization of XML serialization.
class (Data (DictXMLData h) a) => XMLData h a where    
    xmlEncode :: DynamicMap -> h -> a -> [[XmlFilter]] -- Custom encoder
    {-  Perform the default case for serialization, provided the given data-item is XMLData and Data and there are
        no field properties specified, hand control over to XMLData to perform serialization. If there *are* field
        properties serialize by running serialize on each sub-term via gmapQ and then use zipWith to wrap up each
        serialization in elements and attributes (via xmlWrap).

        Strategy for encoding should be;
        1) Use a custom XML encoder if present
        2) If an algebraic data-type with custom fields, use those for encoding.
        3) If an algebraic data-type with record field, use those for encoding as element names.
        4) Use the default instance (atm via Show, but should be via SYB generic)
    -}
    xmlEncode dm q x  = if (null fs) 
			   then []
			   else [concat $ zipWith (xmlWrap nst) elements $ gmapQ ctx (xmlEncodeA dm q) x] 
      where ctx = undefined::DictXMLData h ()
            fs  = xmlFields $ toXMLConstr q x 
            nst = lookupDM_D nstIKey dm
            ns  = xmlNsURI $ toXMLConstrA q x
            prefix = maybe "" (\ns -> fromMaybe "" $ lookup ns nst) ns
	    xmlConstrs = gmapQ ctx (toXMLConstrA q) x
            xmlCons = toXMLConstr q x

	    --elements = map element (zip [0..] fs)
            elements = zipWith (\f -> \fn -> f fn) (gmapQ ctx (toFieldProp q) x) fs
	    element (n, f) = case f of
			         Choice ps -> ps!!((constrIndex $ constrs!!n)-1)
                                 x -> x
	        where --constr = (constrs!!n)
                      qualName n q = maybe n (\x->x++":"++n) (q >>= \x -> lookup x nst)
{-	    askName = map elementName xmlConstrs
            askPrefix = map (\x -> maybe "" (\x -> x++":") $ ((snd x) >>= \x -> lookup x nst)) (gmapQ ctx (getNamespace q) x)-}
	    constrs = gmapQ ctx (toConstr ctx) x


    xmlDecode ::  h -> ReadX a -- Monadic Decoder
    xmlDecode h = xmlDecodeDefault h (undefined::a)
    toXMLConstr :: h -> a -> XMLConstr
    toXMLConstr _ x = xmlConstr 

-- | The default case for deserializing a type. Use field labels and defaulting as before.
xmlDecodeDefault :: (XMLData h a, Data (DictXMLData h) a) => h -> a -> ReadX a
xmlDecodeDefault (q::h) (x::a) = do s <- get
			            let desCons c = do let xc = toXMLConstr q ((fromConstr ctx c)::a)
						       put s{fields = xmlFields xc, thisXMLConstr = xc, thisConstr = c}
				         	       fromConstrM ctx deserialize c
                                    -- If forceConstr has been set by something further up the tree, use that without backtracking.
                                    maybe 
                                      (msum $ map desCons cons)
				      (\n -> desCons (cons!!(n-1))) (forceConstr s) 

  where ctx  = undefined :: DictXMLData h ()
	cons = dataTypeConstrs $ dataTypeOf ctx x
        switchOnParticle f readElem
                           = do s <- get
                                case f of 
			         (Elem n  u) -> do c <- readElem (undefined, n)
                                                   let es = map getChildren c; as = map getAttrl c
                                                   newReadX s{ elements  = es
                                                             , attribs   = as 
                                                             } (xmlDecodeA q)
                                 (Attr n u) -> do c <- readAttr (undefined, n)
					          let es = map getChildren c; as = map getAttrl c
					          newReadX s{ elements = es
						            , attribs  = as
						            } (xmlDecodeA q)
                                 Choice ps -> msum $ map (\(p, cn) -> do -- put s{ forceConstr = Just cn }
                                                                         switchOnParticle p readElem) (zip ps [1..])
                                 (Splice) -> mzero
        deserialize :: (Data (DictXMLData h) b) => ReadX b
        deserialize = result
          where 
            result =  do f <- nextField
			 s <- get
                         put s{forceConstr = Nothing}
                         let cons = toConstr ctx thisType
                             xc  = toXMLConstrA q thisType
                             xcs = map (toXMLConstrA q) ((map (fromConstr ctx) $ dataTypeConstrs $ dataTypeOf ctx thisType)::[b])
			     tc  = thisConstr s
                             txc = thisXMLConstr s
                             readElem = if (isMulti xc) then if (isInterleaved txc) then readElemI else readElemS
                                                        else \n -> do let f = if (isInterleaved txc) then read1ElemI else read1ElemS
                                                                      f n >>= \x -> return [x]
                                                               
                         -- FIXME : All of the following should be made namespace aware at some point.
			 switchOnParticle f readElem
            (thisType::b) = thisTypeOf result
              where 
                thisTypeOf :: ReadX b -> b
                thisTypeOf = undefined 


-- | Get the XML Constructor when only the dictonary is available.
toXMLConstrA :: Data (DictXMLData b) a => b -> a -> XMLConstr
toXMLConstrA (h::b) (x::a) = toXMLConstrD (dict::DictXMLData b a) x

-- | Get the XML Encoder when only the dictionary is available.
xmlEncodeA :: Data (DictXMLData b) a => DynamicMap -> b -> a -> [[XmlFilter]]
xmlEncodeA dm (h::b) (x::a) = xmlEncodeD (dict::DictXMLData b a) dm x

-- | Get the XML Decoder when only the dictionary is available. 
xmlDecodeA :: Data (DictXMLData b) a => b -> ReadX a
xmlDecodeA (q::h) = result
  where
    result :: ReadX a  = xmlDecodeD (dict::DictXMLData h a)

-- | Get all the namespace URIs and prefixes of a particular type.
getURIs :: (Data (DictXMLData b) a) => b -> a -> [(String, Maybe URI)]
getURIs (h::b) (x::a) = let c = getXMLConstrs h x in map (\c -> (xmlPrefix c, xmlNsURI c)) c


defaultPropA c = if (isNothing $ defaultProp c) then (case (elementNames c) of
                                                        []  -> Nothing
                                                        [x] -> Just $ Elem x (xmlNsURI c)
                                                        y   -> Just $ Choice $ map (\x -> Elem x (xmlNsURI c)) y)
                                                else defaultProp c

-- | The dictionary lookup for XMLData
instance (Data (DictXMLData b) a, XMLHook b a, XMLData b a) => Sat (DictXMLData b a) where
    dict = DictXMLData { xmlEncodeD   = \d -> \x -> zipWith (++) (xmlEncode d ctx x) (encodeHook d ctx x)
		       , xmlDecodeD   = xmlDecode ctx
                       , toXMLConstrD = toXMLConstr ctx
		       }
      where ctx = undefined::b

toFieldPropA :: (Data (DictXMLData b) a) => b -> a -> Maybe FieldProp
toFieldPropA h x = (defaultProp $ toXMLConstrA h x) >>= return . toFieldProp h x
                          
toFieldProp :: (Data (DictXMLData b) a) => b -> a -> FieldProp -> FieldProp
toFieldProp (q::h) x p = let con = toConstr ctx x; ctx = (undefined::DictXMLData h ()) in
                           case p of
                             Choice ps -> head $ gmapQ ctx (\x -> toFieldProp q x (ps!!((constrIndex con)-1))) x
                             x -> x

-----------------------------------------------------------------------------------------------------
-- XML Utilities for Serialization
-----------------------------------------------------------------------------------------------------

{-
fromConstrM' :: (Data (DictR q (StateT ReadXO Maybe)) a)
            => q
            -> Constr
            -> ReadX a							
fromConstrM' (q::q) = fromConstrM ctx (applyR q)
		where ctx    = undefined::DictR q (StateT ReadXO Maybe) ()


apply_gmapQ :: (Data (DictQ q r) a) => q -> a -> [r]
apply_gmapQ = gmapQ' undefined
  where
  gmapQ' :: (Data (DictQ q r) a) => DictQ q r () -> q -> a -> [r]
  gmapQ' ctx q a = gmapQ ctx (applyQ q) a
-}        

-- | Use the namespace classes to recursively read off a namespace table.
getNamespaceTable :: Data (DictXMLData b) a => b -> a -> [(String, URI)] -> [(String, URI)]
getNamespaceTable (q::b) x onst = 
    assign 0 $ nubBy (snds (==)) $ reverse $ sortBy (fsts compare) $ (++) onst $ (\x->[(k,v)|(k,Just v)<-x]) $ concat $ getURIs q x : everyone ctx (getURIs q) x 
    where
    ctx = undefined :: DictXMLData b ()
    assign _ [] = []
    assign n (h@(p,ns):t) = if (null p) then ("tns"++show n,ns):(assign (n+1) t) else h:assign n t

-- | Produce a filter which adds a namespace table to the root of a tree.
namespaceTableFilter :: [(String, URI)] -> [XmlFilter]
namespaceTableFilter = map (\(p, ns)->attr ("xmlns:"++p) (txt $ show ns))

-- | Convert a list of lists of XmlFilters, with a specified root name to a list of XmlTrees.
toTrees :: String -> [[XmlFilter]] -> XmlTrees
toTrees n f = concat $ map (\x -> etag n ++= x $ emptyRoot) f

snds f = \(_,x) -> \(_,y) -> f x y
fsts f = \(x,_) -> \(y,_) -> f x y

-----------------------------------------------------------------------------------------------------
-- Core Serialization functions
-----------------------------------------------------------------------------------------------------


{- | The main function; given a Serialization Hook a piece of data and a Flag indicating whether we should 
     encode namespaces, perform serialization.
-}
serialize q x n = fst $ serializeAux q x n

serializeAux :: (Data (DictXMLData h) a, InitXMLHook h, XMLHook h a) => h -> a -> Bool -> ([[XmlFilter]], DynamicMap)
serializeAux (q::h) (x::a) n = (map ((++) (namespaceTableFilter ns)) $ xmlEncodeD (dict::DictXMLData h a) dm x, dm)
   where dm   = addToDM nstI nstIKey emptyDM
         nstI = map swap ns
         ns   = if n then getNamespaceTable q x (getNamespaces q) else []



-- | A simpler version of the above, apply no hook and don't encode namespaces.
basicSerialize a = serialize NullXMLHook a False

-- | Perform serialization and apply the filters output to produce an actual list of trees.
toXML :: (XMLNamespace a, Data (DictXMLData h) a, InitXMLHook h, XMLHook h a) => h -> a -> Bool -> XmlTrees
toXML (q::h) a b = let (s, dm) = serializeAux q a b; cons = toConstr (undefined::DictXMLData h ()) a  in
                         toTrees (applyPrefix dm a ((elementNames $ toXMLConstrA q a)!!((constrIndex cons)-1))) s

-- | Perform deserialization, take an XmlTree and deserialize to a type.  
deserialize xml = do let s = RO Nothing undefined undefined [] [getAttrl xml] [getChildren xml] emptyDM
		     runReadX s (xmlDecode NullXMLHook)

-- | A test function, given a type, perform a no-namespace serialization, deserialize it and see whether the same thing comes out.
testGXSReflection x = let des = (deserialize (head $ toTrees "" $ basicSerialize x)) in
				if ((Just x) == des) then Right () else Left ((show x) ++ " /= " ++ (show des))
		     
---------------------------------------------------------------------------------------------------------------------
-- ALIASES
---------------------------------------------------------------------------------------------------------------------

-- | Use Show to perform serialization of a simple type.
encodeViaShow :: (Show a, (Data (DictXMLData h) a)) => DynamicMap -> h -> a -> [[XmlFilter]]
encodeViaShow dm q x = [[txt $ show x]]

-- | Use Read to perform deserialization of a simple type.
decodeViaRead :: (Read a, (Data (DictXMLData h) a)) => h -> ReadX a
decodeViaRead q = readText >>= \x -> (if (null x) then mzero else return $ read x)
