Tlt2Strat.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Language.TLT.Tlt2Strat
-- 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
-- 
-- Conversion from the two-level language into strategic combinators
--
-----------------------------------------------------------------------------

module Language.TLT.Tlt2Strat where

import Data.Type
import Data.Equal
import Data.Spine

import Data.Transform.TwoLevel
import Language.TLT.TltSyntax
import Language.XML.Xsd2Type
import Language.XPath.XPath2Pf

import Control.Monad.State as ST hiding (when)
import Data.Map as Map
import Data.List as List

tlt2strat :: MonadPlus m => TLT -> StateT TopMap m RuleTRep
tlt2strat Nop = return $ RuleTRep nop
tlt2strat (Comp r1 r2) = do
	RuleTRep x <- tlt2strat r1
	RuleTRep y <- tlt2strat r2
	return $ RuleTRep (x >>> y)
tlt2strat (Choice r1 r2) = do
	RuleTRep x <- tlt2strat r1
	RuleTRep y <- tlt2strat r2
	return $ RuleTRep (x ||| y)
tlt2strat (Try r) = do
	RuleTRep x <- tlt2strat r
	return $ RuleTRep (try x)
tlt2strat (Many r) = do
	RuleTRep x <- tlt2strat r
	return $ RuleTRep (many x)	
tlt2strat (All r) = do
	RuleTRep x <- tlt2strat r
	return $ RuleTRep (allNorm x)
tlt2strat (Once r) = do
	RuleTRep x <- tlt2strat r
	return $ RuleTRep (onceNorm x)
tlt2strat (Everywhere r) = do
	RuleTRep x <- tlt2strat r
	return $ RuleTRep (everywhere x)
tlt2strat (Outermost r) = do
	RuleTRep x <- tlt2strat r
	return $ RuleTRep (outermost x)
tlt2strat (At name r) = do
	RuleTRep x <- tlt2strat r
	return $ RuleTRep (at name x)
tlt2strat (When name r) = do
	RuleTRep x <- tlt2strat r
	types <- ST.get
	case Map.lookup name types of
		Just (DynT t) -> return $ RuleTRep $ when (normalizedteq t) x
		otherwise     -> error $ "element tag " ++ name ++ " undefined in input XML Schema"
tlt2strat (Hoist) = return $ RuleTRep hoist
tlt2strat (Plunge name) = return $ RuleTRep $ plunge name
tlt2strat (Rename name) = return $ RuleTRep $ rename name
tlt2strat Erase = return $ RuleTRep erase
tlt2strat (Select xpath) = do
	pf <- xpath2pf xpath
	return $ RuleTRep (liftQ pf)