Parse.hs revision 8468244da4da42d99833fd59dc1d00b09275158c
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder{- |
076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian MaederModule : $Header$
076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian MaederDescription : ADL syntax parser
076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian MaederCopyright : (c) Christian Maeder DFKI GmbH 2010
076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian MaederLicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt
076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian Maeder
076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian MaederMaintainer : Christian.Maeder@dfki.de
076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian MaederStability : provisional
076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian MaederPortability : portable
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder-}
076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian Maeder
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maedermodule Adl.Parse where
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder
e8ffec0fa3d3061061bdc16e44247b9cf96b050fChristian Maederimport Common.Parsec
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederimport Text.ParserCombinators.Parsec
e8ffec0fa3d3061061bdc16e44247b9cf96b050fChristian Maederimport Haskell.Wrapper
e8ffec0fa3d3061061bdc16e44247b9cf96b050fChristian Maeder
e8ffec0fa3d3061061bdc16e44247b9cf96b050fChristian Maederimport Adl.As
076b559b2ea7b2f1d303df992ae71cd6c6fe563cChristian Maeder
30203b61afb4393c8e459470b3a16d1fe26acc7fChristian Maederkeywordstxt :: [String]
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederkeywordstxt =
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder [ "CONTEXT", "ENDCONTEXT", "EXTENDS"
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder , "PATTERN", "ENDPATTERN"
c4e912fc181d72c8d0e0e38d0351278182f0d0b5Christian Maeder , "SERVICE", "INITIAL", "SQLPLUG", "PHPPLUG"
c4e912fc181d72c8d0e0e38d0351278182f0d0b5Christian Maeder , "POPULATION", "CONTAINS"
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder , "UNI", "INJ", "SUR", "TOT", "SYM", "ASY", "TRN", "RFX", "PROP", "ALWAYS"
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder , "RULE", "MAINTAINS", "SIGNALS", "SIGNAL", "ON"
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder , "RELATION", "CONCEPT", "KEY"
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder , "IMPORT", "GEN", "ISA", "I", "V", "S"
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder , "PRAGMA", "EXPLANATION", "EXPLAIN", "IN", "REF", "ENGLISH", "DUTCH"
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder , "ONE", "BIND", "TOPHP", "BINDING"
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder ]
1d330b771706686190ad2f3711ec5769c555c708Christian Maeder
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederkeywordsops :: [String]
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maederkeywordsops =
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder [ "-|", "|-", "-", "->", ">", "=", "~", "+", ";", "!", "*", "::", ":"
c18e9c3c6d5039618f1f2c05526ece84c7794ea3Christian Maeder , "\\/", "/\\", "\\", "/", "<>" ]
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederspecialchars :: String
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederspecialchars = "()[].,{}"
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maederskip :: CharParser st ()
e05956d1da3c97e4d808926f97c6841c4a561991Christian Maederskip = skipMany $ spaces <|> forget (nestComment <|> lineComment)
fe883661c9d1a5a8b42ac4e8673ec133d9dad354Christian Maeder
c18e9c3c6d5039618f1f2c05526ece84c7794ea3Christian MaederpKey :: String -> CharParser st ()
64558a09e6f6b95d2689d02dd5251339f8ac505bChristian MaederpKey = forget . pKeyS
64558a09e6f6b95d2689d02dd5251339f8ac505bChristian Maeder
c18e9c3c6d5039618f1f2c05526ece84c7794ea3Christian MaederpKeyS :: String -> CharParser st String
ac510075311023bf24175f7a76b89ec2bbda0626Christian MaederpKeyS s = try (string s << notFollowedBy letter) << skip
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder
c18e9c3c6d5039618f1f2c05526ece84c7794ea3Christian MaederpSym :: String -> CharParser st ()
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian MaederpSym = forget . pSymS
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder
ac510075311023bf24175f7a76b89ec2bbda0626Christian MaederpSymS :: String -> CharParser st String
8a1f427564a5ae2db32332512237ef645289c34dChristian MaederpSymS s = tryString s << skip
40b9c4f89adc2853a26acdbd11ed760d4ba96cf0Christian Maeder
613c474338a210f2aad9817376e5a3ce1fdde886Christian MaederpConid :: CharParser st String
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian MaederpConid = reserved keywordstxt (upper <:> many letter) << skip
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder
6e5180855658f12f9059d9041f447bf0935de344Christian MaederpVarid :: CharParser st String
8a1f427564a5ae2db32332512237ef645289c34dChristian MaederpVarid = (lower <:> many letter) << skip
e05956d1da3c97e4d808926f97c6841c4a561991Christian Maeder
c18e9c3c6d5039618f1f2c05526ece84c7794ea3Christian MaederpString :: CharParser st String
64558a09e6f6b95d2689d02dd5251339f8ac505bChristian MaederpString = stringLit <|> charLit
613c474338a210f2aad9817376e5a3ce1fdde886Christian Maeder
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian MaederpADLid :: CharParser st String
76fa667489c5e0868ac68de9f0253ac10f73d0b5Christian MaederpADLid = pConid <|> pVarid <|> pString
76fa667489c5e0868ac68de9f0253ac10f73d0b5Christian Maeder
76fa667489c5e0868ac68de9f0253ac10f73d0b5Christian MaederpArchitecture :: CharParser st [PatElem]
76fa667489c5e0868ac68de9f0253ac10f73d0b5Christian MaederpArchitecture = flat $ many1 pContext
76fa667489c5e0868ac68de9f0253ac10f73d0b5Christian Maeder
76fa667489c5e0868ac68de9f0253ac10f73d0b5Christian MaederpContext :: CharParser st [PatElem]
76fa667489c5e0868ac68de9f0253ac10f73d0b5Christian MaederpContext = do
fd5d3885a092ac0727fa2436cdfc3b248318ebd8Christian Maeder pKey "CONTEXT"
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder pConid
8a1f427564a5ae2db32332512237ef645289c34dChristian Maeder option () $ do
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder pSym ":"
b475a916d62584a2af5f51749240db7a5f0c8b82Christian Maeder pExpr
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder forget $ optionL $ do
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder pKey "BINDING"
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder sepBy1 pBind $ pSym ","
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder optionL $ do
fd5d3885a092ac0727fa2436cdfc3b248318ebd8Christian Maeder pKey "EXTENDS"
fd5d3885a092ac0727fa2436cdfc3b248318ebd8Christian Maeder sepBy1 pConid $ pSym ","
fd5d3885a092ac0727fa2436cdfc3b248318ebd8Christian Maeder ps <- many pContextElement
4be371b81d055e03a5946e4ec333613f313d689bChristian Maeder pKey "ENDCONTEXT"
4be371b81d055e03a5946e4ec333613f313d689bChristian Maeder return $ concat ps
4be371b81d055e03a5946e4ec333613f313d689bChristian Maeder
4be371b81d055e03a5946e4ec333613f313d689bChristian MaederpBind :: CharParser st String
4be371b81d055e03a5946e4ec333613f313d689bChristian MaederpBind = pKey "BIND" >> pDeclaration << pKey "TOPHP" >> (pConid <|> pString)
4be371b81d055e03a5946e4ec333613f313d689bChristian Maeder
4be371b81d055e03a5946e4ec333613f313d689bChristian MaederpContextElement :: CharParser st [PatElem]
4be371b81d055e03a5946e4ec333613f313d689bChristian MaederpContextElement = pPattern <|> fmap (const [])
4be371b81d055e03a5946e4ec333613f313d689bChristian Maeder (pDeclaration <|> pConceptDef <|> pKeyDef
4be371b81d055e03a5946e4ec333613f313d689bChristian Maeder <|> pObjDef <|> pSqlplug <|> pPhpplug <|> pExplain
4be371b81d055e03a5946e4ec333613f313d689bChristian Maeder <|> (pKey "POPULATION" >> pMorphism << pKey "CONTAINS" >> pContent))
4be371b81d055e03a5946e4ec333613f313d689bChristian Maeder
4be371b81d055e03a5946e4ec333613f313d689bChristian MaederpPattern :: CharParser st [PatElem]
4be371b81d055e03a5946e4ec333613f313d689bChristian MaederpPattern = pKey "PATTERN" >> (pConid <|> pString)
4be371b81d055e03a5946e4ec333613f313d689bChristian Maeder >> many pPatElem
4be371b81d055e03a5946e4ec333613f313d689bChristian Maeder << pKey "ENDPATTERN"
4be371b81d055e03a5946e4ec333613f313d689bChristian Maeder
4be371b81d055e03a5946e4ec333613f313d689bChristian MaederpPatElem :: CharParser st PatElem
ac510075311023bf24175f7a76b89ec2bbda0626Christian MaederpPatElem = fmap Pr pRuleDef
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder <|> pGen <|> pDeclaration <|> fmap (const Ignored)
4be371b81d055e03a5946e4ec333613f313d689bChristian Maeder (pConceptDef <|> pKeyDef <|> pExplain)
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder
ac510075311023bf24175f7a76b89ec2bbda0626Christian MaederpDeclaration :: CharParser st PatElem
ac510075311023bf24175f7a76b89ec2bbda0626Christian MaederpDeclaration = do
37bd4066d4a1d6bf8126681f920165aa9a873d91Christian Maeder n <- pVarid
31242f7541fd6ef179e4eb5be7522ddf54ae397bChristian Maeder pSym "::"
568a1ce407fd05a2007c5db3c5c57098bf13997fChristian Maeder c1 <- pConcept
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder s <- pSymS "*" <|> pSymS "->"
fd5d3885a092ac0727fa2436cdfc3b248318ebd8Christian Maeder let ps = if s == "->" then [Uni, Tot] else []
76fa667489c5e0868ac68de9f0253ac10f73d0b5Christian Maeder c2 <- pConcept
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder as <- optionL pProps
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder optionL pPragma
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder optionL $ do
7c57322afb6342e5cc8b1fdc96050b707407fc61Christian Maeder pKey "EXPLANATION"
7c57322afb6342e5cc8b1fdc96050b707407fc61Christian Maeder pString
76fa667489c5e0868ac68de9f0253ac10f73d0b5Christian Maeder optionL $ do
fd5d3885a092ac0727fa2436cdfc3b248318ebd8Christian Maeder pSym "="
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder pContent
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder pSym "."
ac510075311023bf24175f7a76b89ec2bbda0626Christian Maeder return $ Pm (ps ++ as) $ Sgn n c1 c2
pProps :: CharParser st [Prop]
pProps = do
pSym "["
ps <- sepBy1 (choice $ map (\ p -> pKey (showProp p) >> return p) allProps)
$ pSym ","
pSym "]"
return ps
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
pSym "("
sepBy1 pKeyAtt $ pSym ","
pSym ")"
return Ignored
pLabelProps :: CharParser st ()
pLabelProps = do
pADLid
optionL $ do
pSym "{"
ns <- sepBy1 pADLid $ pSym ","
pSym "}"
return ns
pKey ":"
pKeyAtt :: CharParser st Expression
pKeyAtt = do
option () $ try pLabelProps
pExpr
pObjDef = undefined
pSqlplug = undefined
pPhpplug = undefined
pExplain = undefined
pContent = undefined
pRuleDef :: CharParser st Rule
pRuleDef = do
option "" pSignalOrAlways
e1 <- pExpr
r <- option (Truth e1) $ do
sym <- choice $ map pSymS ["=", "|-", "-|"]
e2 <- pExpr
return $ case sym of
"=" -> Rule e1 Equivalence e2
"|-" -> Rule e1 Implication e2
"-|" -> Rule e2 Implication e1
_ -> error "pRuleDef"
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) $ do
pSym "["
c1 <- pConcept
c2 <- option c1 $ do
pKey "*"
pConcept
pSym "]"
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
(c1, c2) <- pTwo
return $ Tm $ Sgn nm c1 c2
pExpr :: CharParser st Expression
pExpr = do
es <- sepBy1 pFactorI $ pSym "\\/"
return $ case es of
[e] -> e
_ -> MulExp Fu es
pFactorI :: CharParser st Expression
pFactorI = do
es <- sepBy1 pFactor $ pSym "/\\"
return $ case es of
[e] -> e
_ -> MulExp Fi es
pFactor :: CharParser st Expression
pFactor = do
es <- sepBy1 pTermD $ pSym "!"
return $ case es of
[e] -> e
_ -> MulExp Fd es
pTermD :: CharParser st Expression
pTermD = do
es <- sepBy1 pTerm $ pSym ";"
return $ case es of
[e] -> e
_ -> MulExp Fc es
pTerm :: CharParser st Expression
pTerm = do
ms <- many $ char '-'
e <- (pSym "(" >> pExpr << pSym ")") <|> pMorphism
rs <- many $ choice $ map char "+*~"
let p = foldl (\ r c -> case c of
'+' -> UnExp K1 r
'*' -> UnExp K0 r
'~' -> UnExp Co r
_ -> error "pTerm post strings") e rs
return $ foldl (\ r _ -> UnExp Cp r) p ms