initial vibecoding experiment with Grok: generated a Datalog parser
This commit is contained in:
parent
e066e68818
commit
8744d97716
@ -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
|
||||
|
||||
188
haskell-experiments/src/DatalogParser.hs
Normal file
188
haskell-experiments/src/DatalogParser.hs
Normal file
@ -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).
|
||||
|
||||
@ -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 = []
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
40
haskell-experiments/test/Test/DatalogParserSpec.hs
Normal file
40
haskell-experiments/test/Test/DatalogParserSpec.hs
Normal file
@ -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
|
||||
Loading…
x
Reference in New Issue
Block a user