suzanne.soy/beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

mysteries

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-22 22:22:51 -07:00
parent 3516555682
commit 084fb8ace2
1 changed files with 30 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
beautiful-racket-lib/br/subscope-4-test.rkt
View File

@ -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])))))))))
(require rackunit)
(define-scope blue)
#;(blue:define x 42)
(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)