{- |

Module : $Header$

Description : ADL syntax parser

Copyright : (c) Stef Joosten, Christian Maeder DFKI GmbH 2010

License : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt

Maintainer : Christian.Maeder@dfki.de

Stability : provisional

Portability : portable

-}

module Adl.Parse where

import Common.Parsec

import Common.Token (casl_structured_reserved_words)

import Text.ParserCombinators.Parsec

import Adl.As

keywordstxt :: [String]

keywordstxt =

[ "CONTEXT", "ENDCONTEXT", "EXTENDS"

, "PATTERN", "ENDPATTERN"

, "SERVICE", "INITIAL", "SQLPLUG", "PHPPLUG"

, "POPULATION", "CONTAINS"

, "UNI", "INJ", "SUR", "TOT", "SYM", "ASY", "TRN", "RFX", "PROP", "ALWAYS"

, "RULE", "MAINTAINS", "SIGNALS", "SIGNAL", "ON"

, "RELATION", "CONCEPT", "KEY"

, "IMPORT", "GEN", "ISA", "I", "V", "S"

, "PRAGMA", "EXPLANATION", "EXPLAIN", "IN", "REF", "ENGLISH", "DUTCH"

, "ONE", "BIND", "TOPHP", "BINDING"

]

-- | a line comment starts with --. In haskell this may be part of an operator.

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

pSymC :: String -> String -> CharParser st String

pSymC s cs = try (string s << notFollowedBy (oneOf cs)) << skip

-- do not parse a double colon

pColon :: CharParser st String

pColon = pSymC ":" ":"

-- do not parse --, ->, or -|

pMinus :: CharParser st String

pMinus = pSymC "-" "->|"

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 "="

pGenParens :: String -> String -> CharParser st a -> CharParser st a

pGenParens o c p =

pSym o >> p << pSym c

pParens :: CharParser st a -> CharParser st a

pParens = pGenParens "(" ")"

pSqBrackets :: CharParser st a -> CharParser st a

pSqBrackets = pGenParens "[" "]"

pConid :: CharParser st String

pConid = reserved keywordstxt (upper <:> many pChar) << skip

pVarid :: CharParser st String

pVarid = reserved casl_structured_reserved_words (lower <:> many pChar) << skip

pString :: CharParser st String

pString = (stringLit <|> sQuoted) << skip

pADLid :: CharParser st String

pADLid = pConid <|> pVarid <|> pString

-- | parse contexts but do not require CONTEXT blocks

pArchitecture :: CharParser st Context

pArchitecture = fmap Context $ flat $ many1

$ pContext <|> flat (many1 pContextElement)

pContext :: CharParser st [PatElem]

pContext = do

pKey "CONTEXT"

pConid

option () $ do

pColon

pExpr

forget $ optionL $ do

pKey "BINDING"

sepBy1 pBind pComma

optionL $ do

pKey "EXTENDS"

sepBy1 pConid pComma

ps <- many pContextElement

pKey "ENDCONTEXT"

return $ concat ps

pBind :: CharParser st String

pBind = pKey "BIND" >> pDeclaration << pKey "TOPHP" >> (pConid <|> pString)

-- | parse a context element but do not require the PATTERN block

pContextElement :: CharParser st [PatElem]

pContextElement = pPattern <|> many1 pPatElem

<|> fmap (: []) pObjDef

<|> fmap (const []) (pSqlplug <|> pPhpplug

<|> (pKey "POPULATION" >> pMorphism << pKey "CONTAINS" >> pContent))

pPattern :: CharParser st [PatElem]

pPattern = pKey "PATTERN" >> (pConid <|> pString)

>> many pPatElem

<< pKey "ENDPATTERN"

pPatElem :: CharParser st PatElem

pPatElem = pDeclaration <|> fmap Pr pRuleDef

<|> pGen <|> fmap (const Ignored)

(pConceptDef <|> pKeyDef <|> pExplain)

pDeclaration :: CharParser st PatElem

pDeclaration = do

n <- try $ pVarid << pSym "::"

c1 <- pConcept

s <- pSymS "*" <|> pSymS "->"

let ps = if s == "->" then [Uni, Tot] else []

c2 <- pConcept

as <- optionL pProps

optionL pPragma

optionL $ do

pKey "EXPLANATION"

pString

option () $ do

pEqual

pContent

return ()

pSym "."

return $ Pm (ps ++ as) $ Sgn n c1 c2

pProps :: CharParser st [Prop]

pProps = pSqBrackets $

sepBy (choice $ map (\ p -> pKey (showProp p) >> return p) allProps) pComma

pPragma :: CharParser st [String]

pPragma = pKey "PRAGMA" >> many1 pString

pConceptDef :: CharParser st PatElem

pConceptDef = do

pKey "CONCEPT"

pConcept

pString

optionL pString

return Ignored

pKeyDef :: CharParser st PatElem

pKeyDef = do

pKey "KEY"

pLabelProps

pConcept

pParens $ sepBy1 pKeyAtt pComma

return Ignored

pLabelProps :: CharParser st String

pLabelProps = do

n <- pADLid

optionL $ pGenParens "{" "}" $ sepBy1 pADLid pComma

pColon

return n

pKeyAtt :: CharParser st Expression

pKeyAtt = do

optionMaybe $ try pLabelProps

pExpr

pObjDef :: CharParser st PatElem

pObjDef = pKey "SERVICE" >> fmap Service pObj

pObj :: CharParser st Object

pObj = do

n <- pLabelProps

e <- pExpr

as <- optionL (pKey "ALWAYS" >> many pProp')

os <- optionL (pEqual >> pSqBrackets (sepBy pObj pComma))

return $ Object n e as os

pProp' :: CharParser st Prop

pProp' = choice $ map (\ p -> pKey (showProp p) >> return p) [Uni, Tot, Prop]

pSqlplug :: CharParser st PatElem

pSqlplug = pKey "SQLPLUG" >> pObj >> return Ignored

pPhpplug :: CharParser st PatElem

pPhpplug = pKey "PHPPLUG" >> pObj >> return Ignored

pExplain :: CharParser st PatElem

pExplain = do

pKey "EXPLAIN"

choice $ map pKey

[ "CONCEPT", "RELATION", "RULE", "KEY", "SERVICE", "PATTERN"

, "POPULATION", "SQLPLUG", "PHPPLUG" ]

pADLid

pLanguageID

pRefID

pExpl

return Ignored

pLanguageID :: CharParser st String

pLanguageID = pKey "IN" >> (pKeyS "DUTCH" <|> pKeyS "ENGLISH")

pRefID :: CharParser st String

pRefID = optionL $ pKey "REF" >> pString

pExpl :: CharParser st String

pExpl = nestedComment "{+" "-}"

pContent :: CharParser st PatElem

pContent = pSqBrackets (sepBy pRecord $ pSym ";") >> return Ignored

pRecord :: CharParser st (String, String)

pRecord = pParens $ pair pString $ pComma >> pString

pRuleDef :: CharParser st Rule

pRuleDef = do

option "" pSignalOrAlways

e1 <- pExpr

r <- option (Truth e1) $ do

sym <- choice $ map pSymS ["=", "|-", "-|"]

e2 <- pExpr

return $ Rule e1 (case sym of

"=" -> Equivalence

"|-" -> Implication

"-|" -> ReverseImpl

_ -> error "pRuleDef") e2

option "" $ do

pKey "EXPLANATION"

pString

return r

pSignalOrAlways :: CharParser st String

pSignalOrAlways =

(pKey "SIGNAL" >> pADLid << pKey "ON")

<|> (pKey "RULE" >> pADLid << (pKey "MAINTAINS" <|> pKey "SIGNALS"))

pGen :: CharParser st PatElem

pGen = do

pKey "GEN"

c1 <- pConcept

pKey "ISA"

c2 <- pConcept

return $ Pg c1 c2

pTwo :: CharParser st (Concept, Concept)

pTwo = option (Anything, Anything)

$ pSqBrackets $ do

c1 <- pConcept

c2 <- option c1 $ do

pSym "*"

pConcept

return (c1, c2)

pConcept :: CharParser st Concept

pConcept = fmap C $ pConid <|> pString <|> pKeyS "ONE"

pMorphism :: CharParser st Expression

pMorphism = do

nm <- pKeyS "I" <|> pKeyS "V" <|> pVarid <|> (sQuoted << skip)

(c1, c2) <- pTwo

return $ Tm $ Sgn nm c1 c2

pExpr :: CharParser st Expression

pExpr = pPrec Fu pFactorI "\\/"

pFactorI :: CharParser st Expression

pFactorI = pPrec Fi pFactor "/\\"

pFactor :: CharParser st Expression

pFactor = pPrec Fd pTermD "!"

pTermD :: CharParser st Expression

pTermD = pPrec Fc pTerm ";"

pPrec :: MulOp -> CharParser st Expression -> String

-> CharParser st Expression

pPrec f p s = do

es <- sepBy1 p $ pSym s

return $ case es of

[e] -> e

_ -> MulExp f es

pTerm :: CharParser st Expression

pTerm = do

ms <- many pMinus

e <- pParens pExpr <|> pMorphism

rs <- many $ choice $ map (pSymS . (: [])) "+*~"

let p = foldl (\ r c -> UnExp (case c of

"+" -> K1

"*" -> K0

"~" -> Co

_ -> error "pTerm post strings") r) e rs

return $ foldl (\ r _ -> UnExp Cp r) p ms