diff --git a/collects/datalog/ast.rkt b/collects/datalog/ast.rkt index 84cafa9694..0eee131be4 100644 --- a/collects/datalog/ast.rkt +++ b/collects/datalog/ast.rkt @@ -3,8 +3,7 @@ racket/match) (define srcloc/c - (or/c syntax? - false/c + (or/c #f (list/c any/c (or/c exact-positive-integer? #f) (or/c exact-nonnegative-integer? #f) diff --git a/collects/datalog/serialize.rkt b/collects/datalog/serialize.rkt index 57635e978d..353e7872b3 100644 --- a/collects/datalog/serialize.rkt +++ b/collects/datalog/serialize.rkt @@ -2,26 +2,27 @@ (require racket/contract racket/match racket/list - "runtime.rkt") + "runtime.rkt" + "ast.rkt") -(define remove-stx-objs +(define remove-paths (match-lambda [(? hash? ht) (for/hash ([(k v) (in-hash ht)]) - (values k (remove-stx-objs v)))] + (values k (remove-paths v)))] [(? cons? c) - (cons (remove-stx-objs (car c)) - (remove-stx-objs (cdr c)))] + (cons (remove-paths (car c)) + (remove-paths (cdr c)))] [(? prefab-struct-key s) (apply make-prefab-struct (prefab-struct-key s) - (remove-stx-objs (rest (vector->list (struct->vector s)))))] - [(? syntax? s) + (remove-paths (rest (vector->list (struct->vector s)))))] + [(? path? s) #f] [x x])) (define (write-theory t) - (write (remove-stx-objs t))) + (write (remove-paths t))) (define (hash->hash! ht) (define ht! (make-hash)) diff --git a/collects/datalog/stx.rkt b/collects/datalog/stx.rkt index 21095f02f4..c69fb630ca 100644 --- a/collects/datalog/stx.rkt +++ b/collects/datalog/stx.rkt @@ -65,13 +65,13 @@ #:literals (! ~ ?) [(_ (~and tstx (! c))) (quasisyntax/loc #'tstx - (assertion #'#,(unoriginal #'tstx) (datalog-clause c)))] + (assertion #,(srcloc-list #'tstx) (datalog-clause c)))] [(_ (~and tstx (~ c))) (quasisyntax/loc #'tstx - (retraction #'#,(unoriginal #'tstx) (datalog-clause c)))] + (retraction #,(srcloc-list #'tstx) (datalog-clause c)))] [(_ (~and tstx (? l))) (quasisyntax/loc #'tstx - (query #'#,(unoriginal #'tstx) (datalog-literal/ref l)))])) + (query #,(srcloc-list #'tstx) (datalog-literal/ref l)))])) (define-syntax (datalog-stmt-var-selector stx) (syntax-parse @@ -130,11 +130,11 @@ (syntax-local-lift-expression fake-lam)) (quasisyntax/loc #'tstx - (clause #'#,(unoriginal #'tstx) (datalog-literal/bind head) + (clause #,(srcloc-list #'tstx) (datalog-literal/bind head) (list (datalog-literal/ref body) ...)))] [(_ e) (quasisyntax/loc #'e - (clause #'#,(unoriginal #'e) (datalog-literal/bind e) empty))])) + (clause #,(srcloc-list #'e) (datalog-literal/bind e) empty))])) (define-syntax (datalog-literal/bind stx) (datalog-literal/b stx #t)) (define-syntax (datalog-literal/ref stx) (datalog-literal/b stx #f)) @@ -146,18 +146,18 @@ [(_ sym:id) (syntax-property (quasisyntax/loc #'sym - (literal #'#,(unoriginal #'sym) 'sym empty)) + (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 #'#,(unoriginal #'tstx) 'sym sym + (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 #'#,(unoriginal #'tstx) 'sym + (literal #,(srcloc-list #'tstx) 'sym (list (datalog-term e) ...))) (if binding? 'disappeared-binding 'disappeared-use) @@ -198,26 +198,26 @@ (cond [(identifier-binding #'sym 0) (quasisyntax/loc #'sym - (constant #'#,(unoriginal #'sym) sym))] + (constant #,(srcloc-list #'sym) sym))] [(char-upper-case? (string-ref (symbol->string (syntax->datum #'sym)) 0)) (quasisyntax/loc #'sym - (variable #'#,(unoriginal #'sym) 'sym))] + (variable #,(srcloc-list #'sym) 'sym))] [else (quasisyntax/loc #'sym - (constant #'#,(unoriginal #'sym) 'sym))])] + (constant #,(srcloc-list #'sym) 'sym))])] [(_ sym:expr) (quasisyntax/loc #'sym - (constant #'#,(unoriginal #'sym) sym))])) + (constant #,(srcloc-list #'sym) sym))])) -(define-for-syntax (unoriginal stx) - (let loop ([stx stx]) - (cond - [(syntax? stx) - (datum->syntax stx (loop (syntax-e stx)) stx)] - [(pair? stx) - (cons (loop (car stx)) - (loop (cdr stx)))] - [else stx]))) +(define-for-syntax (srcloc-list stx) + (define src (syntax-source stx)) + `(list ,(if (path? src) + `(bytes->path ,(path->bytes src)) + `',src) + ',(syntax-line stx) + ',(syntax-column stx) + ',(syntax-position stx) + ',(syntax-span stx))) (provide datalog datalog! :- ! ~ ?) diff --git a/collects/tests/datalog/ast.rkt b/collects/tests/datalog/ast.rkt index db56633c41..06a5b8e8b4 100644 --- a/collects/tests/datalog/ast.rkt +++ b/collects/tests/datalog/ast.rkt @@ -1,9 +1,16 @@ #lang racket (require rackunit - datalog/ast) + datalog/ast + racket/runtime-path) (provide ast-tests) +(define-runtime-path ast.rkt "ast.rkt") +(define sym1-srcloc (list ast.rkt 1 1 10 3)) +(define sym2-srcloc (list #f #f #f #f #f)) +(define lit1-srcloc (list ast.rkt #f #f 3000 3)) +(define cl1-srcloc sym2-srcloc) + (define ast-tests (test-suite "ast" @@ -20,49 +27,49 @@ (test-suite "variable-equal?" (test-not-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable #f 'sym1))) - (test-not-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable #'sym1 'sym1))) + (test-not-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable sym1-srcloc 'sym1))) (test-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable #f 'sym2))) - (test-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable #'sym2 'sym2)))) + (test-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable sym2-srcloc 'sym2)))) (test-suite "constant-equal?" (test-not-false "sym/sym" (constant-equal? (make-constant #f 'sym1) (make-constant #f 'sym1))) - (test-not-false "sym/sym" (constant-equal? (make-constant #f 'sym1) (make-constant #'sym1 'sym1))) - (test-false "sym/sym" (constant-equal? (make-constant #f 'sym1) (make-constant #'sym1 'sym2))) + (test-not-false "sym/sym" (constant-equal? (make-constant #f 'sym1) (make-constant sym1-srcloc 'sym1))) + (test-false "sym/sym" (constant-equal? (make-constant #f 'sym1) (make-constant sym1-srcloc 'sym2))) (test-not-false "str/str" (constant-equal? (make-constant #f "sym1") (make-constant #f "sym1"))) - (test-not-false "str/str" (constant-equal? (make-constant #f "sym1") (make-constant #'sym1 "sym1"))) - (test-false "str/str" (constant-equal? (make-constant #f "sym1") (make-constant #'sym1 "sym2"))) - (test-false "sym/str" (constant-equal? (make-constant #f 'sym1) (make-constant #'sym1 "sym2"))) - (test-false "str/sym" (constant-equal? (make-constant #'sym1 "sym2") (make-constant #f 'sym1)))) + (test-not-false "str/str" (constant-equal? (make-constant #f "sym1") (make-constant sym1-srcloc "sym1"))) + (test-false "str/str" (constant-equal? (make-constant #f "sym1") (make-constant sym1-srcloc "sym2"))) + (test-false "sym/str" (constant-equal? (make-constant #f 'sym1) (make-constant sym1-srcloc "sym2"))) + (test-false "str/sym" (constant-equal? (make-constant sym1-srcloc "sym2") (make-constant #f 'sym1)))) (test-suite "term-equal?" (test-not-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable #f 'sym1))) - (test-not-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable #'sym1 'sym1))) + (test-not-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable sym1-srcloc 'sym1))) (test-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable #f 'sym2))) - (test-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable #'sym2 'sym2))) + (test-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable sym2-srcloc 'sym2))) (test-not-false "sym/sym" (term-equal? (make-constant #f 'sym1) (make-constant #f 'sym1))) - (test-not-false "sym/sym" (term-equal? (make-constant #f 'sym1) (make-constant #'sym1 'sym1))) - (test-false "sym/sym" (term-equal? (make-constant #f 'sym1) (make-constant #'sym1 'sym2))) + (test-not-false "sym/sym" (term-equal? (make-constant #f 'sym1) (make-constant sym1-srcloc 'sym1))) + (test-false "sym/sym" (term-equal? (make-constant #f 'sym1) (make-constant sym1-srcloc 'sym2))) (test-not-false "str/str" (term-equal? (make-constant #f "sym1") (make-constant #f "sym1"))) - (test-not-false "str/str" (term-equal? (make-constant #f "sym1") (make-constant #'sym1 "sym1"))) - (test-false "str/str" (term-equal? (make-constant #f "sym1") (make-constant #'sym1 "sym2"))) - (test-false "sym/str" (term-equal? (make-constant #f 'sym1) (make-constant #'sym1 "sym2"))) - (test-false "str/sym" (term-equal? (make-constant #'sym1 "sym2") (make-constant #f 'sym1))) - (test-false "con/var" (term-equal? (make-constant #'sym1 "sym2") (make-variable #f 'sym1))) - (test-false "var/con" (term-equal? (make-variable #f 'sym1) (make-constant #'sym1 "sym2")))) + (test-not-false "str/str" (term-equal? (make-constant #f "sym1") (make-constant sym1-srcloc "sym1"))) + (test-false "str/str" (term-equal? (make-constant #f "sym1") (make-constant sym1-srcloc "sym2"))) + (test-false "sym/str" (term-equal? (make-constant #f 'sym1) (make-constant sym1-srcloc "sym2"))) + (test-false "str/sym" (term-equal? (make-constant sym1-srcloc "sym2") (make-constant #f 'sym1))) + (test-false "con/var" (term-equal? (make-constant sym1-srcloc "sym2") (make-variable #f 'sym1))) + (test-false "var/con" (term-equal? (make-variable #f 'sym1) (make-constant sym1-srcloc "sym2")))) (test-suite "literal-equal?" - (test-not-false "lit" (literal-equal? (make-literal #f 'lit1 empty) (make-literal #'lit1 'lit1 empty))) + (test-not-false "lit" (literal-equal? (make-literal #f 'lit1 empty) (make-literal lit1-srcloc 'lit1 empty))) (test-not-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1))) - (make-literal #'lit1 'lit1 (list (make-variable #f 'sym1))))) + (make-literal lit1-srcloc 'lit1 (list (make-variable #f 'sym1))))) (test-not-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1))) - (make-literal #'lit1 'lit1 (list (make-variable #'sym1 'sym1))))) - (test-false "lit" (literal-equal? (make-literal #f 'lit1 empty) (make-literal #'lit1 'lit2 empty))) - (test-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1))) (make-literal #'lit1 'lit2 empty))) + (make-literal lit1-srcloc 'lit1 (list (make-variable sym1-srcloc 'sym1))))) + (test-false "lit" (literal-equal? (make-literal #f 'lit1 empty) (make-literal lit1-srcloc 'lit2 empty))) + (test-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1))) (make-literal lit1-srcloc 'lit2 empty))) (test-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1))) - (make-literal #'lit1 'lit2 (list (make-variable #'sym1 'sym2)))))) + (make-literal lit1-srcloc 'lit2 (list (make-variable sym1-srcloc 'sym2)))))) (test-suite "clause-equal?" @@ -71,7 +78,7 @@ (test-not-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) (list (make-literal #f 'lit1 empty))) (make-clause #f (make-literal #f 'lit1 empty) (list (make-literal #f 'lit1 empty))))) (test-not-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) empty) - (make-clause #'cl1 (make-literal #f 'lit1 empty) empty))) + (make-clause cl1-srcloc (make-literal #f 'lit1 empty) empty))) (test-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) empty) (make-clause #f (make-literal #f 'lit2 empty) empty))) (test-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) (list (make-literal #f 'lit1 empty)))