Using the datalog reader for racklog

collects/datalog/eval.rkt

@@ -54,6 +54,7 @@
 
 (provide/contract
  [current-theory (parameter/c mutable-theory/c)]
+ [print-literals ((listof literal?) . -> . void)]
  [eval-program (program/c . -> . void)]
  [eval-top-level-statement (statement/c . -> . void)]
  [eval-statement (statement/c . -> . (or/c void (listof literal?)))]

collects/datalog/lang/reader.rkt

@@ -11,8 +11,7 @@
              [(color-lexer)
               (dynamic-require 'datalog/tool/syntax-color 'get-syntax-token)]
              [(configure-runtime)
-              (λ ()
-                (current-read-interaction even-read))]
+              (λ () (current-read-interaction even-read))]
              [else (default key defval)]))
   (require datalog/parse
            datalog/private/compiler)

collects/datalog/scribblings/datalog.scrbl

@@ -22,7 +22,7 @@ on tabling intermediate results ensures that all queries terminate.
 
 @table-of-contents[]
 
-@section{Datalog Module Language}
+@section[#:tag "datalog"]{Datalog Module Language}
 
 @defmodulelang[datalog]
 

collects/datalog/scribblings/racket.scrbl

@@ -538,6 +538,9 @@ This library provides facilities for evaluating Datalog. It can be required via:
  The @tech{theory} used by @racket[eval-program] and @racket[eval-stmt].
 }
 
+@defproc[(print-literals [ls (listof literal?)]) void]{
+ Pretty formats the literals for display. }
+
 @defproc[(eval-program [p program/c])
          void]{
  Evaluates @racket[p] using @racket[(current-theory)] as the @tech{theory}, printing query answers as it goes.

collects/racklog/lang/compiler.rkt

@@ -0,0 +1,120 @@
+#lang racket/base
+(require racket/contract
+         racket/match
+         racket/set
+         datalog/ast
+         datalog/eval
+         racklog
+         (only-in racklog/lang/lang
+                  racklog-answers->literals))
+(require (for-template racklog
+                       datalog/eval
+                       (only-in racklog/lang/lang
+                                racklog-answers->literals)))
+
+(provide/contract
+ [compile-program (program/c . -> . syntax?)]
+ [compile-statement (statement/c . -> . syntax?)])
+
+(define (compile-program p)
+  (with-syntax ([(pred ...)
+                 (map pred->stx
+                      (set->list
+                       (for/seteq ([s (in-list p)]
+                                   #:when (assertion? s))
+                                  (clause-predicate (assertion-clause s)))))])
+    (quasisyntax
+     (#%module-begin 
+      (require racklog
+               datalog/eval) 
+      (define pred %empty-rel)
+      ...
+      #,@(map compile-statement p)))))
+
+(define pred-cache (make-hasheq))
+(define (pred->stx p)
+  (hash-ref! pred-cache p
+             (λ ()
+               (datum->syntax #f p))))
+
+(define compile-statement
+  (match-lambda
+    [(assertion srcloc c)
+     (define srcstx (datum->syntax #f 'x srcloc))
+     (quasisyntax/loc srcstx
+       (%assert! #,(pred->stx (clause-predicate c))
+                 #,(set->list (clause-variables c))
+                 [#,(compile-clause-head c)
+                  #,@(compile-clause-body c)]))]
+    [(retraction srcloc c)
+     (define srcstx (datum->syntax #f 'x srcloc))
+     ; XXX implement
+     (raise-syntax-error 'racklog "Retraction is not yet supported in racklog" srcstx)]
+    [(query srcloc l)
+     (define srcstx (datum->syntax #f 'x srcloc))
+     (quasisyntax/loc srcstx
+       (print-literals
+        (racklog-answers->literals
+         #,l
+         (%find-all #,(set->list (literal-variables l))
+                    #,(compile-literal l)))))]))
+
+(define (clause-predicate c)
+  (literal-predicate (clause-head c)))
+
+(define (set->list s)
+  (for/list ([e (in-set s)]) e))
+
+(define literal-variables
+  (match-lambda
+    [(literal _ _ ts)
+     (for/seteq ([t (in-list ts)]
+                 #:when (variable? t))
+                (variable-sym t))]))
+
+(define clause-variables
+  (match-lambda
+    [(clause _ h bs)
+     (for/fold ([s (seteq)])
+       ([l (in-list (list* h bs))])
+       (set-union s (literal-variables l)))]))
+
+(define compile-clause-head
+  (match-lambda
+    [(clause srcloc head _)
+     (define srcstx (datum->syntax #f 'x srcloc))
+     (quasisyntax/loc srcstx
+       #,(compile-literal-terms head))]))
+
+(define compile-clause-body
+  (match-lambda
+    [(clause _ _ body)
+     (map compile-literal body)]))
+
+(define compile-literal
+  (match-lambda
+    [(literal srcloc '= (and ts (app length 2)))
+     (define srcstx (datum->syntax #f 'x srcloc))
+     (quasisyntax/loc srcstx
+       (%= #,@(compile-terms ts)))]
+    [(literal srcloc pred ts)
+     (define srcstx (datum->syntax #f 'x srcloc))
+     (quasisyntax/loc srcstx
+       (#,(pred->stx pred) #,@(compile-terms ts)))]))
+
+(define (compile-literal-terms l)
+  (compile-terms (literal-terms l)))
+
+(define (compile-terms ts)
+  (map compile-term ts))
+
+(define compile-term
+  (match-lambda
+    [(variable srcloc sym)
+     (datum->syntax #f sym srcloc)]
+    [(constant srcloc (? string? str))
+     (datum->syntax #f str srcloc)]
+    [(constant srcloc (? symbol? sym))
+     (define srcstx (datum->syntax #f 'x srcloc))
+     (quasisyntax/loc srcstx
+       '#,sym)]))

collects/racklog/lang/lang.rkt

@@ -0,0 +1,25 @@
+#lang racket/base
+(require racket/dict
+         racket/match
+         racket/function
+         datalog/ast)
+
+(define (racklog-answers->literals t as)
+  (for/list ([a (in-list as)]
+             #:when a)
+    (literal-subst a t)))
+
+(define (literal-subst a t)
+  (struct-copy literal t
+               [terms (map (curry term-subst a)
+                           (literal-terms t))]))
+
+(define (term-subst a t)
+  (match t
+    [(? constant?) t]
+    [(variable srcloc sym)
+     (constant srcloc (dict-ref a sym))]))
+
+(provide #%module-begin
+         #%top-interaction
+         racklog-answers->literals)

collects/racklog/lang/reader.rkt

@@ -0,0 +1,35 @@
+(module reader syntax/module-reader
+  ; XXX Copied shamelessly from datalog/lang/reader (some things should be better designed to share
+  #:language 'racklog/lang/lang
+  #:read (lambda ([in (current-input-port)]) (this-read-syntax #f in))
+  #:read-syntax this-read-syntax
+  #:whole-body-readers? #t  
+  #:info (lambda (key defval default)
+           ; XXX Should have different comment character key
+           (case key
+             [(drracket:submit-predicate)
+              (dynamic-require 'datalog/tool/submit 'repl-submit?)]
+             [(color-lexer)
+              (dynamic-require 'datalog/tool/syntax-color 'get-syntax-token)]
+             [(configure-runtime)
+              (λ () (current-read-interaction even-read))]
+             [else (default key defval)]))
+  (require datalog/parse
+           racklog/lang/compiler)
+  
+  (define (this-read-syntax [src #f] [in (current-input-port)])
+    (list
+     (compile-program
+      (parameterize ([current-source-name src])
+        (parse-program in)))))
+  
+  ; XXX This is almost certainly wrong.
+  (define (even-read src ip)
+    (begin0
+      (compile-statement
+       (parameterize ([current-source-name src])
+         (parse-statement ip)))
+      (current-read-interaction odd-read)))
+  (define (odd-read src ip)
+    (current-read-interaction even-read)
+    eof))

collects/racklog/racklog.rkt

@@ -252,6 +252,18 @@
         ((unbox *more-fk*) 'more)
         #f)))
 
+(define-syntax %find-all
+  (syntax-rules ()
+    [(_ (v ...) g)
+     (list* (%which (v ...) g)
+            (%more-list))]))
+
+(define (%more-list)
+  (define a (%more))
+  (if a
+      (list* a (%more-list))
+      empty))
+
 (define racklog-prompt-tag (make-continuation-prompt-tag 'racklog))
 (define (abort-to-racklog-prompt a)
   (abort-current-continuation racklog-prompt-tag (λ () a)))
@@ -293,7 +305,7 @@
 
 ; XXX Add contracts in theses macro expansions
 (provide %and %assert! %assert-after! %cut-delimiter %free-vars %is %let
-         %or %rel %which !)
+         %or %rel %which %find-all !)
 (provide/contract
  [goal/c contract?]
  [logic-var? (any/c . -> . boolean?)]

collects/racklog/racklog.scrbl

@@ -1115,6 +1115,14 @@ Racklog also provides two variants of these set predicates,
 viz., @racket[%bag-of-1] and @racket[%set-of-1].  These act like @racket[%bag-of]
 and @racket[%set-of] but fail if the resulting bag or set is empty.
 
+@section{Racklog Module Language}
+
+@defmodulelang[@racketmodname[racklog] #:module-paths (racklog/lang/lang)]
+
+This module language accepts the syntax of Datalog (except clauses need not be safe) and compiles each predicate to a relation.
+
+The accepted syntax is available in the @secref[#:doc '(lib "datalog/scribblings/datalog.scrbl")]{datalog} documentation.
+
 @section[#:tag "glossary"]{Glossary of Racklog Primitives}
 
 @(define-syntax (defpred stx)
@@ -1164,6 +1172,12 @@ variables in the most recent @racket[%which]-form that satisfy the
 goals in that @racket[%which]-form.  If no more solutions can
 be found, @racket[%more] returns @racket[#f].}
 
+@defform[(%find-all (V ...) G ...)
+         #:contracts ([V identifier?]
+                      [G goal/c])]{
+Like @racket[(list (%which (V ...) G ...) (%more) ...)] with as many @racket[(%more)]s as there are answers. (This will not terminate if there are an infinite number of answers.)
+}
+
 @subsection{Relations}
 
 @defform/subs[(%rel (V ...) clause ...)

collects/tests/racklog/lang.rkt

@@ -0,0 +1,20 @@
+#lang racket
+(require racket/runtime-path tests/eli-tester)
+(define-runtime-path lang "lang")
+
+(test
+ (for ([p (in-list (directory-list lang))]
+       #:when (regexp-match #rx"rkt$" (path->bytes p)))
+   (define test-rkt (build-path lang p))
+   (define test-txt (build-path lang (path-replace-suffix p #".txt")))
+   (test #:failure-prefix (path->string p)
+         (filter (lambda (l)
+                   (not (string=? l "")))
+                 (with-input-from-string
+                     (with-output-to-string
+                         (lambda () (dynamic-require test-rkt #f)))
+                   port->lines))
+         =>
+         (filter (lambda (l)
+                   (not (string=? l "")))
+                 (file->lines test-txt)))))

collects/tests/racklog/lang/ancestor.rkt

@@ -0,0 +1,12 @@
+#lang racklog
+% Equality test
+ancestor(A, B) :-
+    parent(A, B).
+ancestor(A, B) :-
+    parent(A, C),
+    D = C,      % Unification required
+    ancestor(D, B).
+parent(john, douglas).
+parent(bob, john).
+parent(ebbon, bob).
+ancestor(A, B)?

collects/tests/racklog/lang/ancestor.txt

@@ -0,0 +1,6 @@
+ancestor(john, douglas).
+ancestor(bob, john).
+ancestor(ebbon, bob).
+ancestor(bob, douglas).
+ancestor(ebbon, john).
+ancestor(ebbon, douglas).

collects/tests/racklog/lang/laps.rkt

@@ -0,0 +1,12 @@
+#lang racklog
+% Laps Test
+contains(ca, store, rams_couch, rams).
+contains(rams, fetch, rams_couch, will).
+contains(ca, fetch, Name, Watcher) :-
+    contains(ca, store, Name, Owner),
+    contains(Owner, fetch, Name, Watcher).
+trusted(ca).
+permit(User, Priv, Name) :-
+    contains(Auth, Priv, Name, User),
+    trusted(Auth).
+permit(User, Priv, Name)?

collects/tests/racklog/lang/laps.txt

@@ -0,0 +1,2 @@
+permit(rams, store, rams_couch).
+permit(will, fetch, rams_couch).

collects/tests/racklog/lang/long.rkt

@@ -0,0 +1,8 @@
+#lang racklog
+abcdefghi(z123456789,
+z1234567890123456789,
+z123456789012345678901234567890123456789,
+z1234567890123456789012345678901234567890123456789012345678901234567890123456789).
+
+this_is_a_long_identifier_and_tests_the_scanners_concat_when_read_with_a_small_buffer.
+this_is_a_long_identifier_and_tests_the_scanners_concat_when_read_with_a_small_buffer?

collects/tests/racklog/lang/long.txt

@@ -0,0 +1 @@
+this_is_a_long_identifier_and_tests_the_scanners_concat_when_read_with_a_small_buffer.

collects/tests/racklog/lang/says.rkt

@@ -0,0 +1,5 @@
+#lang racklog
+tpme(tpme1).
+ms(m1,'TPME',tpme1,ek,tp).
+says(TPME,M) :- tpme(TPME),ms(M,'TPME',TPME,A,B).
+says(A,B)?

collects/tests/racklog/lang/says.txt

@@ -0,0 +1 @@
+says(tpme1, m1).

collects/tests/racklog/lang/true.rkt

@@ -0,0 +1,3 @@
+#lang racklog
+true.
+true?

collects/tests/racklog/lang/true.txt

@@ -0,0 +1 @@
+true.

collects/tests/racklog/lang/tutorial.rkt

@@ -0,0 +1,42 @@
+#lang racklog
+
+parent(john,douglas).
+parent(john,douglas)?
+% parent(john, douglas).
+
+parent(john,ebbon)?
+
+parent(bob,john).
+parent(ebbon,bob).
+parent(A,B)?
+% parent(john, douglas).
+% parent(bob, john).
+% parent(ebbon, bob).
+
+parent(john,B)?
+% parent(john, douglas).
+
+parent(A,A)?
+
+ancestor(A,B) :- parent(A,B).
+ancestor(A,B) :- parent(A,C), ancestor(C, B).
+ancestor(A, B)?
+% ancestor(ebbon, bob).
+% ancestor(bob, john).
+% ancestor(john, douglas).
+% ancestor(bob, douglas).
+% ancestor(ebbon, john).
+% ancestor(ebbon, douglas).
+
+ancestor(X,john)?
+% ancestor(bob, john).
+% ancestor(ebbon, john).
+
+% XXX parent(bob, john)~
+% XXX parent(A,B)?
+% parent(john, douglas).
+% parent(ebbon, bob).
+
+% XXX ancestor(A,B)?
+% ancestor(john, douglas).
+% ancestor(ebbon, bob).

collects/tests/racklog/lang/tutorial.txt

@@ -0,0 +1,21 @@
+parent(john, douglas).
+
+
+parent(john, douglas).
+parent(bob, john).
+parent(ebbon, bob).
+
+parent(john, douglas).
+
+
+ancestor(john, douglas).
+ancestor(bob, john).
+ancestor(ebbon, bob).
+ancestor(bob, douglas).
+ancestor(ebbon, john).
+ancestor(ebbon, douglas).
+
+ancestor(bob, john).
+ancestor(ebbon, john).
+
+

collects/tests/racklog/run-all.rkt

@@ -6,6 +6,6 @@
  (for ([p (in-list (directory-list here))])
    (define s (path->string p))
    (when (regexp-match #rx"rkt$" s)
-     (unless (or (string=? "compiled" s)
+     (unless (or (directory-exists? s)
                  (string=? "run-all.rkt" s))
        (dynamic-require (build-path here p) #f)))))