From 084fb8ace21d057415506fc0862ab21fc6c54abf Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 22 May 2016 22:22:51 -0700 Subject: [PATCH] mysteries --- beautiful-racket-lib/br/subscope-4-test.rkt | 62 ++++++++++----------- 1 file changed, 30 insertions(+), 32 deletions(-) diff --git a/beautiful-racket-lib/br/subscope-4-test.rkt b/beautiful-racket-lib/br/subscope-4-test.rkt index 9059522..7104614 100644 --- a/beautiful-racket-lib/br/subscope-4-test.rkt +++ b/beautiful-racket-lib/br/subscope-4-test.rkt @@ -1,49 +1,47 @@ #lang br -(require (for-syntax ) racket/splicing racket/function) +(require (for-syntax br/syntax racket/function) racket/splicing) -(define (->syntax x) +(define-for-syntax (->syntax x) (if (syntax? x) x (datum->syntax #f x))) (define (context stx) (hash-ref (syntax-debug-info stx) 'context)) (define #'(define-scope _color . _parents) - (with-syntax ([color-scope (suffix-id #'_color "-scope")] - [add-color (prefix-id "add-" #'_color)] - [color? (suffix-id #'_color "?")] - [color:define (suffix-id #'_color ":define")] - [color-binding-id (suffix-id #'_color "-binding-id")] - [color-binding-form (suffix-id #'_color "-binding-form")] - [color-string (format-string "~a" #'_color)]) - #'(begin - (define color-scope (procedure-rename (make-syntax-introducer #t) 'color-scope)) - (define (add-color x) ((procedure-rename (curryr color-scope 'add) 'add-color) (->syntax x))) - (define (color? x) - (and - (member (car (context (add-color (datum->syntax #f '_)))) - (context (->syntax x))) - #t)) - (define (color-binding-form x) (syntax-local-introduce (add-color x))) - (define #'(color:define _id-in _expr) - (inject-syntax* ([#'color:id (shared-syntax (prefix-id color-string ":" #'_id-in))] - [#'color-binding-id (syntax-shift-phase-level #'(color-binding-form #'_id-in) 1)] - [#'color-id (syntax-shift-phase-level #'(add-color color-binding-id) 1)]) - #'(begin - (define color-binding-id _expr) - (define-syntax color:id - (syntax-id-rules () - [_ color-id])))))))) + (let ([msi (make-syntax-introducer #t)]) + (with-syntax ([color-scope (suffix-id #'_color "-scope")] + [add-color (prefix-id "add-" #'_color)] + [p1-add-color (prefix-id "p1-add-" #'_color)] + [color? (suffix-id #'_color "?")] + [color:define (suffix-id #'_color ":define")] + [msi msi]) + #'(begin + (begin-for-syntax + (define color-scope (begin (displayln (gensym)) (procedure-rename msi 'color-scope))) + (define (add-color x) ((procedure-rename (curryr color-scope 'add) 'add-color) (->syntax x)))) + (define #'(color? _x) + (with-syntax ([p1-add-color add-color]) + #'(and (member (report (car (context (p1-add-color (datum->syntax #f '_))))) (report (context #'_x))) #t))) + (define #'(color:define _id-in _expr) + (with-syntax ([colored-binding-id (add-color #'_id-in)] + [color:id (prefix-id #'_color ":" #'_id-in)]) + #'(begin + (define colored-binding-id _expr) + (define-syntax color:id + (syntax-id-rules () + [_ colored-binding-id]))))))))) -(define-scope blue) +(require rackunit) -#;(blue:define x 42) +(define-scope blue) -(require rackunit) -(check-true (blue? (add-blue #'x))) -(check-false (blue? #'x)) +(blue:define x 42) +(check-equal? blue:x 42) +(context #'blue:x) +(blue? blue:x) #| (define (double-x)