suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Demonstrate Racket/Datalog interop more and add unsyntax

Browse Source
This commit is contained in:
Jay McCarthy 2014-04-16 12:58:59 -06:00
parent d6a3d27e54
commit 744fde1fa8
4 changed files with 94 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/datalog/ast.rkt
View File

@ -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)])]

36
pkgs/datalog/scribblings/racket.scrbl
View File

@ -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[

65
pkgs/datalog/stx.rkt
View File

@ -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))]))

22
pkgs/datalog/tests/racket.rkt
View File

@ -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