From be5e487e3154fdf2e8a083e3f33b007933752c3d Mon Sep 17 00:00:00 2001 From: Patrick Aldis Date: Mon, 2 Mar 2026 16:19:40 +0000 Subject: [PATCH] refactor repo to datalog/datalog-lsp --- {src => datalog-lsp/src}/Main.hs | 2 +- datalog/src/Datalog/Parser.hs | 71 ++++++++++++++++++++++++++ datalog/src/Datalog/Syntax.hs | 86 ++++++++++++++++++++++++++++++++ geolog-lsp.cabal | 20 ++++++-- 4 files changed, 174 insertions(+), 5 deletions(-) rename {src => datalog-lsp/src}/Main.hs (98%) create mode 100644 datalog/src/Datalog/Parser.hs create mode 100644 datalog/src/Datalog/Syntax.hs diff --git a/src/Main.hs b/datalog-lsp/src/Main.hs similarity index 98% rename from src/Main.hs rename to datalog-lsp/src/Main.hs index c930065..7d7904b 100644 --- a/src/Main.hs +++ b/datalog-lsp/src/Main.hs @@ -35,7 +35,7 @@ handlers = , _tokenModifiers = [] } tokens = fromRight (error "failed") $ makeSemanticTokens defaultSemanticTokensLegend [token] - + c <- fromJust <$> getVirtualFile docUri responder (Right $ InL tokens) ] diff --git a/datalog/src/Datalog/Parser.hs b/datalog/src/Datalog/Parser.hs new file mode 100644 index 0000000..d5c8707 --- /dev/null +++ b/datalog/src/Datalog/Parser.hs @@ -0,0 +1,71 @@ +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 diff --git a/datalog/src/Datalog/Syntax.hs b/datalog/src/Datalog/Syntax.hs new file mode 100644 index 0000000..7ed4939 --- /dev/null +++ b/datalog/src/Datalog/Syntax.hs @@ -0,0 +1,86 @@ +module Datalog.Syntax where + +import Data.Char (isUpper) +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) + +newtype VarId = VarId Text + deriving (Eq, Ord, Show) + +newtype RelId = RelId Text + deriving (Eq, Ord, Show) + +data Term = Con ConId | Var VarId + deriving (Eq, Ord, Show) + +con :: Text -> Term +con = Con . ConId + +var :: Text -> Term +var = Var . VarId + +term :: Text -> Term +term t = if not (T.null t) && isUpper (T.head t) then var t else con t + +data Atom = Atom RelId [Term] + deriving (Eq, Ord, Show) + +atom :: Text -> [Text] -> Atom +atom relName args = Atom (RelId relName) (map term args) + +data Rule = Atom :- [Atom] + deriving (Eq, Ord, Show) + +data Program = Program [Rule] + deriving (Eq, Ord, Show) + +class HasConstants a where + constants :: a -> Set ConId + +instance HasConstants Term where + constants t = case t of + Con x -> Set.singleton x + Var _ -> Set.empty + +instance HasConstants a => HasConstants [a] where + constants xs = Set.unions (map constants xs) + +instance HasConstants Atom where + constants (Atom _ ts) = constants ts + +instance HasConstants Rule where + constants (h :- b) = Set.union (constants h) (constants b) + +instance HasConstants Program where + constants (Program rs) = constants rs + +class Pretty t where + pretty :: t -> Text + +instance Pretty ConId where + pretty (ConId t) = t + +instance Pretty VarId where + pretty (VarId t) = t + +instance Pretty RelId where + pretty (RelId t) = t + +instance Pretty Term where + pretty (Con conId) = pretty conId + pretty (Var varId) = pretty varId + +instance Pretty Atom where + pretty (Atom relId terms) = pretty relId <> "(" <> T.intercalate "," (map pretty terms) <> ")" + +instance Pretty Rule where + pretty (h :- []) = pretty h <> "." + pretty (h :- ts) = pretty h <> " :- " <> T.intercalate ", " (map pretty ts) <> "." + +instance Pretty Program where + pretty (Program rs) = T.unlines (map pretty rs) diff --git a/geolog-lsp.cabal b/geolog-lsp.cabal index adb0336..34051d5 100644 --- a/geolog-lsp.cabal +++ b/geolog-lsp.cabal @@ -18,17 +18,29 @@ common warnings common extensions default-extensions: OverloadedRecordDot + OverloadedStrings -executable geolog-lsp +library datalog-parser + import: warnings, extensions + build-depends: + base, + text, + containers, + megaparsec + exposed-modules: + Datalog.Parser, + Datalog.Syntax + hs-source-dirs: datalog/src + default-language: GHC2024 + +executable datalog-lsp import: warnings, extensions main-is: Main.hs - -- other-modules: - -- other-extensions: build-depends: base, lsp, text, containers, lens - hs-source-dirs: src + hs-source-dirs: datalog-lsp/src default-language: GHC2024