patrickaldis/geolog-lsp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

format

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
datalog/src/Datalog/Parser.hs
View File

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

6
datalog/src/Datalog/Syntax.hs
View File

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