From 8744d977166cc418697104009092fb71145364ad Mon Sep 17 00:00:00 2001 From: Felix Dilke Date: Tue, 20 Jan 2026 16:49:53 +0000 Subject: [PATCH] initial vibecoding experiment with Grok: generated a Datalog parser --- haskell-experiments/haskell-experiments.cabal | 5 +- haskell-experiments/src/DatalogParser.hs | 188 ++++++++++++++++++ haskell-experiments/src/Ologs.hs | 120 ----------- haskell-experiments/test/Main.hs | 2 + .../test/Test/DatalogParserSpec.hs | 40 ++++ 5 files changed, 233 insertions(+), 122 deletions(-) create mode 100644 haskell-experiments/src/DatalogParser.hs create mode 100644 haskell-experiments/test/Test/DatalogParserSpec.hs diff --git a/haskell-experiments/haskell-experiments.cabal b/haskell-experiments/haskell-experiments.cabal index c1a1139..4d3e119 100644 --- a/haskell-experiments/haskell-experiments.cabal +++ b/haskell-experiments/haskell-experiments.cabal @@ -80,12 +80,13 @@ test-suite haskell-exps-test build-depends: base, hspec, langfeatures, megaparsec other-modules: Test.OlogsSpec, Test.SimpleParserSpec, - Test.ArithmeticParserSpec + Test.ArithmeticParserSpec, + Test.DatalogParserSpec library langfeatures build-depends: base, containers, megaparsec, parser-combinators, text hs-source-dirs: src - exposed-modules: Ologs, SimpleParser, ArithmeticParser + exposed-modules: Ologs, SimpleParser, ArithmeticParser, DatalogParser ghc-options: -Wall executable haskell-experiments diff --git a/haskell-experiments/src/DatalogParser.hs b/haskell-experiments/src/DatalogParser.hs new file mode 100644 index 0000000..a0fe356 --- /dev/null +++ b/haskell-experiments/src/DatalogParser.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module DatalogParser where + +import Data.Void +import Data.Text (Text) +import qualified Data.Text as T +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L +import Control.Monad (void) + +-- ┌───────────────────────────────────────────────┐ +-- │ Basic types │ +-- └───────────────────────────────────────────────┘ + +type Parser = Parsec Void Text + +data Term + = Var Text -- X, Person, Y1, etc. + | Sym Text -- alice, "london", uk + | Num Integer + deriving (Show, Eq, Ord) + +data Literal = Literal + { positive :: Bool -- negated = False + , predName :: Text + , arguments :: [Term] + } deriving (Show, Eq) + +data Head + = HeadSingle Literal -- only case + deriving (Show, Eq) + +-- data Head +-- = HeadSingle Literal -- usual case +-- | HeadMulti [Literal] -- disjunctive head (less common, but supported by some systems) +-- deriving (Show, Eq) + +data Statement + = Fact Literal -- p(a,b). + | Rule Head [Literal] -- p(X,Y) :- q(X,Z), r(Z,Y). + | Query [Text] [Literal] -- ?- p(X,Y), q(Y,Z). or ?- p(X,Y) → X,Y. + deriving (Show, Eq) + +-- ┌───────────────────────────────────────────────┐ +-- │ Lexer helpers │ +-- └───────────────────────────────────────────────┘ + +sc :: Parser () +sc = L.space space1 lineComment blockComment + where + lineComment = L.skipLineComment "--" + blockComment = L.skipBlockComment "/*" "*/" + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +symbol :: Text -> Parser Text +symbol = L.symbol sc + +parens :: Parser a -> Parser a +parens = between (symbol "(") (symbol ")") + +comma :: Parser () +comma = () <$ symbol "," + +dot :: Parser () +dot = () <$ symbol "." + +arrow :: Parser () +arrow = void $ symbol ":-" <|> symbol "→" <|> symbol "->" + +identifier :: Parser Text +identifier = T.pack <$> lexeme + (some (alphaNumChar <|> oneOf ['_','-'])) + +variable :: Parser Text +variable = T.pack <$> lexeme + ((:) <$> upperChar <*> many (alphaNumChar <|> char '_')) + +stringLit :: Parser Text +stringLit = T.pack <$> (char '"' *> manyTill L.charLiteral (char '"')) + +-- ┌───────────────────────────────────────────────┐ +-- │ Term parser │ +-- └───────────────────────────────────────────────┘ + +term :: Parser Term +term = choice + [ Var <$> try variable + , Sym <$> (stringLit <|> identifier) + , Num <$> L.signed sc L.decimal + ] "variable, symbol or number" + +-- ┌───────────────────────────────────────────────┐ +-- │ Literal / atom │ +-- └───────────────────────────────────────────────┘ + +literal :: Parser Literal +literal = do + neg <- (symbol "not" *> sc *> pure False) + <|> (symbol "!" *> sc *> pure False) + <|> pure True + name <- identifier + args <- parens (term `sepBy` comma) <|> pure [] + pure $ Literal neg name args + +-- ┌───────────────────────────────────────────────┐ +-- │ Head │ +-- └───────────────────────────────────────────────┘ + +parserHead :: Parser Head +parserHead = do + lits <- literal `sepBy1` (symbol ";" <* sc <|> symbol "or" <* sc) + pure $ HeadSingle (myHead lits) + where + myHead [x] = x + myHead _ = error "impossible: sepBy1" + +-- ┌───────────────────────────────────────────────┐ +-- │ Full Datalog statement │ +-- └───────────────────────────────────────────────┘ + +statement :: Parser Statement +statement = do + sc + choice $ + try <$> [ do -- Query + _ <- symbol "?-" + body <- literal `sepBy` (symbol "," <* sc) + choice + [ do arrow; sc; vars <- variable `sepBy` (symbol "," <* sc); dot; pure $ Query vars body + , dot *> pure (Query [] body) + , eof *> pure (Query [] body) + ] + + , do -- Rule: head :- body . + hd <- parserHead + arrow + body <- literal `sepBy` (symbol "," <* sc) + dot + pure $ Rule hd body + + , do -- Fact: atom . + lit <- literal + dot + pure $ Fact lit + + , do -- Fact without dot (interactive mode / last line) + lit <- literal + eof + pure $ Fact lit + ] + "Datalog statement (fact, rule or query)" + +-- ┌───────────────────────────────────────────────┐ +-- │ Runner │ +-- └───────────────────────────────────────────────┘ + +parseDatalog :: Text -> Either (ParseErrorBundle Text Void) Statement +parseDatalog = parse (statement <* sc <* eof) "" + +-- Multi-statement parser (for whole files) +parseDatalogFile :: Text -> Either (ParseErrorBundle Text Void) [Statement] +parseDatalogFile src = parse (many (statement <* sc)) "" src + +-- Typical examples it can now parse +-- text-- Fact +-- parent("alice", "bob"). + +-- -- Fact with variables (uncommon but allowed) +-- edge(X, Y). + +-- -- Rule +-- ancestor(X,Y) :- parent(X,Y). +-- ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y). + +-- -- Query styles +-- ?- parent(alice,X). +-- ?- ancestor(X,Y), not blocked(X,Y). +-- ?- knows(a,X), friend(X,Y) → X,Y. +-- ?- edge(A,B), edge(B,C) → A,C . + +-- -- With disjunction (rare but supported) +-- reached(X) :- start(X); via(Y), edge(Y,X). + diff --git a/haskell-experiments/src/Ologs.hs b/haskell-experiments/src/Ologs.hs index 377c6a0..803691e 100644 --- a/haskell-experiments/src/Ologs.hs +++ b/haskell-experiments/src/Ologs.hs @@ -25,14 +25,10 @@ module Ologs where import Control.Monad -import Data.Foldable (for_) import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe import Data.Traversable -import Debug.Trace data Arc dot = Arc { name :: String, @@ -54,107 +50,6 @@ data Olog dot = Olog } deriving (Show, Eq) -makeOlogOld :: - forall dot. - (Eq dot, Show dot) => - [dot] -> - [(String, dot, dot)] -> - [([String], [String])] -> - Either (MakeOlogError dot) (Olog dot) -makeOlogOld dots preArcs preIdentities = - case errors of - [] -> - Right $ - Olog - dots - (map (\(name, src, tgt) -> Arc {name = name, source = src, target = tgt}) preArcs) - ( (\(path1, path2) -> Identity {lhs = path1, rhs = path2}) <$> preIdentities - ) - err : _ -> Left err - where - errorUnless b e = if b then Nothing else Just e - errors :: [MakeOlogError dot] = arcErrors <> identityErrors - arcErrors = - concat . concat $ - map - ( fmap maybeToList . \(dotMapper, errorPrefix) -> - map (\arc@(name, _, _) -> (\dot -> errorUnless (dot `elem` dots) $ errorPrefix name dot) $ dotMapper arc) preArcs - ) - [ (\(_, src, _) -> src, UnknownSource), - (\(_, _, tgt) -> tgt, UnknownTarget) - ] - knownArcNames = map (\(name, _, _) -> name) preArcs - identityErrors :: [MakeOlogError dot] = - identityKnownArcErrors <> identityLhsJoinErrors <> identityRhsJoinErrors <> identityMismatchErrors - identityKnownArcErrors = - concat $ - map - ( \(lhs, rhs) -> - -- TODO: don't need to check triviality here - (if null lhs && null rhs then [ForbiddenTrivialIdentity] else []) - <> catMaybes - ( map - (\arcName -> errorUnless (arcName `elem` knownArcNames) $ UnknownArc arcName) - $ lhs <> rhs - ) - ) - preIdentities - namesToArcs :: Map String (dot, dot) = Map.fromList $ (\(s, src, tgt) -> (s, (src, tgt))) <$> preArcs - identityLhsJoinErrors = identityXhsJoinErrors NonJoiningExpressionLhs fst - identityRhsJoinErrors = identityXhsJoinErrors NonJoiningExpressionRhs snd - identityXhsJoinErrors :: - ([String] -> MakeOlogError dot) -> - (([String], [String]) -> [String]) -> - [MakeOlogError dot] - identityXhsJoinErrors errorFactory picker = catMaybes $ map (checkTerm errorFactory . picker) preIdentities - checkTerm :: ([String] -> MakeOlogError dot) -> [String] -> Maybe (MakeOlogError dot) - checkTerm errorFactory arcNames = errorUnless (targets == sources) $ errorFactory arcNames - where - arcs :: [(dot, dot)] = catMaybes $ flip Map.lookup namesToArcs <$> arcNames - targets :: [dot] = tail $ snd <$> arcs - sources :: [dot] = init $ fst <$> arcs - identityMismatchErrors = catMaybes $ checkMismatch <$> preIdentities - checkMismatch :: ([String], [String]) -> Maybe (MakeOlogError dot) - checkMismatch (lhs, rhs) = do - nonEmptyLhsAndSig <- case nonEmpty lhs of - Nothing -> - -- lhs empty - Just Nothing - Just nonEmptyLhs -> do - -- lhs non-empty - sig <- signature nonEmptyLhs - Just $ Just sig - nonEmptyRhsAndSig <- case nonEmpty rhs of - Nothing -> - -- rhs empty - Just Nothing - Just nonEmptyRhs -> do - -- rhs non-empty - sig <- signature nonEmptyRhs - Just $ Just sig - case (nonEmptyLhsAndSig, nonEmptyRhsAndSig) of - (Nothing, Nothing) -> - -- both empty - Just ForbiddenTrivialIdentity - (Just (src, tgt), Nothing) -> - -- right empty - errorUnless (src == tgt) $ NotALoop lhs - (Nothing, Just (src, tgt)) -> - -- left empty - errorUnless (src == tgt) $ NotALoop rhs - (Just lSig, Just rSig) -> - -- both non-empty - errorUnless (lSig == rSig) $ IdentityMismatch lhs rhs lSig rSig - where - signature :: NonEmpty String -> Maybe (dot, dot) - signature terms = - case Map.lookup (NE.last terms) namesToArcs of - Nothing -> Nothing - Just (src, _) -> - case Map.lookup (NE.head terms) namesToArcs of - Nothing -> Nothing - Just (_, tgt) -> Just (src, tgt) - -- type f $ x = f x -- type ($) f x = f x @@ -220,18 +115,3 @@ makeOlog dots preArcs preIdentities = do errorWhen b e = if b then Left e else Right () namesToArcs = Map.fromList $ (\(name, src, tgt) -> (name, (src, tgt))) <$> preArcs --- checkArc :: (PreArc dot -> dot, String) -> PreArc dot -> Maybe String --- checkArc (mapper, errorPrefix) preArc = --- if mapper preArc `elem` dots then Nothing else Just $ errorPrefix <> show dot --- checkers :: [(PreArc dot -> dot, String)] = --- [ (\(_, src, _) -> src, "bad source: "), --- (\(_, _, tgt) -> tgt, "bad target: ") --- ] --- applyChecker :: (PreArc dot -> dot, String) -> Maybe String --- applyChecker (mapper, prefix) = --- map mapper arcs --- rawStrings :: [Maybe String] = map applyChecker [ --- (\(_, src, _) -> src, "bad source: "), --- (\(_, _, tgt) -> tgt, "bad target: ") --- ] --- errors = [] diff --git a/haskell-experiments/test/Main.hs b/haskell-experiments/test/Main.hs index 586d9db..8a057d1 100644 --- a/haskell-experiments/test/Main.hs +++ b/haskell-experiments/test/Main.hs @@ -4,10 +4,12 @@ import Test.Hspec import qualified Test.OlogsSpec as Ologs import qualified Test.SimpleParserSpec as SimpleParserSpec import qualified Test.ArithmeticParserSpec as ArithmeticParserSpec +import qualified Test.DatalogParserSpec as DatalogParserSpec main :: IO () main = hspec $ do describe "Ologs" Ologs.spec describe "SimpleParser" SimpleParserSpec.spec describe "ArithmeticParser" ArithmeticParserSpec.spec + describe "DatalogParser" DatalogParserSpec.spec diff --git a/haskell-experiments/test/Test/DatalogParserSpec.hs b/haskell-experiments/test/Test/DatalogParserSpec.hs new file mode 100644 index 0000000..44a28d0 --- /dev/null +++ b/haskell-experiments/test/Test/DatalogParserSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# HLINT ignore "Use const" #-} +{-# HLINT ignore "Unused LANGUAGE pragma" #-} +{-# HLINT ignore "Avoid lambda" #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# LANGUAGE TypeApplications #-} + +module Test.DatalogParserSpec where + +import Test.Hspec +import DatalogParser + +-- checkParse :: String -> Expr -> Expectation +-- checkParse text expectedExpr = +-- parse parseExpr "" text `shouldBe` Right expectedExpr + +-- checkEval :: String -> Int -> Expectation +-- checkEval text expectedVal = +-- fmap eval (parse parseExpr "" text) `shouldBe` Right expectedVal + + +spec :: Spec +spec = do + describe "evaluate expressions" $ do + it "parsing facts" $ do + parseDatalog "parent(\"alice\", \"bob\")." `shouldBe` Right (Fact Literal { + positive = True, + predName = "parent", + arguments = [Sym "alice", Sym "bob"] + }) + + -- eval (BinaryExpr Add (Literal 2) (Literal 3) ) `shouldBe` 5 + -- eval (BinaryExpr Subtract (Literal 2) (Literal 3) ) `shouldBe` -1 + -- eval (BinaryExpr Multiply (Literal 2) (Literal 3) ) `shouldBe` 6 + -- eval (BinaryExpr Divide (Literal 7) (Literal 3) ) `shouldBe` 2 + -- eval (UnaryExpr Negate (Literal 7) ) `shouldBe` -7