72 lines
1.7 KiB
Haskell
72 lines
1.7 KiB
Haskell
|
module Datalog.Parser
|
||
|
|
( parseTerm
|
||
|
|
, parseAtom
|
||
|
|
, parseRule
|
||
|
|
, parseQuery
|
||
|
|
, parseProgram
|
||
|
|
)
|
||
|
|
where
|
||
|
|
|
||
|
|
import Datalog.Syntax
|
||
|
|
import Data.Text (Text)
|
||
|
|
import Data.Text qualified as T
|
||
|
|
import Data.Void (Void)
|
||
|
|
import Text.Megaparsec
|
||
|
|
import Text.Megaparsec.Char
|
||
|
|
import Text.Megaparsec.Char.Lexer qualified as L
|
||
|
|
|
||
|
|
type Parser = Parsec Void Text
|
||
|
|
|
||
|
|
lexeme :: (MonadParsec e Text m) => m a -> m a
|
||
|
|
lexeme = L.lexeme whitespace
|
||
|
|
|
||
|
|
symbol :: (MonadParsec e Text m) => Text -> m Text
|
||
|
|
symbol = L.symbol whitespace
|
||
|
|
|
||
|
|
whitespace :: (MonadParsec e Text m) => m ()
|
||
|
|
whitespace = L.space
|
||
|
|
space1
|
||
|
|
(L.skipLineComment "--")
|
||
|
|
(L.skipBlockComment "{-" "-}")
|
||
|
|
|
||
|
|
parens :: (MonadParsec e Text m) => m a -> m a
|
||
|
|
parens = between (symbol "(") (symbol ")")
|
||
|
|
|
||
|
|
comma, period :: (MonadParsec e Text m) => m ()
|
||
|
|
comma = () <$ symbol ","
|
||
|
|
period = () <$ symbol "."
|
||
|
|
|
||
|
|
parseCon :: (MonadParsec e Text m) => m Term
|
||
|
|
parseCon = Con . ConId . T.pack <$> lexeme (liftA2 (:) (numberChar <|> lowerChar) (many alphaNumChar))
|
||
|
|
|
||
|
|
parseVar :: (MonadParsec e Text m) => m Term
|
||
|
|
parseVar = Var . VarId . T.pack <$> lexeme (liftA2 (:) upperChar (many alphaNumChar))
|
||
|
|
|
||
|
|
parseTerm :: Parser Term
|
||
|
|
parseTerm = parseVar <|> parseCon
|
||
|
|
|
||
|
|
parseAtom :: Parser Atom
|
||
|
|
parseAtom = do
|
||
|
|
rel <- RelId . T.pack <$> lexeme (liftA2 (:) lowerChar (many alphaNumChar))
|
||
|
|
args <- parens (parseTerm `sepBy` comma)
|
||
|
|
return (Atom rel args)
|
||
|
|
|
||
|
|
parseQuery :: Parser [Atom]
|
||
|
|
parseQuery = parseAtom `sepBy` comma
|
||
|
|
|
||
|
|
parseFact :: Parser Rule
|
||
|
|
parseFact = do
|
||
|
|
headAtom <- parseAtom
|
||
|
|
period
|
||
|
|
return (headAtom :- [])
|
||
|
|
|
||
|
|
parseRule :: Parser Rule
|
||
|
|
parseRule = try parseFact <|> do
|
||
|
|
headAtom <- parseAtom <* symbol ":-"
|
||
|
|
bodyAtoms <- parseQuery
|
||
|
|
period
|
||
|
|
return (headAtom :- bodyAtoms)
|
||
|
|
|
||
|
|
parseProgram :: Parser Program
|
||
|
|
parseProgram = Program <$> many parseRule
|