Type2Xsd.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Language.XML.Type2Xsd
-- 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 type representations to XML Schemas.
--
-----------------------------------------------------------------------------

module Language.XML.Type2Xsd where

import Data.Type
import Data.Equal
import Language.XML.Xml2Type
import Language.XML.Xsd2Type
import Language.XML.HaXmlAliases

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

-- (attributes of the current element,recursive complex elements)
type XsdGenM a = MonadPlus m => StateT ([Element ()],[Element ()]) m a

type2xsd :: Type a -> Maybe Schema
type2xsd t = type2doc t >>= doc2Xsd . one2posn

type2doc :: Type a -> Maybe (Document ())
type2doc t = evalStateT (type2doc' t) ([],[])

type2doc' :: Type a -> XsdGenM (Document ())
type2doc' t = do
	els <- type2topelements t
	(_,complexels) <- ST.get
	return $ Document
		(Prolog  (Just (XMLDecl "1.0" (Just (EncodingDecl "utf-8")) Nothing)) [] Nothing [])
		[] (Elem (N "xsd:schema")
			[ genAttribute "xmlns:xsd" "http://www.w3.org/2001/XMLSchema"]
			(celems els ++ celems complexels)
		) []
	
type2topelements :: Type a -> XsdGenM [Element ()]
type2topelements e@(Either a b) | not (isMaybe e) = do
	x <- type2element a 
	y <- type2element b
	return (maybeToList x ++ maybeToList y)
type2topelements t = do
	mb <- type2element t
	case mb of { Just el -> return [el]; Nothing -> error "top-level attribute?" }

type2element :: Type a -> XsdGenM (Maybe (Element ()))
type2element (Either One a) = type2element (Either a One)
type2element (Data "Maybe" (K One :+!: K a)) = type2element (Either a One)
type2element (Either a One) | isAtt a = data2attribute a >>= addAtt . maybe2attribute >> return Nothing
type2element a | isAtt a =  data2attribute a >>= addAtt . nonmaybe2attribute >> return Nothing
type2element (Either a One) = type2element a >>= return . fmap maybe2element
type2element (List a) = type2element a >>= return . fmap list2element
type2element d | isData d = data2element d >>= return . Just
type2element (Id (Var s)) = return $ Just $ Elem (N "xsd:element") [genAttribute "name" s,genAttribute "type" (ref s)] []
type2element Dynamic = return $ Just $ Elem (N "xsd:any") [] []
type2element t = error $ "type2element: " ++ show t

isMaybe :: Type a -> Bool
isMaybe (Either a One) = True
isMaybe (Either One a) = True
isMaybe (Data "Maybe" (K One :+!: K a)) = True
isMaybe _ = False

isBasicList :: Type a -> Bool
isBasicList (List a) = isBasic a
isBasicList _ = False

isDynamic :: Type a -> Bool
isDynamic Dynamic = True
isDynamic _ = False

nonmaybe2attribute :: Element () -> Element ()
nonmaybe2attribute (Elem n atts cts) = Elem n (atts ++ [genAttribute "use" "required"]) cts

maybe2attribute :: Element () -> Element ()
maybe2attribute (Elem n atts cts) = Elem n (atts ++ [genAttribute "use" "optional"]) cts

maybe2element :: Element () -> Element ()
maybe2element (Elem n atts cts) = Elem n (atts ++ [genAttribute "minOccurs" "0",genAttribute "maxOccurs" "1"]) cts

list2element :: Element () -> Element ()
list2element (Elem n atts cts) = Elem n (atts ++ [genAttribute "minOccurs" "0",genAttribute "maxOccurs" "unbounded"]) cts

basic2primitive :: Type a -> XsdGenM String
basic2primitive (List Char) = return "xsd:string"
basic2primitive (Data "Nat" _) = return "xsd:nonNegativeInteger"
basic2primitive Int = return "xsd:integer"
basic2primitive Bool = return "xsd:boolean"

basiclist2list :: Type a -> XsdGenM (Element ())
basiclist2list (List a) = do
	t <- basic2primitive a
	return $ Elem (N "xsd:list") [genAttribute "itemType" t] []

data2attribute :: Type a -> XsdGenM (Element ())
data2attribute (dataNameFctr -> Just (nodename -> ('@':s),f)) | isBasic repf = do
	t <- basic2primitive repf
	return $ Elem (N "xsd:attribute") [genAttribute "name" s,genAttribute "type" t] []
  where repf = rep f $ One
data2attribute a = error $ "data2attribute: " ++ show a

data2element :: Type a -> XsdGenM (Element ())
data2element (Data s f) = data2element (NewData s f)
data2element (NewData s f) | isOne repf = do
	let complex = Elem (N "xsd:complexType") [] (celems [Elem (N "xsd:sequence") [] []])
	return $ Elem (N "xsd:element") [genAttribute "name" (nodename s)] (celems [complex])
                           | isDynamic repf = do
	return $ Elem (N "xsd:element") [genAttribute "name" (nodename s)] []
                           | isBasic repf = do
	t <- basic2primitive repf
	return $ Elem (N "xsd:element") [genAttribute "name" (nodename s),genAttribute "type" t] []
                           | isBasicList repf = do
	l <- basiclist2list repf
	let simple = Elem (N "xsd:simpleType") [] (celems [l])
	return $ Elem (N "xsd:element") [genAttribute "name" (nodename s)] (celems [simple])
	                   | otherwise = do
	atts <- getAtts
	putAtts []
	mbels <- type2content False repf
	let els = maybe [] (:[]) mbels
	atts' <- getAtts
	let complex = Elem (N "xsd:complexType") [genAttribute "name" (ref $ refname s)] (celems els ++ celems atts')
	addTopComplex complex
	putAtts atts
	return $ Elem (N "xsd:element") [genAttribute "name" (nodename s),genAttribute "type" (ref $ refname s)] []
  where repf = rep f $ Id $ Var $ refname s

-- Bool for identifying if we need to create a sequence container or not
type2content :: Bool -> Type a -> XsdGenM (Maybe (Element ()))
type2content b (Either One a) = type2content b (Either a One)
type2content b (Data "Maybe" (K One :+!: K a)) = type2content b (Either a One)
type2content b (Either a One) | isAtt a = data2attribute a >>= addAtt . maybe2attribute >> return Nothing
type2content b a | isAtt a =  data2attribute a >>= addAtt . nonmaybe2attribute >> return Nothing
type2content b (Either a One) = type2content b a >>= return . fmap maybe2element
type2content b (List a) = type2content b a >>= return . fmap list2element
type2content b p@(Prod _ _) = prods2elements p >>= return . Just . Elem (N "xsd:sequence") [] . celems
type2content b e@(Either _ _) | not (isMaybe e) = sums2elements e >>= return . Just . Elem (N "xsd:choice") [] . celems
type2content False t = type2element t >>= return . fmap (\el -> Elem (N "xsd:sequence") [] (celems [el]))
type2content True t = type2element t

prods2elements :: Type a -> XsdGenM [Element ()]
prods2elements (Prod a b) = do
	x <- prods2elements a
	y <- prods2elements b
	return (x ++ y)
prods2elements t = type2content True t >>= return . maybe [] (:[])

sums2elements :: Type a -> XsdGenM [Element ()]
sums2elements e@(Either a b) | not (isMaybe e) = do
	x <- sums2elements a
	y <- sums2elements b
	return (x ++ y)
sums2elements t = type2content True t >>= return . maybe [] (:[])

ref :: String -> String
ref s = s++"REF"

celems :: [Element ()] -> [Content ()]
celems = map (\e -> CElem e ())

genAttribute :: String -> String -> Attribute
genAttribute n v = (N n, AttValue [Left $ v])

addTopComplex :: Element () -> XsdGenM ()
addTopComplex e = do
	(atts,tops) <- ST.get
	if (elem e tops) then return () else ST.put (atts,e:tops)

getAtts :: XsdGenM [Element ()]
getAtts = do
	(atts,_) <- ST.get
	return atts

putAtts :: [Element ()] -> XsdGenM ()
putAtts atts = do
	(_,tops) <- ST.get
	ST.put (atts,tops)

addAtt :: Element () -> XsdGenM ()
addAtt att = do
	(atts,tops) <- ST.get
	ST.put (atts++[att],tops)