{- |
Module : ./Adl/Parse.hs
Description : ADL syntax parser
Copyright : (c) Stef Joosten, Christian Maeder DFKI GmbH 2010
License : GPLv2 or higher, see LICENSE.txt
Maintainer : Christian.Maeder@dfki.de
Stability : provisional
Portability : portable
-}
module Adl.Parse where
import Adl.As
import Common.Id
import Common.Lexer (parseToken)
import Common.Parsec
import Common.Token (criticalKeywords)
import Control.Monad
keywordstxt :: [String]
keywordstxt = map showUp allProps ++
[ "CONTEXT", "ENDCONTEXT", "EXTENDS"
, "PATTERN", "ENDPATTERN"
, "SERVICE", "INITIAL", "SQLPLUG", "PHPPLUG"
, "POPULATION", "CONTAINS"
, "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", "BYPLUG"
]
-- | 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
-- | with true argument exclude CASL keywords
pVarid :: Bool -> CharParser st String
pVarid b = (if b then reserved criticalKeywords else id)
$ ((lower <|> char '_') <:> many pChar) << skip
pString :: CharParser st String
pString = (stringLit <|> sQuoted) << skip
pADLid :: CharParser st Token
pADLid = parseToken $ pConid <|> pVarid False <|> pString
-- | parse contexts but do not require CONTEXT blocks
pArchitecture :: CharParser st Context
pArchitecture = pContext
<|> fmap (mkContext Nothing) (flat $ many1 $ pContextElement True)
pContext :: CharParser st Context
pContext = do
pKey "CONTEXT"
c <- parseToken pConid
option () $ do
pColon
pRule False
forget $ optionL $ do
pKey "BINDING"
sepBy1 pBind pComma
optionL $ do
pKey "EXTENDS"
sepBy1 pConid pComma
ps <- many $ pContextElement False
pKey "ENDCONTEXT"
return $ mkContext (Just c) $ concat ps
pBind :: CharParser st String
pBind = pKey "BIND" >> pDeclaration False << pKey "TOPHP"
>> (pConid <|> pString)
-- | parse a context element but do not require the PATTERN block
pContextElement :: Bool -> CharParser st [PatElem]
pContextElement b = pPattern <|> flat (many1 $ pPatElem b)
<|> single (pObjDef <|> pPopulation)
pPopulation :: CharParser st PatElem
pPopulation = do
pKey "POPULATION"
r <- pMorphism False
pKey "CONTAINS"
pContent False r
pPattern :: CharParser st [PatElem]
pPattern = pKey "PATTERN" >> (pConid <|> pString)
>> flat (many $ pPatElem False)
<< pKey "ENDPATTERN"
pPatElem :: Bool -> CharParser st [PatElem]
pPatElem b = pDeclaration b <|> pConceptDef <|> pExplain
<|> single (pRuleDef b <|> pGen <|> pKeyDef)
pDeclaration :: Bool -> CharParser st [PatElem]
pDeclaration b = do
n <- try $ parseToken (pVarid b) << pSym "::"
c1 <- pConcept
s <- parseToken $ pSymS "*" <|> pSymS "->"
let ps = if tokStr s == "->" then
map (flip RangedProp $ tokPos s) [Uni, Tot] else []
c2 <- pConcept
pByplug
as <- optionL pProps
pByplug
optionL pPragma
optionL $ do
pKey "EXPLANATION"
pString
let r = Sgn n $ RelType c1 c2
p <- optionL $ do
pEqual
single $ pContent True r
option () $ pSym "."
return $ Pm (ps ++ as) r (not $ null p) : p
pRangedProp :: Prop -> CharParser st RangedProp
pRangedProp p = liftM2 (flip RangedProp)
(liftM tokPos $ parseToken $ pKeyS $ showUp p) $ return p
pProps :: CharParser st [RangedProp]
pProps = pSqBrackets $ sepBy
(choice $ map pRangedProp allProps) pComma
pPragma :: CharParser st [String]
pPragma = pKey "PRAGMA" >> many1 pString
pByplug :: CharParser st Bool
pByplug = option False $ pKey "BYPLUG" >> return True
pConceptDef :: CharParser st [PatElem]
pConceptDef = do
pKey "CONCEPT"
pConcept
pByplug
pString
optionL pString
return []
pKeyDef :: CharParser st PatElem
pKeyDef = do
pKey "KEY"
t <- pLabelProps
c <- pConcept <|> (pKey "I" >> pSqBrackets pConcept)
let ks = sepBy1 pKeyAtt pComma
l <- pParens ks <|> pSqBrackets ks
return $ Pk $ KeyDef t c l
pLabelProps :: CharParser st Token
pLabelProps = do
n <- pADLid
optionL $ pGenParens "{" "}" $ sepBy1 pADLid pComma
option "" pColon
return n
pKeyAtt :: CharParser st KeyAtt
pKeyAtt = liftM2 KeyAtt (optionMaybe $ try pLabelProps) $ pRule False
choiceP :: (a -> CharParser st ()) -> [a] -> CharParser st a
choiceP p = choice . map (\ a -> p a >> return a)
choiceS :: Show a => (String -> CharParser st ()) -> [a] -> CharParser st a
choiceS p = choiceP $ p . show
pObjDef :: CharParser st PatElem
pObjDef = liftM2 Plug (choiceP (pKey . showUp)
[Service, Sqlplug, Phpplug]) pObj
pObj :: CharParser st Object
pObj = do
n <- pLabelProps
e <- pRule False <|> fmap (Tm . Sgn (mkSimpleId "I")) pTwo
as <- optionL (pKey "ALWAYS" >> many pProp')
os <- optionL (pEqual >> pSqBrackets (sepBy pObj pComma))
return $ Object n e as os
pProp' :: CharParser st RangedProp
pProp' = choice $ map pRangedProp [Uni, Tot, Prop]
pExplain :: CharParser st [PatElem]
pExplain = do
pKey "EXPLAIN"
choiceP pKey
[ "CONCEPT", "RELATION", "RULE", "KEY", "SERVICE", "PATTERN"
, "POPULATION", "SQLPLUG", "PHPPLUG" ]
pADLid
pLanguageID
pRefID
pExpl
return []
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 :: Bool -> Relation -> CharParser st PatElem
pContent b r = fmap (Population b r) $ pSqBrackets $ sepBy pRecord $ pSym ";"
pRecord :: CharParser st Pair
pRecord = let ps = parseToken pString in
pParens $ liftM2 Pair ps $ pComma >> ps
pRuleDef :: Bool -> CharParser st PatElem
pRuleDef b = do
h <- option Always pSignalOrAlways
r <- pRule $ b && h == Always
option () $ do
pKey "COMPUTING"
pMorphism False
return ()
option "" $ do
pKey "EXPLANATION"
pString
return $ Pr h r
pSignalOrAlways :: CharParser st RuleHeader
pSignalOrAlways =
fmap (RuleHeader SignalOn) (pKey "SIGNAL" >> pADLid << pKey "ON")
<|> (pKey "RULE" >> liftM2 (flip RuleHeader) pADLid
(choiceP (pKey . showRuleKind) [Maintains, Signals]))
pGen :: CharParser st PatElem
pGen = do
pKey "GEN"
c1 <- pConcept
pKey "ISA"
c2 <- pConcept
return $ Pg c1 c2
pTwo :: CharParser st RelType
pTwo = option (RelType Anything Anything)
$ pSqBrackets $ do
c1 <- pConcept
c2 <- option c1 $ do
pSym "*"
pConcept
return $ RelType c1 c2
pConcept :: CharParser st Concept
pConcept = fmap C . parseToken $ pConid <|> pString <|> pKeyS "ONE"
pMorphism :: Bool -> CharParser st Relation
pMorphism b = do
nm <- parseToken $ choiceP pKey bRels <|> pVarid b <|> (sQuoted << skip)
ty <- pTwo
return $ Sgn nm ty
pRule :: Bool -> CharParser st Rule
pRule = pPrec Re . pImpl
pImpl :: Bool -> CharParser st Rule
pImpl b = do
e <- pExpr b
option e $ do
o <- choiceS pSym [Ri, Rr]
es <- sepBy1 (pExpr False) $ pSym (show o)
return $ MulExp o $ e : es
pExpr :: Bool -> CharParser st Rule
pExpr = pPrec Fu . pFactorI
pFactorI :: Bool -> CharParser st Rule
pFactorI = pPrec Fi . pFactor
pFactor :: Bool -> CharParser st Rule
pFactor = pPrec Fd . pTermD
pTermD :: Bool -> CharParser st Rule
pTermD = pPrec Fc . pTerm
pPrec :: MulOp -> CharParser st Rule -> CharParser st Rule
pPrec f p = do
es <- sepBy1 p $ try $ pSym (show f) >> notFollowedBy (char '[')
-- to avoid conflict in objects
return $ case es of
[e] -> e
_ -> MulExp f es
pTerm :: Bool -> CharParser st Rule
pTerm b = do
ms <- many pMinus
e <- pParens (pRule False) <|> fmap Tm (pMorphism b)
rs <- many $ choiceS pSym [K0, K1, Co]
let p = foldl (flip UnExp) e rs
return $ foldl (\ r _ -> UnExp Cp r) p ms