initial vibecoding experiment with Grok: generated a Datalog parser

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

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) "<datalog>"
+
+-- Multi-statement parser (for whole files)
+parseDatalogFile :: Text -> Either (ParseErrorBundle Text Void) [Statement]
+parseDatalogFile src = parse (many (statement <* sc)) "<datalog-file>" 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).
+

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 = []

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
 

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