Demonstrate Racket/Datalog interop more and add unsyntax

pkgs/datalog/ast.rkt

@@ -99,7 +99,7 @@
                   [terms (listof term/c)])]
  [literal-equal? (literal? literal? . -> . boolean?)]
  [struct external ([srcloc srcloc/c]
-                   [predicate-sym symbol?]
+                   [predicate-sym any/c]
                    [predicate procedure?]
                    [arg-terms (listof term/c)]
                    [ans-terms (listof term/c)])]

pkgs/datalog/scribblings/racket.scrbl

@@ -15,6 +15,7 @@
 The Datalog database can be directly used by Racket programs through this API.
 
 @examples[#:eval the-eval
+          #:escape UNSYNTAX-NOT
           (define family (make-theory))
 
           (datalog family
@@ -25,6 +26,17 @@ The Datalog database can be directly used by Racket programs through this API.
           (datalog family
                    (? (parent X joseph2)))
 
+          (datalog family
+                   (? (parent X (string->symbol "joseph2"))))
+
+          (let ([atom 'joseph2])
+            (datalog family
+                     (? (parent X #,atom))))
+
+          (let ([table 'parent])
+            (datalog family
+                     (? (#,table X joseph2))))
+
           (datalog family
                    (? (parent joseph2 X)))
 
@@ -48,7 +60,9 @@ The Datalog database can be directly used by Racket programs through this API.
                      (? (parent x X))))
 
           (datalog family
-                   (? (add1 1 :- X)))]
+                   (? (add1 1 :- X)))
+          (datalog family
+                   (? (#,(λ (x) (+ x 1)) 1 :- X)))]
 
 @defthing[theory/c contract?]{ A contract for Datalog theories. }
 
@@ -75,9 +89,23 @@ Statements are either assertions, retractions, or queries.
 @defform[(? question)]{ Queries the literal and prints the result literals. }
 
 Questions are either literals or external queries.
-Literals are represented as @racket[identifier] or @racket[(identifier term ...)].
+
-External queries are represented as @racket[(identifier term ... :- term ...)], where @racket[identifier] is bound to a procedure that when given the first set of terms as arguments returns the second set of terms as values.
+Literals are represented as @racket[identifier] or @racket[(table term ...)].
-A term is either a non-capitalized identifiers for a constant symbol, a Racket datum for a constant datum, or a capitalized identifier for a variable symbol. Bound identifiers in terms are treated as datums. 
+
+A table is either an identifier or @RACKET[#,expr] where @racket[expr]
+evaluates to a symbol.
+
+External queries are represented as @racket[(ext-table term ... :-
+term ...)], where @racket[ext-table] is an identifier bound to a
+procedure or @RACKET[#,expr] where @racket[expr] evaluates to a
+procedure that when given the first set of terms as arguments returns
+the second set of terms as values.
+
+A term is either a non-capitalized identifiers for a constant symbol,
+a Racket expression for a constant datum, or a capitalized identifier
+for a variable symbol, or @RACKET[#,expr] where @racket[expr]
+evaluates to a constant datum. Bound identifiers in terms are treated
+as the datum they are bound to.
 
 External queries invalidate Datalog's guaranteed termination. For example, this program does not terminate:
 @racketblock[

pkgs/datalog/stx.rkt

@@ -139,44 +139,53 @@
 (define-syntax (datalog-literal/bind stx) (datalog-literal/b stx #t))
 (define-syntax (datalog-literal/ref stx) (datalog-literal/b stx #f))
 
-(define-for-syntax (datalog-literal/b stx binding?)
+(begin-for-syntax
+  (define-syntax-class table-id
+    #:literals (unsyntax)
+    (pattern sym:id
+             #:attr ref #''sym
+             #:attr val #'sym)
+    (pattern (unsyntax sym:expr)
+             #:attr ref #'sym
+             #:attr val #'sym))
+  (define (datalog-literal/b stx binding?)
     (syntax-parse 
         stx
       #:literals (:-)
-   [(_ sym:id)
+      [(_ sym:table-id)
        (syntax-property 
         (quasisyntax/loc #'sym
-       (literal #,(srcloc-list #'sym) 'sym empty))
+          (literal #,(srcloc-list #'sym) sym.ref empty))
         (if binding? 'disappeared-binding 'disappeared-use)
         (syntax-local-introduce #'sym))]
-   [(_ (~and tstx (sym:id arg ... :- ans ...)))
+      [(_ (~and tstx (sym:table-id arg ... :- ans ...)))
        (quasisyntax/loc #'tstx
-      (external #,(srcloc-list #'tstx) 'sym sym
+         (external #,(srcloc-list #'tstx) 'sym sym.val
                    (list (datalog-term arg) ...)
                    (list (datalog-term ans) ...)))]
-   [(_ (~and tstx (sym:id e ...)))
+      [(_ (~and tstx (sym:table-id e ...)))
        (syntax-property
         (quasisyntax/loc #'tstx
-       (literal #,(srcloc-list #'tstx) 'sym 
+          (literal #,(srcloc-list #'tstx) sym.ref 
                    (list (datalog-term e)
                          ...)))
         (if binding? 'disappeared-binding 'disappeared-use)
-     (syntax-local-introduce #'sym))]))
+        (syntax-local-introduce #'sym))])))
 
 (define-syntax (datalog-literal-var-selector stx)
   (syntax-parse 
    stx
    #:literals (:-)
-   [(_ sym:id)
+   [(_ sym:table-id)
     (quasisyntax/loc #'sym (λ (l) (hasheq)))]
-   [(_ (~and tstx (sym:id arg ... :- ans ...)))
+   [(_ (~and tstx (sym:table-id arg ... :- ans ...)))
     (quasisyntax/loc #'tstx 
       (match-lambda
         [(external _srcloc _predsym _pred args anss)
          (terms->hasheq (list (datalog-term arg) ...
                               (datalog-term ans) ...)
                         (append args anss))]))]
-   [(_ (~and tstx (sym:id e ...)))
+   [(_ (~and tstx (sym:table-id e ...)))
     (quasisyntax/loc #'tstx
       (match-lambda
         [(literal _srcloc _predsym ts)
@@ -194,6 +203,7 @@
 (define-syntax (datalog-term stx)
   (syntax-parse 
    stx
+   #:literals (unsyntax)
    [(_ sym:id)
     (cond
       [(identifier-binding #'sym 0)
@@ -205,6 +215,9 @@
       [else
        (quasisyntax/loc #'sym
          (constant #,(srcloc-list #'sym) 'sym))])]
+   [(_ (unsyntax sym:expr))
+    (quasisyntax/loc #'sym
+      (constant #,(srcloc-list #'sym) sym))]
    [(_ sym:expr)
     (quasisyntax/loc #'sym
       (constant #,(srcloc-list #'sym) sym))]))

pkgs/datalog/tests/racket.rkt

@@ -16,6 +16,23 @@
  =>
  (list (hasheq 'X 'joseph3))
 
+ (datalog parent
+          (? (parent X (string->symbol "joseph2"))))
+ =>
+ (list (hasheq 'X 'joseph3))
+
+ (let ([atom 'joseph2])
+   (datalog parent
+            (? (parent X #,atom))))
+ =>
+ (list (hasheq 'X 'joseph3))
+
+ (let ([table 'parent])
+   (datalog parent
+            (? (#,table X joseph2))))
+ =>
+ (list (hasheq 'X 'joseph3))
+ 
  (datalog parent
           (? (parent joseph2 X)))
  =>
@@ -59,6 +76,11 @@
  =>
  (list (hasheq 'X 2))
 
+ (datalog parent
+          (? (#,(λ (x) (+ x 1)) 1 :- X)))
+ =>
+ (list (hasheq 'X 2))
+ 
  (let ()
    (define new-parent
      (with-input-from-bytes