Xsd2Type.hs

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

module Language.XML.Xsd2Type where

import Data.Type
import Data.Equal
import Data.Transform.TwoLevel hiding (not)
import Generics.Pointless.Combinators

import Language.XML.HaXmlAliases

import Text.XML.HaXml.Types hiding (ElementDecl,Choice)
import qualified Text.XML.HaXml.Schema.XSDTypeModel as T(Any(..))
import Text.XML.HaXml.Schema.XSDTypeModel hiding (Any(..))

import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Control.Monad.State as ST
import Data.List

xsd2type :: MonadPlus m => Schema -> m DynType
xsd2type s = xsd2toptype s >>= return . fst

xsd2toptype :: MonadPlus m => Schema -> m (DynType,TopMap)
xsd2toptype (Schema _ _ _ _ _ _ _ items) = do
	-- process top items
	(_,deps) <- runStateT (topitems2type items) Map.empty
	-- process variable dependencies
	let toprocess = map (\(a,(x,y,z)) -> (a,x,z)) $ Map.toList deps
	(_,top) <- runStateT (dependencies deps toprocess) Map.empty
	-- process root elements
	let els = map (\(SchemaElement e) -> e) $ filter isElement items
	cl <- mapM (element2type (TopItems top)) els
	dynt <- applyDynT reshape (nestedEither cl)
	return (dynt,top)

isElement :: SchemaItem -> Bool
isElement (SchemaElement e) = True
isElement _ = False
isAttribute :: SchemaItem -> Bool
isAttribute (SchemaAttribute e) = True
isAttribute _ = False	

subset :: Eq a => [a] -> [a] -> Bool
subset [] l = True
subset (x:xs) l = elem x l && subset xs l

depends :: Deps -> [(Name,a,b)] -> [Name] -> ([(Name,a,b)],[(Name,a,b)])
depends deps [] vars = ([],[])
depends deps (x:xs) vars = let (l1,r1) = depend deps x vars
                               (l2,r2) = depends deps xs vars
                           in (l1++l2,r1++r2)
depend :: Deps -> (Name,a,b) -> [Name] -> ([(Name,a,b)],[(Name,a,b)])
depend deps (n,t,x) vars | depGraph deps n `subset` vars = ([(n,t,x)],[])
                       | otherwise = ([],[(n,t,x)])
depGraph :: Deps -> Name -> [Name]
depGraph deps name = case Map.lookup name deps of { Nothing -> []; Just (t,ns,x) -> ns }

dependencies :: MonadPlus m => Deps -> [(Name,DynType,SchemaItem)] -> StateT TopMap m ()
dependencies deps [] = return ()
dependencies deps l = do
	processed <- ST.get
	let vars = Map.keys processed
	    (now,after) = depends deps l vars
	if (null now) then error $ "unsupported mutual recursion or reference to undefined top-level type" ++ show (map (\(x,_,_)->x) after)
	else do
		mapM (dependency deps) now
		dependencies deps after	
dependency :: MonadPlus m => Deps -> (Name,DynType,SchemaItem) -> StateT TopMap m ()
dependency deps (n,DynT t,item) = do
	vars <- ST.get
	t' <- replacevar t vars
	ST.put (Map.insert n (DynT t') vars)

topitems2type :: MonadPlus m => [SchemaItem] -> StateT Deps m ()
topitems2type [] = return ()
topitems2type (x:xs) = do
	mb <- topitem2type x
	case mb of
		Just (n,t,deps) -> do
			top <- ST.get
			ST.put $ Map.insert n (t,deps,x) top
			topitems2type xs
		otherwise  -> topitems2type xs

topitem2type :: MonadPlus m => SchemaItem -> m (Maybe (Name,DynType,[Name]))
topitem2type item = do
	let name = itemName item
	case name of
		Nothing -> return Nothing
		Just n  -> do
			mb <- item2type (Self n) item
			case mb of
				Nothing -> return Nothing
				Just (DynT t) -> do
					return $ Just (n,DynT t,collectVars t)

type Deps = Map Name (DynType,[Name],SchemaItem)
type TopMap = Map Name DynType
data TopItems = Self Name | TopItems TopMap

findTopItem :: Map Name DynType -> Name -> Maybe DynType
findTopItem top name = Map.lookup name top

itemName :: SchemaItem -> Maybe Name
itemName (Include _ _) = Nothing
itemName (Import _ _ _) = Nothing
itemName (Redefine _ _) = Nothing
itemName (Annotation _) = Nothing
itemName (Simple s) = Nothing
itemName (Complex (ComplexType _ name _ _ _ _ _)) = name
itemName (SchemaElement (ElementDecl _ (Left (NT name _)) _ _ _ _ _ _ _ _ _)) = Just name
itemName (SchemaElement (ElementDecl _ (Right ref) _ _ _ _ _ _ _ _ _)) = Nothing
itemName (SchemaAttribute (AttributeDecl _ (Left (NT name _)) _ _ _ _)) = Just name
itemName (SchemaAttribute (AttributeDecl _ (Right ref) _ _ _ _)) = Nothing
itemName (AttributeGroup (AttrGroup _ (Left name) _)) = Just name
itemName (AttributeGroup (AttrGroup _ (Right ref) _)) = Nothing
itemName (SchemaGroup (Group _ (Left name) _ _)) = Just name
itemName (SchemaGroup (Group _ (Right ref) _ _)) = Nothing

item2type :: MonadPlus m => TopItems -> SchemaItem -> m (Maybe DynType)
item2type top (Include _ _) = error "xsd:include unsupported"
item2type top (Import _ _ _) = error "xsd:import unsupported"
item2type top (Redefine _ _) = error "xsd:import unsupported"
item2type top (Annotation _) = return Nothing
item2type top (Simple s) = simple2type top s >>= return . Just
item2type top (Complex c) = complex2type top c >>= return . Just
item2type top (SchemaElement e) = element2type top e >>= return . Just
item2type top (SchemaAttribute a) = attribute2type top a >>= return . Just
item2type top (AttributeGroup as) = attrgroup2type top as >>= return . Just
item2type top (SchemaGroup g) = group2type top g

simple2type :: MonadPlus m => TopItems -> SimpleType -> m DynType
simple2type top (Primitive p) = primitive2type p
simple2type top (Restricted _ _ _ _) = error "xsd:restriction unsupported"
simple2type top (ListOf _ _ _ stype) = do
	DynT s <- (simple2type top \/ qname2type) stype
	return $ DynT $ List s
simple2type top (UnionOf _ _ _ union members) = do
	u <- mapM (simple2type top) union
	m <- mapM qname2type members
	return $ nestedEither (u ++ m)

complex2type :: MonadPlus m => TopItems -> ComplexType -> m DynType
complex2type top (ComplexType _ name _ _ _ _ (SimpleContent _ _)) = error "simpleContent unsupported"
complex2type top (ComplexType _ name _ _ _ _ (ComplexContent _ _ _)) = error "complexContent unsupported"
complex2type top (ComplexType _ name _ _ _ _ (ThisType pas)) = particleattrs2type top pas

particleattrs2type :: MonadPlus m => TopItems -> ParticleAttrs -> m DynType
particleattrs2type top (PA pa atts _) = do
	el <- particle2type top pa
	ats <- mapM (attribute2type top \/ attrgroup2type top) atts
	return $ nestedProd $ filterJust (el:map Just ats)
	
particle2type :: MonadPlus m => TopItems -> Particle -> m (Maybe DynType)
particle2type top Nothing = return Nothing
particle2type top (Just (Left acs)) = acs2type top acs >>= return . Just
particle2type top (Just (Right group)) = group2type top group

group2type :: MonadPlus m => TopItems -> Group -> m (Maybe DynType)
group2type top (Group _ (Right ref) occurs _) = liftM (occurs2type occurs) (ref2type top ref) >>= return . Just
group2type top (Group _ (Left name) occurs Nothing) = return Nothing
group2type top (Group _ (Left name) occurs (Just acs)) = liftM (occurs2type occurs) (acs2type top acs) >>= return . Just

acs2type :: MonadPlus m => TopItems -> ChoiceOrSeq -> m DynType
acs2type top (All _ els) = error "xsd:all unsupported"
acs2type top (Choice _ occurs els) = liftM (occurs2type occurs) $ choice2type top els
acs2type top (Sequence _ occurs els) = liftM (occurs2type occurs) $ sequence2type top els

choice2type :: MonadPlus m => TopItems -> [ElementEtc] -> m DynType
choice2type top l = do
	cl <- mapM (elementetc2type top) l
	return $ nestedEither $ filterJust cl

sequence2type :: MonadPlus m => TopItems -> [ElementEtc] -> m DynType
sequence2type top l = do
	sl <- mapM (elementetc2type top) l
	return $ nestedProd $ filterJust sl

filterJust :: [Maybe a] -> [a]
filterJust = map fromJust . filter isJust

elementetc2type :: MonadPlus m => TopItems -> ElementEtc -> m (Maybe DynType)
elementetc2type top (HasElement e) = element2type top e >>= return . Just
elementetc2type top (HasGroup g) = group2type top g
elementetc2type top (HasCS acs) = acs2type top acs >>= return . Just
elementetc2type top (HasAny a) = any2type a >>= return . Just

any2type :: MonadPlus m => T.Any -> m DynType
any2type (T.Any _ _ _ occurs) = return $ occurs2type occurs $ DynT Dynamic

element2type :: MonadPlus m => TopItems -> ElementDecl -> m DynType
element2type top (ElementDecl _ (Right ref) occurs _ _ _ _ _ _ _ _) = liftM (occurs2type occurs) $ ref2type top ref
element2type top (ElementDecl _ (Left (NT name Nothing)) occurs _ _ _ _ _ _ Nothing _) = do
	liftM (occurs2type occurs) $ newElement top name (DynT Dynamic)
element2type top@(Self n) (ElementDecl _ (Left (NT name t)) occurs _ _ _ _ _ _ Nothing _) = do
	-- references to the same type are considered recursive invocations, even if the name does not match
	dynt <- typeref2type top t
	case dynt of
		DynT (Id Any) -> return $ occurs2type occurs dynt
		otherwise     -> liftM (occurs2type occurs) $ newElement top name dynt
element2type top (ElementDecl _ (Left (NT name t)) occurs _ _ _ _ _ _ Nothing _) = do
	dynt <- typeref2type top t
	liftM (occurs2type occurs) $ newElement top name dynt
element2type top (ElementDecl _ (Left (NT name Nothing)) occurs _ _ _ _ _ _ (Just content) _) = do
	dynt <- (simple2type top \/ complex2type top) content
	liftM (occurs2type occurs) $ newElement top name dynt
element2type top (ElementDecl _ (Left (NT name t)) occurs _ _ _ _ _ _ content _) = error "element has two types?"
	
attribute2type :: MonadPlus m => TopItems -> AttributeDecl -> m DynType
attribute2type top (AttributeDecl _ (Right ref) use _ _ _) = do
	att <- ref2type top ref
	return (use2type use att)
attribute2type top (AttributeDecl _ (Left (NT name t)) use _ _ _) = do
	dynt <- typeref2type top t
	att <- newAttribute top name dynt
	return (use2type use att)

occurs2type :: Occurs -> DynType -> DynType
occurs2type (Occurs (Just 0) (Just 9223372036854775807)) (DynT t) = DynT $ List t
occurs2type (Occurs (Just 0) (Just 1)) (DynT t) = DynT (Either t One)
occurs2type (Occurs (Just 1) (Just 1)) t = t
occurs2type (Occurs Nothing max) t = occurs2type (Occurs (Just 1) max) t
occurs2type (Occurs min Nothing) t = occurs2type (Occurs min (Just 1)) t
occurs2type (Occurs min max) t = error $ "occurs unsupported: " ++ show min ++ "-" ++ show max

use2type :: Use -> DynType -> DynType
use2type Prohibited t = DynT One
use2type Required t = t
use2type Optional (DynT t) = DynT (Either t One)

attrgroup2type :: MonadPlus m => TopItems -> AttrGroup -> m DynType
attrgroup2type top (AttrGroup _ (Right ref) _) = ref2type top ref
attrgroup2type top (AttrGroup _ (Left name) atts) = do
	ats <- mapM (attribute2type top \/ attrgroup2type top) atts
	return $ nestedProd ats

basicTypes :: Map Name DynType
basicTypes = Map.fromList
	[("integer",DynT Int),("positiveInteger",DynT Int),("int",DynT Int)
	,("decimal",DynT (List Char)),("float",DynT (List Char)),("double",DynT (List Char))
	,("string",DynT (List Char)),("byte",DynT Int),("boolean",DynT Bool),("date",DynT (List Char))
	,("NMTOKEN",DynT (List Char)),("NMTOKENS",DynT (List Char)),("ID",DynT (List Char))
	,("anyUri",DynT (List Char)),("language",DynT (List Char)),("NCName",DynT (List Char))
	,("NCName",DynT (List Char)),("dateTime",DynT (List Char)),("nonNegativeInteger",DynT nat)
	,("short",DynT Int),("long",DynT Int),("token",DynT (List Char)),("duration",DynT (List Char))
	,("normalizedString",DynT (List Char)),("Name",DynT (List Char))]

isBasicType :: QName -> Bool
isBasicType (QN (Namespace "xs" _) n) = Map.member n basicTypes
isBasicType (QN (Namespace "xsd" _) n) = Map.member n basicTypes
isBasicType _ = False

-- A simple type as a qualified name
qname2type :: MonadPlus m => QName -> m DynType
qname2type qn@(isBasicType -> True) = return $ fromJust $ Map.lookup (fromQName qn) basicTypes
qname2type qn = error $ show qn ++ " is not a basic type"

typeref2type :: MonadPlus m => TopItems -> Maybe QName -> m DynType
typeref2type top Nothing = return $ DynT Dynamic
typeref2type top (Just qn@(isBasicType -> True)) = return $ fromJust $ Map.lookup (fromQName qn) basicTypes
typeref2type top (Just qn) = ref2type top qn

ref2type :: MonadPlus m => TopItems -> QName -> m DynType
ref2type (Self name) (qname -> n) = if name == n
	then return $ DynT $ Id Any
	else return $ DynT $ Var n
ref2type (TopItems top) (qname -> n) = case findTopItem top n of
	Just t  -> return t
	Nothing -> error $ "reference to undefined top-level type " ++ show n

fromQName :: QName -> Name
fromQName (QN _ name) = name

qname :: QName -> Name
qname (N name) = name
qname (QN (Namespace ns _) name) = name

primitive2type :: MonadPlus m => PrimitiveType -> m DynType
primitive2type Boolean = return $ DynT Bool
primitive2type _ = return $ DynT (List Char)

nestedEither,nestedProd :: [DynType] -> DynType
nestedEither [] = DynT $ One
nestedEither [t] = t
nestedEither (DynT x:xs) = applyDynT (\y -> DynT $ Either x y) (nestedEither xs)
nestedProd [] = DynT $ One
nestedProd [t] = t
nestedProd (DynT x:xs) = applyDynT (\y -> DynT $ Prod x y) (nestedProd xs)

newElement :: MonadPlus m => TopItems -> Name -> DynType -> m DynType
newElement top name (DynT t) = do
	FRep f <- inferFctr (Id Any) t
	return $ DynT $ NewData name f

newAttribute :: MonadPlus m => TopItems -> Name -> DynType -> m DynType
newAttribute top name (DynT t) = do
	FRep f <- inferFctr (Id Any) t
	return $ DynT $ NewData ("@"++name) f