1690N/A{- |

1690N/AModule : $Header$

1690N/ADescription : ADL syntax parser

1690N/ACopyright : (c) Stef Joosten, Christian Maeder DFKI GmbH 2010

1690N/ALicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt

1690N/A

1690N/AMaintainer : Christian.Maeder@dfki.de

1690N/AStability : provisional

1690N/APortability : portable

1690N/A

1690N/A-}

1690N/A

1690N/Amodule Adl.Parse where

1690N/A

1690N/Aimport Common.Parsec

1690N/Aimport Text.ParserCombinators.Parsec

1690N/A

1690N/Aimport Adl.As

1690N/A

1690N/Akeywordstxt :: [String]

1690N/Akeywordstxt =

1690N/A [ "CONTEXT", "ENDCONTEXT", "EXTENDS"

1690N/A , "PATTERN", "ENDPATTERN"

1690N/A , "SERVICE", "INITIAL", "SQLPLUG", "PHPPLUG"

3231N/A , "POPULATION", "CONTAINS"

1690N/A , "UNI", "INJ", "SUR", "TOT", "SYM", "ASY", "TRN", "RFX", "PROP", "ALWAYS"

1690N/A , "RULE", "MAINTAINS", "SIGNALS", "SIGNAL", "ON"

1690N/A , "RELATION", "CONCEPT", "KEY"

1690N/A , "IMPORT", "GEN", "ISA", "I", "V", "S"

2601N/A , "PRAGMA", "EXPLANATION", "EXPLAIN", "IN", "REF", "ENGLISH", "DUTCH"

2601N/A , "ONE", "BIND", "TOPHP", "BINDING"

2601N/A ]

2601N/A

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

2601N/AlineComment :: CharParser st String

2601N/AlineComment = tryString "--" <++> many (noneOf "\n")

2601N/A

2601N/Askip :: CharParser st ()

2601N/Askip = skipMany $ forget space

2601N/A <|> forget (nestedComment "{-" "-}" <|> lineComment)

2601N/A

2601N/ApChar :: CharParser st Char

2601N/ApChar = alphaNum <|> oneOf "_'"

2601N/A

2601N/ApKeyS :: String -> CharParser st String

2601N/ApKeyS s = try (string s << notFollowedBy pChar) << skip

2601N/A

1690N/ApKey :: String -> CharParser st ()

1690N/ApKey = forget . pKeyS

2601N/A

2601N/ApSymC :: String -> String -> CharParser st String

2601N/ApSymC s cs = try (string s << notFollowedBy (oneOf cs)) << skip

2601N/A

2601N/A-- do not parse a double colon

2601N/ApColon :: CharParser st String

2601N/ApColon = pSymC ":" ":"

2601N/A

2601N/A-- do not parse --, ->, or -|

2601N/ApMinus :: CharParser st String

1690N/ApMinus = pSymC "-" "->|"

2601N/A

2601N/ApSymS :: String -> CharParser st String

2601N/ApSymS s = tryString s << skip

2601N/A

2601N/ApSym :: String -> CharParser st ()

2601N/ApSym = forget . pSymS

2601N/A

1690N/ApComma :: CharParser st ()

1690N/ApComma = pSym ","

1690N/A

2439N/ApEqual :: CharParser st ()

1690N/ApEqual = pSym "="

2601N/A

2601N/ApGenParens :: String -> String -> CharParser st a -> CharParser st a

2601N/ApGenParens o c p =

2601N/A pSym o >> p << pSym c

2601N/A

2601N/ApParens :: CharParser st a -> CharParser st a

2601N/ApParens = pGenParens "(" ")"

2601N/A

1690N/ApSqBrackets :: CharParser st a -> CharParser st a

1690N/ApSqBrackets = pGenParens "[" "]"

1690N/A

1690N/ApConid :: CharParser st String

2601N/ApConid = reserved keywordstxt (upper <:> many pChar) << skip

2601N/A

2601N/ApVarid :: CharParser st String

2601N/ApVarid = (lower <:> many pChar) << skip

2601N/A

1690N/ApString :: CharParser st String

2601N/ApString = (stringLit <|> sQuoted) << skip

2601N/A

2601N/ApADLid :: CharParser st String

2601N/ApADLid = pConid <|> pVarid <|> pString

2601N/A

2601N/ApArchitecture :: CharParser st [PatElem]

2601N/ApArchitecture = flat $ many1 pContext

2601N/A

2601N/ApContext :: CharParser st [PatElem]

2601N/ApContext = do

2601N/A pKey "CONTEXT"

2601N/A pConid

2601N/A option () $ do

2601N/A pColon

2601N/A pExpr

2601N/A forget $ optionL $ do

2601N/A pKey "BINDING"

2601N/A sepBy1 pBind pComma

2601N/A optionL $ do

2601N/A pKey "EXTENDS"

2601N/A sepBy1 pConid pComma

2601N/A ps <- many pContextElement

1690N/A pKey "ENDCONTEXT"

1690N/A return $ concat ps

1690N/A

2601N/ApBind :: CharParser st String

2601N/ApBind = pKey "BIND" >> pDeclaration << pKey "TOPHP" >> (pConid <|> pString)

2601N/A

2601N/ApContextElement :: CharParser st [PatElem]

2601N/ApContextElement = pPattern

1690N/A <|> fmap (: [])

1690N/A (choice [pObjDef, pDeclaration, pConceptDef, pKeyDef, pExplain])

1690N/A <|> fmap (const []) (pSqlplug <|> pPhpplug

1690N/A <|> (pKey "POPULATION" >> pMorphism << pKey "CONTAINS" >> pContent))

1690N/A

1690N/ApPattern :: CharParser st [PatElem]

1690N/ApPattern = pKey "PATTERN" >> (pConid <|> pString)

1690N/A >> many pPatElem

1690N/A << pKey "ENDPATTERN"

1690N/A

1690N/ApPatElem :: CharParser st PatElem

1690N/ApPatElem = pDeclaration <|> fmap Pr pRuleDef

1690N/A <|> pGen <|> fmap (const Ignored)

2601N/A (pConceptDef <|> pKeyDef <|> pExplain)

1690N/A

1690N/ApDeclaration :: CharParser st PatElem

1690N/ApDeclaration = do

1690N/A n <- try $ pVarid << pSym "::"

1690N/A c1 <- pConcept

1690N/A s <- pSymS "*" <|> pSymS "->"

1690N/A let ps = if s == "->" then [Uni, Tot] else []

1690N/A c2 <- pConcept

1690N/A as <- optionL pProps

1690N/A optionL pPragma

1690N/A optionL $ do

2601N/A pKey "EXPLANATION"

2601N/A pString

1690N/A option () $ do

2601N/A pEqual

1690N/A pContent

2601N/A return ()

2601N/A pSym "."

1690N/A return $ Pm (ps ++ as) $ Sgn n c1 c2

2601N/A

2601N/ApProps :: CharParser st [Prop]

2601N/ApProps = pSqBrackets $

2601N/A sepBy (choice $ map (\ p -> pKey (showProp p) >> return p) allProps) pComma

2601N/A

2601N/ApPragma :: CharParser st [String]

2601N/ApPragma = pKey "PRAGMA" >> many1 pString

2601N/A

2601N/ApConceptDef :: CharParser st PatElem

2601N/ApConceptDef = do

2601N/A pKey "CONCEPT"

2601N/A pConcept

2603N/A pString

2601N/A optionL pString

2601N/A return Ignored

2601N/A

2601N/ApKeyDef :: CharParser st PatElem

2601N/ApKeyDef = do

2601N/A pKey "KEY"

2601N/A pLabelProps

2601N/A pConcept

2601N/A pParens $ sepBy1 pKeyAtt pComma

2601N/A return Ignored

2601N/A

2601N/ApLabelProps :: CharParser st String

2601N/ApLabelProps = do

2601N/A n <- pADLid

2601N/A optionL $ pGenParens "{" "}" $ sepBy1 pADLid pComma

2601N/A pColon

2601N/A return n

2601N/A

2601N/ApKeyAtt :: CharParser st Expression

2601N/ApKeyAtt = do

2601N/A optionMaybe $ try pLabelProps

2601N/A pExpr

2601N/A

2601N/ApObjDef :: CharParser st PatElem

2601N/ApObjDef = pKey "SERVICE" >> fmap Service pObj

2601N/A

2601N/ApObj :: CharParser st Object

2601N/ApObj = do

2601N/A n <- pLabelProps

2601N/A e <- pExpr

2601N/A as <- optionL (pKey "ALWAYS" >> many pProp')

2601N/A os <- optionL (pEqual >> pSqBrackets (sepBy pObj pComma))

2601N/A return $ Object n e as os

2601N/A

2601N/ApProp' :: CharParser st Prop

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

2601N/A

2601N/ApSqlplug :: CharParser st PatElem

2601N/ApSqlplug = pKey "SQLPLUG" >> pObj >> return Ignored

2601N/A

2601N/ApPhpplug :: CharParser st PatElem

2601N/ApPhpplug = pKey "PHPPLUG" >> pObj >> return Ignored

2601N/A

2601N/ApExplain :: CharParser st PatElem

2601N/ApExplain = do

2601N/A pKey "EXPLAIN"

2601N/A choice $ map pKey

2601N/A [ "CONCEPT", "RELATION", "RULE", "KEY", "SERVICE", "PATTERN"

2601N/A , "POPULATION", "SQLPLUG", "PHPPLUG" ]

2601N/A pADLid

2601N/A pLanguageID

2601N/A pRefID

2601N/A pExpl

2601N/A return Ignored

2601N/A

2601N/ApLanguageID :: CharParser st String

2601N/ApLanguageID = pKey "IN" >> (pKeyS "DUTCH" <|> pKeyS "ENGLISH")

2601N/A

2601N/ApRefID :: CharParser st String

2601N/ApRefID = optionL $ pKey "REF" >> pString

2601N/A

2601N/ApExpl :: CharParser st String

2601N/ApExpl = nestedComment "{+" "-}"

2601N/A

2601N/ApContent :: CharParser st PatElem

2601N/ApContent = pSqBrackets (sepBy pRecord $ pSym ";") >> return Ignored

2601N/A

2601N/ApRecord :: CharParser st (String, String)

2601N/ApRecord = pParens $ pair pString $ pComma >> pString

2601N/A

2601N/ApRuleDef :: CharParser st Rule

2601N/ApRuleDef = do

2601N/A option "" pSignalOrAlways

2601N/A e1 <- pExpr

2601N/A r <- option (Truth e1) $ do

2601N/A sym <- choice $ map pSymS ["=", "|-", "-|"]

2601N/A e2 <- pExpr

2601N/A return $ Rule e1 (case sym of

2601N/A "=" -> Equivalence

2601N/A "|-" -> Implication

2601N/A "-|" -> ReverseImpl

2601N/A _ -> error "pRuleDef") e2

2601N/A option "" $ do

2601N/A pKey "EXPLANATION"

2601N/A pString

2601N/A return r

2601N/A

2601N/ApSignalOrAlways :: CharParser st String

2601N/ApSignalOrAlways =

2601N/A (pKey "SIGNAL" >> pADLid << pKey "ON")

2601N/A <|> (pKey "RULE" >> pADLid << (pKey "MAINTAINS" <|> pKey "SIGNALS"))

2601N/A

2601N/ApGen :: CharParser st PatElem

2601N/ApGen = do

2601N/A pKey "GEN"

2601N/A c1 <- pConcept

2601N/A pKey "ISA"

2601N/A c2 <- pConcept

2601N/A return $ Pg c1 c2

2601N/A

2601N/ApTwo :: CharParser st (Concept, Concept)

2601N/ApTwo = option (Anything, Anything)

2601N/A $ pSqBrackets $ do

2601N/A c1 <- pConcept

2601N/A c2 <- option c1 $ do

2601N/A pSym "*"

2601N/A pConcept

2601N/A return (c1, c2)

2601N/A

2601N/ApConcept :: CharParser st Concept

2601N/ApConcept = fmap C $ pConid <|> pString <|> pKeyS "ONE"

2601N/A

2601N/ApMorphism :: CharParser st Expression

2601N/ApMorphism = do

2601N/A nm <- pKeyS "I" <|> pKeyS "V" <|> pVarid <|> (sQuoted << skip)

2601N/A (c1, c2) <- pTwo

2601N/A return $ Tm $ Sgn nm c1 c2

2601N/A

2601N/ApExpr :: CharParser st Expression

2601N/ApExpr = pPrec Fu pFactorI "\\/"

2601N/A

2601N/ApFactorI :: CharParser st Expression

2601N/ApFactorI = pPrec Fi pFactor "/\\"

2601N/A

2601N/ApFactor :: CharParser st Expression

2601N/ApFactor = pPrec Fd pTermD "!"

2601N/A

2601N/ApTermD :: CharParser st Expression

2601N/ApTermD = pPrec Fc pTerm ";"

2601N/A

2601N/ApPrec :: MulOp -> CharParser st Expression -> String

2601N/A -> CharParser st Expression

2601N/ApPrec f p s = do

2601N/A es <- sepBy1 p $ pSym s

2601N/A return $ case es of

2601N/A [e] -> e

2601N/A _ -> MulExp f es

2601N/A

2601N/ApTerm :: CharParser st Expression

2601N/ApTerm = do

2601N/A ms <- many pMinus

2601N/A e <- pParens pExpr <|> pMorphism

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

2601N/A let p = foldl (\ r c -> UnExp (case c of

2601N/A "+" -> K1

2601N/A "*" -> K0

2601N/A "~" -> Co

2601N/A _ -> error "pTerm post strings") r) e rs

2601N/A return $ foldl (\ r _ -> UnExp Cp r) p ms

2601N/A