From cdda2224dae9a84e44fc70fb5a6a79a7ce6753b5 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 13 May 2016 22:54:54 -0700 Subject: [PATCH] scopes --- .../br/syntax-scopes-test.rkt | 43 +++++++ beautiful-racket-lib/br/syntax.rkt | 106 +++++++++++------- 2 files changed, 108 insertions(+), 41 deletions(-) create mode 100644 beautiful-racket-lib/br/syntax-scopes-test.rkt diff --git a/beautiful-racket-lib/br/syntax-scopes-test.rkt b/beautiful-racket-lib/br/syntax-scopes-test.rkt new file mode 100644 index 0000000..aa26775 --- /dev/null +++ b/beautiful-racket-lib/br/syntax-scopes-test.rkt @@ -0,0 +1,43 @@ +#lang br +(require (for-syntax br/syntax sugar/debug) br/syntax) + +(begin-for-syntax + (define-scope blue) + (define-scope yellow) + (define-scope red) + (define-scope green (blue yellow)) + (define-scope purple (blue red))) + +(define #'(define-blue _id _val) + (with-blue-binding-form ([x '_id]) + #'(define x _val))) + +#;(define-blue x (+ 42 42)) + +(define #'(def-x) + (with-blue-binding-form ([x 'x]) + #'(define x (+ 42 42)))) + +(define #'(def-x-2) + (with-yellow-binding-form ([x 'x]) + #'(define x (+ 42)))) + +(define #'(print-x) + (with-yellow-syntax ([x 'x]) + #'(println (+ x x)))) + +(define #'(print-x-2) + (with-purple-syntax ([x 'x]) + #'(println (+ x x x)))) + + +(scopes (syntax-find (expand-once #'(def-x)) 'x)) +(def-x) +(def-x-2) +(scopes (syntax-find (expand-once #'(print-x)) 'x)) +(print-x) +(scopes (syntax-find (expand-once #'(print-x-2)) 'x)) +(print-x-2) + +#;(let-syntax ([x (λ(stx) (syntax-case stx () [_ #'42]))]) + (* x 4)) diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index d2b2d46..2193f0f 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ b/beautiful-racket-lib/br/syntax.rkt @@ -58,6 +58,20 @@ (for/list ([scope (in-list (context stx))]) scope)))) +(define (syntax-find stx stx-or-datum) + (unless (syntax? stx) + (raise-argument-error 'syntax-find "not given syntax object as first argument" stx)) + (define datum + (cond [(syntax? stx-or-datum) (syntax->datum stx-or-datum)] + [(symbol? stx-or-datum) stx-or-datum] + [else (raise-argument-error 'syntax-find "not given syntax or datum as second argument" stx-or-datum)])) + (let/ec exit + (let loop ([so stx]) + (cond + [(eq? (syntax->datum so) datum) (exit so)] + [(syntax->list so) => (curry map loop)])))) + + (define (->syntax x) (if (syntax? x) x (datum->syntax #f x))) @@ -70,6 +84,10 @@ (with-syntax ([id-sis (format-id #'id "~a-sis" #'id)] [add-id (format-id #'id "add-~a" #'id)] [flip-id (format-id #'id "flip-~a" #'id)] + [id-binding-form (format-id #'id "~a-binding-form" #'id)] + [with-id-syntax (format-id #'id "with-~a-syntax" #'id)] + [let-id-syntax (format-id #'id "let-~a-syntax" #'id)] + [with-id-binding-form (format-id #'id "with-~a-binding-form" #'id)] [remove-id (format-id #'id "remove-~a" #'id)] [id? (format-id #'id "~a?" #'id)] [id* (format-id #'id "~a*" #'id)] @@ -80,7 +98,7 @@ (if (pair? sis-in) (apply append sis-in) (list - (let ([si (make-syntax-introducer)]) + (let ([si (make-syntax-introducer #t)]) (list (procedure-rename (curryr si 'add) 'add-id) (procedure-rename (curryr si 'flip) 'flip-id) (procedure-rename (curryr si 'remove) 'remove-id))))))) @@ -88,13 +106,19 @@ (define flip-id (λ(x) ((apply compose1 (map cadr id-sis)) (->syntax x)))) (define remove-id (λ(x) ((apply compose1 (map caddr id-sis)) (->syntax x)))) (define (id x) (add-id (datum->syntax #f (syntax-e (->syntax x))))) + (define (id-binding-form x) (syntax-local-introduce (id x))) (define (id* x) (replace-context (add-id (datum->syntax #f '_)) (->syntax x))) (define (id? x) (and (member (car (context (add-id (datum->syntax #f '_)))) (context (->syntax x))) - #t))))])) - + #t)) + (define-syntax-rule (with-id-syntax ([pat val] (... ...)) . body) + (with-syntax ([pat (id* val)] (... ...)) . body)) + (define-syntax-rule (with-id-binding-form ([pat val] (... ...)) . body) + (with-syntax ([pat (id-binding-form val)] (... ...)) . body)) + (define-syntax-rule (let-id-syntax ([pat val] (... ...)) . body) + (let-syntax ([pat (id* val)] (... ...)) . body))))])) (define (scopes-equal? stxl stxr) ;; "A bound-identifier=? comparison checks that two identifiers have exactly the same scope sets" @@ -102,44 +126,44 @@ (module+ test -(require rackunit) -(define-scope red) - -(define stx (datum->syntax #f 'x)) - -(define red-stx (add-red stx)) -(define double-red-stx (add-red (add-red stx))) - - -(check-false (red? stx)) -(check-true (red? red-stx)) -(check-true (red? double-red-stx)) -(check-false (scopes-equal? stx red-stx)) -(check-true (scopes-equal? red-stx double-red-stx)) -(check-false (scopes-equal? red-stx (remove-red double-red-stx))) - - -(define-scope blue) ; scope addition is commutative -(define blue-stx (blue stx)) -(check-true (scopes-equal? (add-blue red-stx) (add-red blue-stx))) -(check-true (scopes-equal? (remove-red (add-blue red-stx)) (remove-red (add-red blue-stx)))) - - -(define-scope green) ; replace scopes at outer layer -(check-true (scopes-equal? (green red-stx) (green blue-stx))) - - -;; replace scopes everywhere -(check-true (scopes-equal? (car (syntax->list (green* #`(#,blue-stx #,red-stx)))) - (car (syntax->list (green* #`(#,red-stx #,blue-stx)))))) - -;; todo: test flipping - - -(define-scope purple (red blue)) - -(check-true (purple? (add-purple stx))) -(check-true (scopes-equal? (purple (green stx)) (add-blue (remove-green (add-red (add-green (add-blue stx)))))))) + (require rackunit) + (define-scope red) + + (define stx (datum->syntax #f 'x)) + + (define red-stx (add-red stx)) + (define double-red-stx (add-red (add-red stx))) + + + (check-false (red? stx)) + (check-true (red? red-stx)) + (check-true (red? double-red-stx)) + (check-false (scopes-equal? stx red-stx)) + (check-true (scopes-equal? red-stx double-red-stx)) + (check-false (scopes-equal? red-stx (remove-red double-red-stx))) + + + (define-scope blue) ; scope addition is commutative + (define blue-stx (blue stx)) + (check-true (scopes-equal? (add-blue red-stx) (add-red blue-stx))) + (check-true (scopes-equal? (remove-red (add-blue red-stx)) (remove-red (add-red blue-stx)))) + + + (define-scope green) ; replace scopes at outer layer + (check-true (scopes-equal? (green red-stx) (green blue-stx))) + + + ;; replace scopes everywhere + (check-true (scopes-equal? (car (syntax->list (green* #`(#,blue-stx #,red-stx)))) + (car (syntax->list (green* #`(#,red-stx #,blue-stx)))))) + + ;; todo: test flipping + + + (define-scope purple (red blue)) + + (check-true (purple? (add-purple stx))) + (check-true (scopes-equal? (purple (green stx)) (add-blue (remove-green (add-red (add-green (add-blue stx)))))))) (define-syntax (with-scopes stx)