74b23191c8f49798f7513f324bbdbbe32f8a1db2Razvan Pascanu{- |

Module : ./QVTR/Parser.hs

Description : QVT-Relational syntax parser

Copyright : (c) Daniel Calegari Universidad de la Republica, Uruguay 2013

License : GPLv2 or higher, see LICENSE.txt

Maintainer : dcalegar@fing.edu.uy

Stability : provisional

Portability : portable

-}

module QVTR.Parser where

import qualified QVTR.As as QVTR

import qualified CSMOF.As as CSMOF

import Text.ParserCombinators.Parsec

import Common.Parsec

{- Parse a QVTR model transformation

<transformation> ::= <header>

'{' <keyDecl>* <relation>* '}' -}

pTransformation :: CharParser st QVTR.Transformation

pTransformation = do

skip

(name, souMeta, tarMeta) <- pTransfHeader

skip

char '{'

skip

keys <- many (try pKeyDecl)

skip

relations <- many (try pRelation)

skip

char '}'

skip

eof

return (QVTR.Transformation

name

souMeta

tarMeta

keys

relations

)

{- Parse a transformation header without source and target CSMOF.Metamodel (just names)

<header> ::= 'transformation' <identifier>

'(' <modelDecl> ',' <modelDecl> ')'

<modelDecl> ::= <modelId> ':' <metaModelId>

<modelId> ::= <identifier>

<metaModelId> ::= <identifier> -}

pTransfHeader :: CharParser st (String, (String, String, CSMOF.Metamodel),

(String, String, CSMOF.Metamodel))

pTransfHeader = do

pKey "transformation"

skip

name <- pIdentifier

skip

list <- pBetParent $ pCommaSep $ pColonSep (skip >> pIdentifier << skip)

return ( name,

(head $ head list, head $ tail $ head list, emptyMetamodel),

(head $ head $ tail list, head $ tail $ head $ tail list, emptyMetamodel)

)

emptyMetamodel :: CSMOF.Metamodel

emptyMetamodel = CSMOF.Metamodel "" [] []

{- Parse keys of the transfromation

<keyDecl> ::= 'key' <classId> '{' <keyProperty> (, <keyProperty>)* '}' ';' -}

pKeyDecl :: CharParser st QVTR.Key

pKeyDecl = do

skip

pKey "key"

skip

classId <- pClassId

skip

list <- pBetBraces $ pCommaSep (skip >> pKeyProperty << skip)

skip

char ';'

return (uncurry QVTR.Key classId list) -- ToDo

-- <classId> ::= <identifier> '::' <identifier>

pClassId :: CharParser st (String, String)

pClassId = do

met <- pIdentifier

char ':'

char ':'

typ <- pIdentifier

return (met, typ)

{- <keyProperty> ::= <identifier>

'opposite' '(' <identifier> '.' <identifier> ')' -}

pKeyProperty :: CharParser st QVTR.PropKey

pKeyProperty = do

pKey "opposite"

skip

oppo <- pBetParent pFullName

return (uncurry QVTR.OppositeProp oppo)

<|>

do

skip

ident <- pIdentifier

return (QVTR.SimpleProp ident)

-- <identifier> '.' <identifier>

pFullName :: CharParser st (String, String)

pFullName = do

cla <- pIdentifier

char '.'

typ <- pIdentifier

return (cla, typ)

{- Parse transformation rules

<relation> ::= ['top'] 'relation' <identifier>

'{'

<varDeclaration>*

<primitiveTypeDomain>*

<domain> <domain>

[<when>] [<where>]

'}' -}

pRelation :: CharParser st QVTR.Relation

pRelation = do

skip

top <- pIsTop

skip

iden <- pIdentifier

skip

char '{'

skip

varSet <- many (try pVarDeclaration)

skip

primDom <- many (try pPrimitiveTypeDomain)

skip

sourceDom <- pDomain

skip

targetDom <- pDomain

skip

whenCon <- option Nothing pWhen

skip

whereCon <- option Nothing pWhere

skip

char '}'

return ( QVTR.Relation top iden (concat varSet)

primDom sourceDom targetDom whenCon whereCon )

-- Parse if a relation is top or not

pIsTop :: CharParser st Bool

pIsTop = do

skip

pKey "top"

skip

pKey "relation"

return True

<|>

do skip

pKey "relation"

return False

{- Parse var declaration

<varDeclaration> ::= <identifier> (, <identifier>)* ':' <TypeCS> ';' -}

pVarDeclaration :: CharParser st [QVTR.RelVar]

pVarDeclaration = do

skip

vars <- pCommaSep (skip >> pIdentifier << skip)

skip

char ':'

skip

typ <- pTypeCS

skip

char ';'

return ( map (QVTR.RelVar typ) vars )

{- <TypeCS> ::= <identifier> '::' <identifier>

<identifier> -}

pTypeCS :: CharParser st String

pTypeCS =

try (do typ <- pIdentifier

skip

notFollowedBy (char ':')

return typ

)

<|>

do

_ <- pIdentifier

char ':'

char ':'

pIdentifier

{- Parse primitive domain

<primitiveTypeDomain> ::= 'primitive' 'domain' <identifier> ':' <TypeCS> ';' -}

pPrimitiveTypeDomain :: CharParser st QVTR.PrimitiveDomain

pPrimitiveTypeDomain = do

skip

pKey "primitive"

skip

pKey "domain"

skip

nam <- pIdentifier

skip

char ':'

skip

typ <- pTypeCS

skip

char ';'

return ( QVTR.PrimitiveDomain nam typ )

-- <domain> ::= 'domain' <modelId> <template> ';'

pDomain :: CharParser st QVTR.Domain

pDomain = do

skip

pKey "checkonly" <|> pKey "enforce"

skip

pKey "domain"

skip

modelId <- pIdentifier

skip

tem <- pTemplate

skip

char ';'

return ( QVTR.Domain modelId tem )

{- <template> ::= <objectTemplate>

<objectTemplate> ::= <identifier> ':' <pathNameCS>

'{' [<propertyTemplateList>] '}' -}

pTemplate :: CharParser st QVTR.ObjectTemplate

pTemplate = do

skip

ide <- pIdentifier

skip

char ':'

skip

typ <- pClassId

skip

tempList <- pBetBraces $ option [] pPropertyTemplateList

skip

return (uncurry (QVTR.ObjectTemplate ide) typ tempList )

-- <propertyTemplateList> ::= <propertyTemplate> (',' <propertyTemplate>)*

pPropertyTemplateList :: CharParser st [QVTR.PropertyTemplate]

pPropertyTemplateList = do

skip

try $ pCommaSep pPropertyTemplate

{- <propertyTemplate> ::= <identifier> '=' <OclExpressionCS>

<identifier> '=' <objectTemplate> -}

pPropertyTemplate :: CharParser st QVTR.PropertyTemplate

pPropertyTemplate = do

skip

ident <- pIdentifier

skip

pEqual

skip

(do t <- try pTemplate

return ( QVTR.PropertyTemplate ident Nothing (Just t) ))

<|>

do e <- try pOCLExpression

return ( QVTR.PropertyTemplate ident (Just e) Nothing )

-- <when> ::= 'when' '{' (<RelInvocation> ';')* (<OclExpressionCS> ';')* '}'

pWhen :: CharParser st (Maybe QVTR.WhenWhere)

pWhen = do

skip

pKey "when"

skip

char '{'

skip

relInvok <- many (try pRelInvocation)

skip

oclExpre <- many (try pOCLWSemi)

skip

char '}'

return ( Just (QVTR.WhenWhere relInvok oclExpre) )

-- <where> ::= 'where' '{' (<RelInvocation> ';')* (<OclExpressionCS> ';')* '}'

pWhere :: CharParser st (Maybe QVTR.WhenWhere)

pWhere = do

skip

pKey "where"

skip

char '{'

skip

relInvok <- many (try pRelInvocation)

skip

oclExpre <- many (try pOCLWSemi)

skip

char '}'

return ( Just (QVTR.WhenWhere relInvok oclExpre) )

pOCLWSemi :: CharParser st QVTR.OCL

pOCLWSemi = do

e <- pOCLExpression

skip

char ';'

return e

-- <RelInvocation> ::= <identifier> '(' (<identifier> ',')* ')' ';'

pRelInvocation :: CharParser st QVTR.RelInvok

pRelInvocation = do

skip

nam <- pIdentifier

skip

char '('

skip

params <- pCommaSep (skip >> pIdentifier << skip)

skip

char ')'

skip

char ';'

return ( QVTR.RelInvok nam params )

-- Auxiliary definitions

lineComment :: CharParser st String

lineComment = tryString "--" <++> many (noneOf "\n")

skip :: CharParser st ()

skip = skipMany $ forget space

<|> forget (nestedComment "/*" "*/" <|> lineComment)

pChar :: CharParser st Char

pChar = alphaNum <|> oneOf "_'"

pKeyS :: String -> CharParser st String

pKeyS s = try (string s << notFollowedBy pChar) << skip

pKey :: String -> CharParser st ()

pKey = forget . pKeyS

pColon :: CharParser st ()

pColon = pSym ":"

pSymS :: String -> CharParser st String

pSymS s = tryString s << skip

pSym :: String -> CharParser st ()

pSym = forget . pSymS

pComma :: CharParser st ()

pComma = pSym ","

pEqual :: CharParser st ()

pEqual = pSym "="

pBetParent :: CharParser st a -> CharParser st a

pBetParent = between (char '(') (char ')')

pBetBraces :: CharParser st a -> CharParser st a

pBetBraces = between (char '{') (char '}')

pCommaSep :: CharParser st a -> CharParser st [a]

pCommaSep p = p `sepBy` char ','

pSemiSep :: CharParser st a -> CharParser st [a]

pSemiSep p = p `sepBy` char ';'

pColonSep :: CharParser st a -> CharParser st [a]

pColonSep p = p `sepBy` char ':'

pIdentifier :: CharParser st String

pIdentifier = do

skip

c <- letter

rest <- many (alphaNum <|> oneOf "_")

return (c : rest)

{- FAKE OCL PARSER

<OclExpressionCS> ::= '(' <OclExpressionCS> ')'

<String>

<Const>

<OclExpressionCS> <Duop> <OclExpressionCS>

<Unop> <OclExpressionCS>

<String> '=' <String> -}

--

{- <Const> ::= 'true' | 'false'

<Unop> ::= 'not'

<Duop> ::= 'and' | 'or' -}

--

{- <String> ::= ''' <text> '''

<identifier>

<String> '+' <String> -}

pOCLExpression :: CharParser st QVTR.OCL

pOCLExpression = do

skip

try pOCLConst

<|> try pUnop

<|> try pDuopAnd

<|> try pDuopOr

<|> try pEqualExpre

<|> do ex <- try $ pBetParent pOCLExpression

return ( QVTR.Paren ex )

<|> do s <- try pOCLSTRING

return ( QVTR.StringExp s )

pUnop :: CharParser st QVTR.OCL

pUnop = do

skip

pKey "not"

skip

char '('

skip

e <- try pOCLExpression

skip

char ')'

return ( QVTR.NotB e )

-- Prefix form. This MUST be changed

pEqualExpre :: CharParser st QVTR.OCL

pEqualExpre = do

skip

pKey "="

skip

char '('

skip

ex1 <- try pOCLSTRING

skip

char ')'

skip

char '('

skip

ex2 <- try pOCLSTRING

skip

char ')'

return ( QVTR.Equal ex1 ex2 )

-- Prefix form. This MUST be changed

pDuopAnd :: CharParser st QVTR.OCL

pDuopAnd = do

skip

pKey "and"

skip

char '('

skip

ex1 <- try pOCLExpression

skip

char ')'

skip

char '('

skip

ex2 <- try pOCLExpression

skip

char ')'

return ( QVTR.AndB ex1 ex2 )

-- Prefix form. This MUST be changed

pDuopOr :: CharParser st QVTR.OCL

pDuopOr = do

skip

pKey "or"

skip

char '('

skip

ex1 <- try pOCLExpression

skip

char ')'

skip

char '('

skip

ex2 <- try pOCLExpression

skip

char ')'

return ( QVTR.OrB ex1 ex2 )

pOCLConst :: CharParser st QVTR.OCL

pOCLConst = do pKey "true"

return ( QVTR.BExp True )

<|> do pKey "false"

return ( QVTR.BExp False )

pOCLSTRING :: CharParser st QVTR.STRING

pOCLSTRING = do ls <- try pOCLSingleSTRING

skip

do rs <- try pStringConcat

return ( QVTR.ConcatExp (QVTR.Str ls) rs )

<|> return ( QVTR.Str ls )

<|> do ls <- try pIdentifier

skip

do rs <- try pStringConcat

return ( QVTR.ConcatExp (QVTR.VarExp ls) rs )

<|> return ( QVTR.VarExp ls )

pStringConcat :: CharParser st QVTR.STRING

pStringConcat = do

char '+'

skip

try pOCLSTRING

pOCLSingleSTRING :: CharParser st String

pOCLSingleSTRING = do

char '\''

skip

many (noneOf "\'") << oneOf "\'"

pEverything :: CharParser st String

pEverything = do

skip

many (noneOf ",;{}") << oneOf ",;"