From 3516555682ff3ca39b10e2b717af532c8e6d7eda Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Sun, 22 May 2016 17:59:24 -0700
Subject: [PATCH] scope experiments

---
 beautiful-racket-lib/br/subscope-4-test.rkt | 64 +++++++++++++++++++++
 beautiful-racket-lib/br/subscope-4.rkt      | 35 +++++++++++
 2 files changed, 99 insertions(+)
 create mode 100644 beautiful-racket-lib/br/subscope-4-test.rkt
 create mode 100644 beautiful-racket-lib/br/subscope-4.rkt

diff --git a/beautiful-racket-lib/br/subscope-4-test.rkt b/beautiful-racket-lib/br/subscope-4-test.rkt
new file mode 100644
index 0000000..9059522
--- /dev/null
+++ b/beautiful-racket-lib/br/subscope-4-test.rkt
@@ -0,0 +1,64 @@
+#lang br
+(require (for-syntax ) racket/splicing racket/function)
+
+(define (->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]))))))))
+
+(define-scope blue)
+
+#;(blue:define x 42)
+
+(require rackunit)
+(check-true (blue? (add-blue #'x)))
+(check-false (blue? #'x))
+
+
+
+
+#|
+(define (double-x)
+  (with-blue-identifiers (x)
+                         (set! x (+ x x))))
+
+(define (display-x)
+  (with-blue-identifiers (x)
+                         (displayln x)))
+
+(blue:define x 42)
+
+blue:x
+
+(double-x)
+
+(display-x)
+|#
\ No newline at end of file
diff --git a/beautiful-racket-lib/br/subscope-4.rkt b/beautiful-racket-lib/br/subscope-4.rkt
new file mode 100644
index 0000000..e73764c
--- /dev/null
+++ b/beautiful-racket-lib/br/subscope-4.rkt
@@ -0,0 +1,35 @@
+#lang br
+(require (for-syntax br/syntax))
+(provide (all-defined-out))
+
+(define #'(introduce-scope _color . _parents)
+  (with-syntax ([color #'_color]
+                [color-string (format-string "~a" #'_color)]
+                [color:define (suffix-id #'_color ":define")]
+                [color:id (suffix-id #'_color ":id")]
+                [color-binding-id (suffix-id #'_color "-binding-id")]
+                [color-binding-form (suffix-id  #'_color "-binding-form")]
+                [color-id (suffix-id #'_color "-id")]
+                [module-name (generate-temporary)]
+                [parents (if (pair? (syntax->list #'_parents))
+                             (car (syntax->list #'_parents))
+                             (syntax->list #'_parents))])
+    (replace-context #'_color
+                     #'(begin
+                         (module module-name br
+                           (require (for-syntax br/datum br/scope br/syntax))
+                           (provide (for-syntax (all-defined-out)) (all-defined-out))
+                           
+                           (begin-for-syntax
+                             (define-scope color parents))
+                           
+                           (define #'(color:define _id-in _expr)
+                             (inject-syntax* ([#'color:id (shared-syntax (prefix-id color-string ":" #'_id-in))]
+                                              [#'color-binding-id (color-binding-form #'_id-in)]
+                                              [#'color-id (color #'color-binding-id)])
+                                             #'(begin
+                                                 (define color-binding-id _expr)
+                                                 (define-syntax color:id
+                                                   (syntax-id-rules ()
+                                                     [_ color-id]))))))
+                         (require 'module-name)))))