mysteries

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)