Type2Xml.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Language.XML.Type2Xml
-- Copyright   :  (c) 2011 University of Minho
-- License     :  BSD3
--
-- Maintainer  :  hpacheco@di.uminho.pt
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Multifocal:
-- Bidirectional Two-level Transformation of XML Schemas
-- 
-- Translation from haskell values to XML documents.
--
-----------------------------------------------------------------------------

module Language.XML.Type2Xml where
	
import Data.Type
import Data.Equal
import Data.Spine
import Language.XML.Xml2Type
import Language.XML.Xsd2Type
import Language.XML.Type2Xsd
import Language.XML.HaXmlAliases
import Generics.Pointless.Functors hiding (rep)
import Generics.Pointless.RecursionPatterns
import Generics.Pointless.Combinators

import Text.XML.HaXml.Schema.XSDTypeModel hiding (K)
import Text.XML.HaXml.Types
import Text.XML.HaXml.Posn
import Data.List
import Data.Maybe
import Control.Monad.State as ST

type XmlGenM b = MonadPlus m => StateT [Attribute] m b

value2xml :: FilePath -> Type a -> a -> Maybe (Document ())
value2xml schemaloc t v = evalStateT (value2xml' schemaloc t v) []

value2xml' :: FilePath -> Type a -> a -> XmlGenM (Document ())
value2xml' schemaloc t v = do
	el <- value2topelement schemaloc t v
	return $ Document (Prolog  (Just (XMLDecl "1.0" (Just (EncodingDecl "utf-8")) Nothing)) [] Nothing []) [] el []

value2topelement :: FilePath -> Type a -> a -> XmlGenM (Element ())
value2topelement schemaloc t v = do
	els <- value2elements t v
	let header = [ genAttribute "xmlns:xsi" "http://www.w3.org/2001/XMLSchema-instance"
	             , genAttribute "xsi:noNamespaceSchemaLocation" schemaloc]
	case els of
		[Elem name atts cts] -> return $ Elem name (header++atts) cts
		otherwise -> error "multiple or inexistent top elements"
		
value2elements :: Type a -> a -> XmlGenM [Element ()]
value2elements (Either One a) (Left _) | isAtt a = return []
value2elements (Either One a) (Right x) | isAtt a = datavalue2attribute a x >>= addAttVal >> return []
value2elements (Data "Maybe" (K One :+!: K a)) v | isAtt a = case (out v) of
	Left _  -> return []
	Right x -> datavalue2attribute a x >>= addAttVal >> return []
value2elements (Either a One) (Left x) | isAtt a = datavalue2attribute a x >>= addAttVal >> return []
value2elements (Either a One) (Right _) | isAtt a = return []
value2elements (Either One a) (Left _) = return []
value2elements (Either One a) (Right x) = value2elements a x
value2elements (Data "Maybe" (K One :+!: K a)) v = case (out v) of
	Left _  -> return []
	Right x -> value2elements a x
value2elements (Either a One) (Left x) = value2elements a x
value2elements (Either a One) (Right _) = return []
value2elements (List a) lv = mapM (value2elements a) lv  >>= return . concat
value2elements a v | isAtt a = datavalue2attribute a v >>= addAttVal >> return []
value2elements d v | isData d = datavalue2element d v >>= return . (:[])
value2elements Dynamic (Dyn t v) = datavalue2element t v >>= return . (:[])
value2elements (Prod a b) (x,y) = do
	elsx <- value2elements a x
	elsy <- value2elements b y
	return $ elsx ++ elsy
value2elements e@(Either a b) (Left x) | not (isMaybe e) = value2elements a x
value2elements e@(Either a b) (Right y) | not (isMaybe e) = value2elements b y

basicvalue2primitive :: Type a -> a -> XmlGenM String
basicvalue2primitive (List Char) str = return str
basicvalue2primitive (isNat -> Just Eq) (Nat n) = return $ show n
basicvalue2primitive Int i = return $ show i
basicvalue2primitive Bool True = return "true"
basicvalue2primitive Bool False = return "false"

datavalue2attribute :: Type a -> a -> XmlGenM Attribute
datavalue2attribute (Data s f) v = datavalue2attribute (NewData s f) (nu (vnn v) v)
datavalue2attribute d@(NewData ('@':s) f) v | isAtt d && isBasic repf = do
	bv <- basicvalue2primitive repf (out v)
	return $ genAttribute s bv
  where repf = rep f d

dynvalue2elements :: Type a -> a -> XmlGenM [Content ()]
dynvalue2elements Dynamic (Dyn t v) = value2elements t v >>= return . celems

listvalue2element :: Type a -> a -> XmlGenM (Content ())
listvalue2element (List a) lv = mapM (basicvalue2primitive a) lv >>= return . cstring . unwords

datavalue2element :: Type a -> a -> XmlGenM (Element ())
datavalue2element d@(Data s f) v = datavalue2element (NewData s f) (nu (vnn v) v)
datavalue2element d@(NewData (nodename -> s) f) v
	| isDynamic repf = dynvalue2elements repf (out v) >>= return . Elem (N s) []
	| isBasic repf = basicvalue2primitive repf (out v) >>= return . Elem (N s) [] . (:[]) . cstring
	| isBasicList repf = listvalue2element repf (out v) >>= return . Elem (N s) [] . (:[])
	| otherwise = do
        	atts <- getAttVals
        	putAttVals []
        	els <- value2elements repf (out v)
        	atts' <- getAttVals
        	putAttVals atts
        	return $ Elem (N s) atts' (celems els)
  where repf = rep f d

cstring :: String -> Content ()
cstring str = CString False str ()

getAttVals :: XmlGenM [Attribute]
getAttVals = ST.get

putAttVals :: [Attribute] -> XmlGenM ()
putAttVals atts = ST.put atts

addAttVal :: Attribute -> XmlGenM ()
addAttVal att = do
	atts <- ST.get
	ST.put (atts++[att])