This commit is contained in:
George Thomas 2026-03-03 11:14:25 +00:00
parent 902fb4e0b5
commit 8dc5cd3c17
2 changed files with 73 additions and 69 deletions

View File

@ -1,18 +1,18 @@
{-# LANGUAGE MultilineStrings #-}
module Datalog.Parser
( parseTerm
, parseAtom
, parseRule
, parseQuery
, parseProgram
)
where
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 Datalog.Syntax
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L
@ -27,7 +27,8 @@ symbol :: (MonadParsec e Text m) => Text -> m Text
symbol = L.symbol whitespace
whitespace :: (MonadParsec e Text m) => m ()
whitespace = L.space
whitespace =
L.space
space1
(L.skipLineComment "--")
(L.skipBlockComment "{-" "-}")
@ -64,7 +65,8 @@ parseFact = do
return (Rule () headAtom [])
parseRule :: Parser Rule
parseRule = try parseFact <|> do
parseRule =
try parseFact <|> do
headAtom <- parseAtom <* symbol ":-"
bodyAtoms <- parseQuery
period
@ -73,7 +75,7 @@ parseRule = try parseFact <|> do
parseProgram :: Parser Program
parseProgram = Program () <$> many parseRule
annotateSrcLoc :: Functor f => Parser (f a) -> Parser (f SrcLoc)
annotateSrcLoc :: (Functor f) => Parser (f a) -> Parser (f SrcLoc)
annotateSrcLoc p = do
s <- getSourcePos
res <- p
@ -83,13 +85,15 @@ annotateSrcLoc p = do
data SrcLoc = SrcLoc
{ start :: SourcePos
, end :: SourcePos
} deriving Show
}
deriving (Show)
test = do
let r = runParser parseProgram "???" prog
pPrint @IO r
prog = """
prog =
"""
odd(X,Y) :- r(X,Y).
odd(X,Y) :- even(X,Z), r(Z,Y).
even(X,Y) :- odd(X,Z), r(Z,Y).

View File

@ -3,10 +3,10 @@
module Datalog.Syntax where
import Data.Char (isUpper)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Data.Set qualified as Set
import Data.Set (Set)
newtype ConId = ConId Text
deriving (Eq, Ord, Show)
@ -56,7 +56,7 @@ instance HasConstants (Term' a) where
Con _ x -> Set.singleton x
Var _ _ -> Set.empty
instance HasConstants a => HasConstants [a] where
instance (HasConstants a) => HasConstants [a] where
constants xs = Set.unions (map constants xs)
instance HasConstants (Atom' a) where