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

fix for new syntax expander, thanks mflatt!

Browse Source
This commit is contained in:
Jay McCarthy 2015-07-28 15:24:36 -06:00
parent 5fc15cde51
commit a0d3481b73
2 changed files with 27 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
lang/reader.rkt
View File

@ -3,6 +3,7 @@
#:read (lambda ([in (current-input-port)]) (this-read-syntax #f in)) #:read (lambda ([in (current-input-port)]) (this-read-syntax #f in))
#:read-syntax this-read-syntax #:read-syntax this-read-syntax
#:whole-body-readers? #t #:whole-body-readers? #t
#:module-wrapper call-with-intro
#:language-info #:language-info
'#(datalog/lang/lang-info get-info #f) '#(datalog/lang/lang-info get-info #f)
#:info (lambda (key defval default) #:info (lambda (key defval default)
@ -18,7 +19,13 @@
(require datalog/parse (require datalog/parse
datalog/private/compiler) datalog/private/compiler)
(define (call-with-intro thunk)
(define intro (make-syntax-introducer #t))
(parameterize ([current-datalog-introducer intro])
(intro (thunk))))
(define (this-read-syntax [src #f] [in (current-input-port)]) (define (this-read-syntax [src #f] [in (current-input-port)])
(compile-program (quasisyntax/loc src
#,(compile-program
(parameterize ([current-source-name src]) (parameterize ([current-source-name src])
(parse-program in))))) (parse-program in))))))

22
private/compiler.rkt
View File

@ -5,27 +5,35 @@
datalog/stx) datalog/stx)
(require (for-template datalog/stx)) (require (for-template datalog/stx))
(provide/contract (provide
current-datalog-introducer
(contract-out
[compile-program (program/c . -> . (listof syntax?))] [compile-program (program/c . -> . (listof syntax?))]
[compile-statement (statement/c . -> . syntax?)]) [compile-statement (statement/c . -> . syntax?)]))
(define (compile-program p) (define (compile-program p)
(map compile-statement p)) (map compile-statement p))
(define current-datalog-introducer
(make-parameter (λ (x) x)))
(define (intro x)
((current-datalog-introducer) x))
(define compile-statement (define compile-statement
(match-lambda (match-lambda
[(assertion srcloc c) [(assertion srcloc c)
(define srcstx (datum->syntax #f 'x srcloc)) (define srcstx (datum->syntax #f 'x srcloc))
(quasisyntax/loc srcstx (quasisyntax/loc srcstx
(! #,(compile-clause c)))] (#,(intro #'!) #,(compile-clause c)))]
[(retraction srcloc c) [(retraction srcloc c)
(define srcstx (datum->syntax #f 'x srcloc)) (define srcstx (datum->syntax #f 'x srcloc))
(quasisyntax/loc srcstx (quasisyntax/loc srcstx
(~ #,(compile-clause c)))] (#,(intro #'~) #,(compile-clause c)))]
[(query srcloc l) [(query srcloc l)
(define srcstx (datum->syntax #f 'x srcloc)) (define srcstx (datum->syntax #f 'x srcloc))
(quasisyntax/loc srcstx (quasisyntax/loc srcstx
(? #,(compile-literal l)))])) (#,(intro #'?) #,(compile-literal l)))]))
(define compile-clause (define compile-clause
(match-lambda (match-lambda
@ -35,14 +43,14 @@
[(clause srcloc head body) [(clause srcloc head body)
(define srcstx (datum->syntax #f 'x srcloc)) (define srcstx (datum->syntax #f 'x srcloc))
(quasisyntax/loc srcstx (quasisyntax/loc srcstx
(:- #,@(map compile-literal (list* head body))))])) (#,(intro #':-) #,@(map compile-literal (list* head body))))]))
(define compile-literal (define compile-literal
(match-lambda (match-lambda
[(literal srcloc '= (and ts (app length 2))) [(literal srcloc '= (and ts (app length 2)))
(define srcstx (datum->syntax #f 'x srcloc)) (define srcstx (datum->syntax #f 'x srcloc))
(quasisyntax/loc srcstx (quasisyntax/loc srcstx
(= #,@(map compile-term ts)))] (#,(intro #'=) #,@(map compile-term ts)))]
[(literal srcloc pred ts) [(literal srcloc pred ts)
(define srcstx (datum->syntax #f 'x srcloc)) (define srcstx (datum->syntax #f 'x srcloc))
(define pred-stx (if (predicate-sym? pred) (define pred-stx (if (predicate-sym? pred)