From 744fde1fa85aa52cd9a969d9deffa726ca94af37 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 16 Apr 2014 12:58:59 -0600 Subject: [PATCH] Demonstrate Racket/Datalog interop more and add unsyntax --- pkgs/datalog/ast.rkt | 2 +- pkgs/datalog/scribblings/racket.scrbl | 36 +++++++++++++-- pkgs/datalog/stx.rkt | 65 ++++++++++++++++----------- pkgs/datalog/tests/racket.rkt | 22 +++++++++ 4 files changed, 94 insertions(+), 31 deletions(-) diff --git a/pkgs/datalog/ast.rkt b/pkgs/datalog/ast.rkt index 0eee131be4..6b632dfb85 100644 --- a/pkgs/datalog/ast.rkt +++ b/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)])] diff --git a/pkgs/datalog/scribblings/racket.scrbl b/pkgs/datalog/scribblings/racket.scrbl index 1904cd24ae..3b298fa674 100644 --- a/pkgs/datalog/scribblings/racket.scrbl +++ b/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. -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. + +Literals are represented as @racket[identifier] or @racket[(table term ...)]. + +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[ diff --git a/pkgs/datalog/stx.rkt b/pkgs/datalog/stx.rkt index c69fb630ca..24741f11c4 100644 --- a/pkgs/datalog/stx.rkt +++ b/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?) - (syntax-parse - stx - #:literals (:-) - [(_ sym:id) - (syntax-property - (quasisyntax/loc #'sym - (literal #,(srcloc-list #'sym) 'sym empty)) - (if binding? 'disappeared-binding 'disappeared-use) - (syntax-local-introduce #'sym))] - [(_ (~and tstx (sym:id arg ... :- ans ...))) - (quasisyntax/loc #'tstx - (external #,(srcloc-list #'tstx) 'sym sym - (list (datalog-term arg) ...) - (list (datalog-term ans) ...)))] - [(_ (~and tstx (sym:id e ...))) - (syntax-property - (quasisyntax/loc #'tstx - (literal #,(srcloc-list #'tstx) 'sym - (list (datalog-term e) - ...))) - (if binding? 'disappeared-binding 'disappeared-use) - (syntax-local-introduce #'sym))])) +(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:table-id) + (syntax-property + (quasisyntax/loc #'sym + (literal #,(srcloc-list #'sym) sym.ref empty)) + (if binding? 'disappeared-binding 'disappeared-use) + (syntax-local-introduce #'sym))] + [(_ (~and tstx (sym:table-id arg ... :- ans ...))) + (quasisyntax/loc #'tstx + (external #,(srcloc-list #'tstx) 'sym sym.val + (list (datalog-term arg) ...) + (list (datalog-term ans) ...)))] + [(_ (~and tstx (sym:table-id e ...))) + (syntax-property + (quasisyntax/loc #'tstx + (literal #,(srcloc-list #'tstx) sym.ref + (list (datalog-term e) + ...))) + (if binding? 'disappeared-binding 'disappeared-use) + (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))])) diff --git a/pkgs/datalog/tests/racket.rkt b/pkgs/datalog/tests/racket.rkt index 69c0c73a0e..9f578d5dea 100644 --- a/pkgs/datalog/tests/racket.rkt +++ b/pkgs/datalog/tests/racket.rkt @@ -15,6 +15,23 @@ (? (parent X joseph2))) => (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))) @@ -58,6 +75,11 @@ (? (add1 1 :- X))) => (list (hasheq 'X 2)) + + (datalog parent + (? (#,(λ (x) (+ x 1)) 1 :- X))) + => + (list (hasheq 'X 2)) (let () (define new-parent