scopes

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

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)
+  (require rackunit)
-(define-scope red)
+  (define-scope red)
-
+  
-(define stx (datum->syntax #f 'x))
+  (define stx (datum->syntax #f 'x))
-
+  
-(define red-stx (add-red stx))
+  (define red-stx (add-red stx))
-(define double-red-stx (add-red (add-red stx)))
+  (define double-red-stx (add-red (add-red stx)))
-
+  
-
+  
-(check-false (red? stx))
+  (check-false (red? stx))
-(check-true (red? red-stx))
+  (check-true (red? red-stx))
-(check-true (red? double-red-stx))
+  (check-true (red? double-red-stx))
-(check-false (scopes-equal? stx red-stx))
+  (check-false (scopes-equal? stx red-stx))
-(check-true (scopes-equal? red-stx double-red-stx))
+  (check-true (scopes-equal? red-stx double-red-stx))
-(check-false (scopes-equal? red-stx (remove-red double-red-stx)))
+  (check-false (scopes-equal? red-stx (remove-red double-red-stx)))
-
+  
-
+  
-(define-scope blue) ; scope addition is commutative
+  (define-scope blue) ; scope addition is commutative
-(define blue-stx (blue stx))
+  (define blue-stx (blue stx))
-(check-true (scopes-equal? (add-blue red-stx) (add-red 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))))
+  (check-true (scopes-equal? (remove-red (add-blue red-stx)) (remove-red (add-red blue-stx))))
-
+  
-
+  
-(define-scope green) ; replace scopes at outer layer
+  (define-scope green) ; replace scopes at outer layer
-(check-true (scopes-equal? (green red-stx) (green blue-stx)))
+  (check-true (scopes-equal? (green red-stx) (green blue-stx)))
-
+  
-
+  
-;; replace scopes everywhere
+  ;; replace scopes everywhere
-(check-true (scopes-equal? (car (syntax->list (green* #`(#,blue-stx #,red-stx))))
+  (check-true (scopes-equal? (car (syntax->list (green* #`(#,blue-stx #,red-stx))))
-                           (car (syntax->list (green* #`(#,red-stx #,blue-stx))))))
+                             (car (syntax->list (green* #`(#,red-stx #,blue-stx))))))
-
+  
-;; todo: test flipping
+  ;; todo: test flipping
-
+  
-
+  
-(define-scope purple (red blue))
+  (define-scope purple (red blue))
-
+  
-(check-true (purple? (add-purple stx)))
+  (check-true (purple? (add-purple stx)))
-(check-true (scopes-equal? (purple (green stx)) (add-blue (remove-green (add-red (add-green (add-blue stx))))))))
+  (check-true (scopes-equal? (purple (green stx)) (add-blue (remove-green (add-red (add-green (add-blue stx))))))))
 
 
 (define-syntax (with-scopes stx)