Parse.hs revision 84e479fad2abd5bbb9fe08f571707af929a2e0b6
c797f343be2f3619bb1f5569753166ec49d27bdbChristian Maeder{- |
c797f343be2f3619bb1f5569753166ec49d27bdbChristian MaederModule : $Header$
81d182b21020b815887e9057959228546cf61b6bChristian MaederDescription : ADL syntax parser
10397bcc134edbcfbe3ae2c7ea4c6080036aae22Christian MaederCopyright : (c) Stef Joosten, Christian Maeder DFKI GmbH 2010
97018cf5fa25b494adffd7e9b4e87320dae6bf47Christian MaederLicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt
c797f343be2f3619bb1f5569753166ec49d27bdbChristian Maeder
3f69b6948966979163bdfe8331c38833d5d90ecdChristian MaederMaintainer : Christian.Maeder@dfki.de
c797f343be2f3619bb1f5569753166ec49d27bdbChristian MaederStability : provisional
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaederPortability : portable
f3a94a197960e548ecd6520bb768cb0d547457bbChristian Maeder
f3a94a197960e548ecd6520bb768cb0d547457bbChristian Maeder-}
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maeder
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maedermodule Main where
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maederimport Common.Parsec
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maederimport Common.DocUtils
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maederimport Common.Doc hiding (space)
59c301c268f79cfde0a4c30a2c572a368db98da5Christian Maederimport System.Environment
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maederimport Text.ParserCombinators.Parsec
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maederimport Haskell.Wrapper
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maeder
23a00c966f2aa8da525d7a7c51933c99964426c0Christian Maederimport Adl.As
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maederimport Adl.Print ()
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maederkeywordstxt :: [String]
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maederkeywordstxt =
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maeder [ "CONTEXT", "ENDCONTEXT", "EXTENDS"
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian Maeder , "PATTERN", "ENDPATTERN"
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder , "SERVICE", "INITIAL", "SQLPLUG", "PHPPLUG"
10397bcc134edbcfbe3ae2c7ea4c6080036aae22Christian Maeder , "POPULATION", "CONTAINS"
b984ff0ba75221f64451c1e69b3977967d4e99a1Christian Maeder , "UNI", "INJ", "SUR", "TOT", "SYM", "ASY", "TRN", "RFX", "PROP", "ALWAYS"
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder , "RULE", "MAINTAINS", "SIGNALS", "SIGNAL", "ON"
ad270004874ce1d0697fb30d7309f180553bb315Christian Maeder , "RELATION", "CONCEPT", "KEY"
ad270004874ce1d0697fb30d7309f180553bb315Christian Maeder , "IMPORT", "GEN", "ISA", "I", "V", "S"
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder , "PRAGMA", "EXPLANATION", "EXPLAIN", "IN", "REF", "ENGLISH", "DUTCH"
89054b2b95a3f92e78324dc852f3d34704e2ca49Christian Maeder , "ONE", "BIND", "TOPHP", "BINDING"
b984ff0ba75221f64451c1e69b3977967d4e99a1Christian Maeder ]
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maederskip :: CharParser st ()
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maederskip = skipMany $ forget space <|> forget (nestComment <|> lineComment)
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpChar :: CharParser st Char
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpChar = alphaNum <|> oneOf "_'"
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpKeyS :: String -> CharParser st String
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian MaederpKeyS s = try (string s << notFollowedBy pChar) << skip
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpKey :: String -> CharParser st ()
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpKey = forget . pKeyS
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpSymC :: String -> String -> CharParser st String
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpSymC s cs = try (string s << notFollowedBy (oneOf cs)) << skip
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder-- do not parse a double colon
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpColon :: CharParser st String
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpColon = pSymC ":" ":"
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maeder-- do not parse --, ->, or -|
27912d626bf179b82fcb337077e5cd9653bb71cfChristian MaederpMinus :: CharParser st String
ee6c748be810b24e3c70ffd74f291c7394e389f5Christian MaederpMinus = pSymC "-" "->|"
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian MaederpSymS :: String -> CharParser st String
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian MaederpSymS s = tryString s << skip
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpSym :: String -> CharParser st ()
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpSym = forget . pSymS
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpComma :: CharParser st ()
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpComma = pSym ","
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian MaederpEqual :: CharParser st ()
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian MaederpEqual = pSym "="
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian MaederpGenParens :: String -> String -> CharParser st a -> CharParser st a
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaederpGenParens o c p =
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder pSym o >> p << pSym c
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaederpParens :: CharParser st a -> CharParser st a
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpParens = pGenParens "(" ")"
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian MaederpSqBrackets :: CharParser st a -> CharParser st a
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaederpSqBrackets = pGenParens "[" "]"
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian MaederpConid :: CharParser st String
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaederpConid = reserved keywordstxt (upper <:> many pChar) << skip
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian MaederpVarid :: CharParser st String
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaederpVarid = (lower <:> many pChar) << skip
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpString :: CharParser st String
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpString = (stringLit <|> charLit) << skip
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpADLid :: CharParser st String
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpADLid = pConid <|> pVarid <|> pString
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpArchitecture :: CharParser st [PatElem]
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian MaederpArchitecture = flat $ many1 pContext
59c301c268f79cfde0a4c30a2c572a368db98da5Christian Maeder
59c301c268f79cfde0a4c30a2c572a368db98da5Christian MaederpContext :: CharParser st [PatElem]
59c301c268f79cfde0a4c30a2c572a368db98da5Christian MaederpContext = do
cdb141ee48c3a96e620186de94316c562037a2e0Christian Maeder pKey "CONTEXT"
cdb141ee48c3a96e620186de94316c562037a2e0Christian Maeder pConid
ad187062b0009820118c1b773a232e29b879a2faChristian Maeder option () $ do
cdb141ee48c3a96e620186de94316c562037a2e0Christian Maeder pColon
cdb141ee48c3a96e620186de94316c562037a2e0Christian Maeder pExpr
cdb141ee48c3a96e620186de94316c562037a2e0Christian Maeder forget $ optionL $ do
ad187062b0009820118c1b773a232e29b879a2faChristian Maeder pKey "BINDING"
b984ff0ba75221f64451c1e69b3977967d4e99a1Christian Maeder sepBy1 pBind pComma
cdb141ee48c3a96e620186de94316c562037a2e0Christian Maeder optionL $ do
cdb141ee48c3a96e620186de94316c562037a2e0Christian Maeder pKey "EXTENDS"
59c301c268f79cfde0a4c30a2c572a368db98da5Christian Maeder sepBy1 pConid pComma
59c301c268f79cfde0a4c30a2c572a368db98da5Christian Maeder ps <- many pContextElement
cdb141ee48c3a96e620186de94316c562037a2e0Christian Maeder pKey "ENDCONTEXT"
59c301c268f79cfde0a4c30a2c572a368db98da5Christian Maeder return $ concat ps
59c301c268f79cfde0a4c30a2c572a368db98da5Christian Maeder
59c301c268f79cfde0a4c30a2c572a368db98da5Christian MaederpBind :: CharParser st String
b984ff0ba75221f64451c1e69b3977967d4e99a1Christian MaederpBind = pKey "BIND" >> pDeclaration << pKey "TOPHP" >> (pConid <|> pString)
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder
59c301c268f79cfde0a4c30a2c572a368db98da5Christian MaederpContextElement :: CharParser st [PatElem]
59c301c268f79cfde0a4c30a2c572a368db98da5Christian MaederpContextElement = pPattern <|> fmap (const [])
59c301c268f79cfde0a4c30a2c572a368db98da5Christian Maeder (pDeclaration <|> pConceptDef <|> pKeyDef
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder <|> pObjDef <|> pSqlplug <|> pPhpplug <|> pExplain
59c301c268f79cfde0a4c30a2c572a368db98da5Christian Maeder <|> (pKey "POPULATION" >> pMorphism << pKey "CONTAINS" >> pContent))
59c301c268f79cfde0a4c30a2c572a368db98da5Christian Maeder
cdb141ee48c3a96e620186de94316c562037a2e0Christian MaederpPattern :: CharParser st [PatElem]
31a189d4cff554f78407cdc422480e84e99a6ec6Christian MaederpPattern = pKey "PATTERN" >> (pConid <|> pString)
31a189d4cff554f78407cdc422480e84e99a6ec6Christian Maeder >> many pPatElem
31a189d4cff554f78407cdc422480e84e99a6ec6Christian Maeder << pKey "ENDPATTERN"
59c301c268f79cfde0a4c30a2c572a368db98da5Christian Maeder
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpPatElem :: CharParser st PatElem
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian MaederpPatElem = pDeclaration <|> fmap Pr pRuleDef
31a189d4cff554f78407cdc422480e84e99a6ec6Christian Maeder <|> pGen <|> fmap (const Ignored)
31a189d4cff554f78407cdc422480e84e99a6ec6Christian Maeder (pConceptDef <|> pKeyDef <|> pExplain)
ee9eddfa6953868fd6fbaff0d9ff68675a13675aChristian Maeder
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederpDeclaration :: CharParser st PatElem
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaederpDeclaration = do
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder n <- try $ pVarid << pSym "::"
c797f343be2f3619bb1f5569753166ec49d27bdbChristian Maeder c1 <- pConcept
15bb922b665fcd44c6230a1202785d0c7890e90cChristian Maeder s <- pSymS "*" <|> pSymS "->"
15bb922b665fcd44c6230a1202785d0c7890e90cChristian Maeder let ps = if s == "->" then [Uni, Tot] else []
32a7cc7177ecf70e35ec831ff86887b9acc40dcaChristian Maeder 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 ()
pLabelProps = do
pADLid
optionL $ pGenParens "{" "}" $ sepBy1 pADLid pComma
forget $ pColon
pKeyAtt :: CharParser st Expression
pKeyAtt = do
option () $ try pLabelProps
pExpr
pObjDef :: CharParser st PatElem
pObjDef = pKey "SERVICE" >> pObj >> return Ignored
pObj :: CharParser st Expression
pObj = pLabelProps >> pExpr
<< optionL (pKey "ALWAYS" >> many pProp')
<< optionL (pEqual >> pSqBrackets (sepBy pObj pComma))
pProp' :: CharParser st String
pProp' = choice $ map pKeyS ["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 <|> (charLit << 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
main :: IO ()
main = getArgs >>= mapM_ process
process :: String -> IO ()
process f = do
s <- readFile f
case parse (skip >> pArchitecture << eof) f s of
Right es -> print $ vcat $ map pretty es
Left err -> fail $ show err