diff --git a/collects/datalog/eval.rkt b/collects/datalog/eval.rkt index 38de442c24..82bf6b3deb 100644 --- a/collects/datalog/eval.rkt +++ b/collects/datalog/eval.rkt @@ -19,11 +19,13 @@ (format-literals ls))) (define (eval-program p) - (for-each (lambda (s) - (define v (eval-statement s)) - (unless (void? v) - (print-literals v))) - p)) + (for-each eval-top-level-statement p)) + +(define (eval-top-level-statement s) + (define v (eval-statement s)) + (unless (void? v) + (print-literals v))) + (define (eval-statement s) (cond [(assertion? s) @@ -53,5 +55,6 @@ (provide/contract [current-theory (parameter/c mutable-theory/c)] [eval-program (program/c . -> . void)] + [eval-top-level-statement (statement/c . -> . void)] [eval-statement (statement/c . -> . (or/c void (listof literal?)))] [eval-program/fresh (program/c . -> . immutable-theory/c)]) \ No newline at end of file diff --git a/collects/datalog/scribblings/racket.scrbl b/collects/datalog/scribblings/racket.scrbl index b3c6e0cc5f..b30111772d 100644 --- a/collects/datalog/scribblings/racket.scrbl +++ b/collects/datalog/scribblings/racket.scrbl @@ -175,7 +175,7 @@ This library provides the structures that represent Datalog syntax. It can be re } @defstruct[query ([srcloc srcloc/c] - [clause clause?])]{ + [literal literal?])]{ A Datalog query. } diff --git a/collects/datalog/sexp/lang.rkt b/collects/datalog/sexp/lang.rkt new file mode 100644 index 0000000000..d4433c9515 --- /dev/null +++ b/collects/datalog/sexp/lang.rkt @@ -0,0 +1,76 @@ +#lang racket +(require (for-syntax syntax/parse) + "../eval.rkt" + "../ast.rkt") + +(define-syntax (top stx) + (syntax-parse + stx + [(_ . sym:id) + (quasisyntax/loc stx + (constant #'#,stx 'sym))])) + +(define-syntax (unquote stx) + (syntax-parse + stx + [(_ sym:id) + (quasisyntax/loc stx + (variable #'#,stx 'sym))])) + +(define-syntax (datum stx) + (syntax-parse + stx + [(_ . sym:str) + (quasisyntax/loc stx + (constant #'#,stx 'sym))])) + +(define-syntax (->literal stx) + (syntax-parse + stx + [(_ sym:id) + (quasisyntax/loc stx + (literal #'#,stx 'sym empty))] + [(_ (sym:id e ...)) + (quasisyntax/loc stx + (literal #'#,stx 'sym (list e ...)))])) + +(define-syntax (->simple-clause stx) + (syntax-case stx () + [(_ e) + (quasisyntax/loc stx + (clause #'#,stx (->literal e) empty))])) + +(define-syntax (:- stx) + (syntax-case stx () + [(_ head body ...) + (quasisyntax/loc stx + (eval-top-level-statement + (assertion #'#,stx + (clause #'#,stx (->literal head) + (list (->literal body) ...)))))])) + +(define-syntax-rule (define-paren-stx op struct) + (define-syntax (op stx) + (syntax-case stx () + [(_ c) + (quasisyntax/loc stx + (eval-top-level-statement (struct #'#,stx (->simple-clause c))))]))) + +(define-paren-stx ! assertion) +(define-paren-stx ~ retraction) + +(define-syntax (? stx) + (syntax-case stx () + [(_ c) + (quasisyntax/loc stx + (eval-top-level-statement (query #'#,stx (->literal c))))])) + +(provide (rename-out [top #%top] + [datum #%datum] + #;[module-begin #%module-begin] + #;[top-interaction #%top-interaction]) + + #%module-begin + ! ~ ? + :- + unquote) \ No newline at end of file diff --git a/collects/datalog/sexp/lang/reader.rkt b/collects/datalog/sexp/lang/reader.rkt new file mode 100644 index 0000000000..546cb06409 --- /dev/null +++ b/collects/datalog/sexp/lang/reader.rkt @@ -0,0 +1,2 @@ +(module reader syntax/module-reader + #:language 'datalog/sexp/lang) \ No newline at end of file diff --git a/collects/datalog/tests/eval.rkt b/collects/datalog/tests/eval.rkt index 360f5a2854..b5c1241529 100644 --- a/collects/datalog/tests/eval.rkt +++ b/collects/datalog/tests/eval.rkt @@ -14,15 +14,16 @@ (define test-rkt (build-path examples-dir (format "~a.rkt" t))) (define test-txt (build-path examples-dir (format "~a.txt" t))) (test-equal? t - (filter (lambda (l) - (not (string=? l ""))) - (file->lines test-txt)) (filter (lambda (l) (not (string=? l ""))) (with-input-from-string (with-output-to-string (lambda () (dynamic-require test-rkt #f))) - port->lines)))) + port->lines)) + (filter (lambda (l) + (not (string=? l ""))) + (file->lines test-txt)) + )) (test-suite (path->string examples-dir) diff --git a/collects/datalog/tests/paren-examples/ancestor.txt b/collects/datalog/tests/paren-examples/ancestor.txt index bed107f84b..27724bbbfb 100644 --- a/collects/datalog/tests/paren-examples/ancestor.txt +++ b/collects/datalog/tests/paren-examples/ancestor.txt @@ -1,6 +1,6 @@ +ancestor(ebbon, douglas). +ancestor(ebbon, john). +ancestor(bob, douglas). ancestor(ebbon, bob). ancestor(bob, john). ancestor(john, douglas). -ancestor(bob, douglas). -ancestor(ebbon, john). -ancestor(ebbon, douglas). diff --git a/collects/datalog/tests/paren-examples/laps.rkt b/collects/datalog/tests/paren-examples/laps.rkt index abd48c5e82..4c68765f4e 100644 --- a/collects/datalog/tests/paren-examples/laps.rkt +++ b/collects/datalog/tests/paren-examples/laps.rkt @@ -2,7 +2,7 @@ ; Laps Test (! (contains ca store rams_couch rams)) (! (contains rams fetch rams_couch will)) -(:- (contains ca ,Fetch ,Name ,Watcher) +(:- (contains ca fetch ,Name ,Watcher) (contains ca store ,Name ,Owner) (contains ,Owner fetch ,Name ,Watcher)) (! (trusted ca))