mbutterick
/
beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

destroy

Browse Source
pull/2/head
Matthew Butterick 8 years ago
parent e1e091421e
commit f9f79d63f6
7 changed files with 0 additions and 268 deletions
Show Stats Download Patch File Download Diff File

32
beautiful-racket-lib/br/scope-ramble.rkt
Unescape Escape View File

@ -1,32 +0,0 @@
#lang br
(require (for-syntax br/syntax))
(define (context stx)
(hash-ref (syntax-debug-info stx) 'context))
(define blue-scope (begin (displayln (gensym)) (procedure-rename (make-syntax-introducer #t) 'blue-scope)))
(define (add-blue x) ((procedure-rename (λ(arg) (blue-scope arg 'add)) 'add-blue) x))
(define-for-syntax my-blue (syntax-shift-phase-level #'add-blue -1))
(define (blue? _x)
(and (member (report (car (context (add-blue (datum->syntax #f '_))))) (report (context #'_x))) #t))
(define #'(blue:define _id-in _expr)
(with-syntax* ([blue-binding-id (syntax-local-eval #`(my-blue #,#'_id-in))]
[blue:id (prefix-id "blue" ":" #'_id-in)])
#'(begin
(define blue-binding-id _expr)
(define-syntax blue:id
(syntax-id-rules ()
[_ blue-binding-id])))))
(require rackunit)
(blue:define x 42)
#|
(check-equal? blue:x 42)
(blue? blue:x)
|#

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

@ -1,62 +0,0 @@
#lang br
(require (for-syntax br/syntax racket/function) racket/splicing)
(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)
(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)
(check-equal? blue:x 42)
(context #'blue:x)
(blue? 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)
|#

35
beautiful-racket-lib/br/subscope-4.rkt
Unescape Escape View File

@ -1,35 +0,0 @@
#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)))))

35
beautiful-racket-lib/br/subscope.rkt
Unescape Escape View File

@ -1,35 +0,0 @@
#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)))))

21
beautiful-racket-lib/br/syntax-scopes-test-2.rkt
Unescape Escape View File

@ -1,21 +0,0 @@
#lang br
(require (for-syntax br/scope))
(begin-for-syntax
(define-scope blue))
(define #'(define-blue _id _expr)
(with-syntax ([_id (blue-binding-form #'_id)])
#'(define _id _expr)))
(define #'(blue _id)
(with-syntax ([_id (blue #'_id)])
#'_id))
(define-syntax x:blue (make-rename-transformer (with-syntax ([x (blue #'x)])
#'x)))
(define-blue x (+ 42 42))
(define y 50)
#;(+ (blue x) y)

22
beautiful-racket-lib/br/syntax-scopes-test-3.rkt
Unescape Escape View File

@ -1,22 +0,0 @@
#lang br
(require "subscope.rkt")
(introduce-scope blue)
(introduce-scope red)
(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)

61
beautiful-racket-lib/br/syntax-scopes-test.rkt
Unescape Escape View File

@ -1,61 +0,0 @@
#lang br
(require (for-syntax br/syntax sugar/debug br/scope) br/syntax br/scope)
(begin-for-syntax
(define-scope blue)
(define-scope yellow)
(define-scope red)
(define-scope green (blue yellow))
(define-scope purple (blue red)))
(define #'(def-blue-x)
(with-blue-binding-form (x)
#'(define x (+ 42 42))))
(define #'(print-blue-x)
(with-purple-identifiers (x)
#'x))
(define #'(define-blue _id _expr)
(with-syntax ([_id (blue-binding-form #'_id)])
#'(define _id _expr)))
(define #'(print-blue-y)
(with-blue-identifiers (y)
#'y))
(scopes (syntax-find (expand-once #'(def-blue-x)) 'x))
(def-blue-x)
(scopes (syntax-find (expand-once #'(print-blue-x)) 'x))
(print-blue-x)
(let ()
(scopes (syntax-find (expand-once #'(print-blue-x)) 'x))
#;(print-blue-x)) ;; error why?
(define-blue y (+ 42 42))
(print-blue-y)
#|
(define #'(def-y)
(with-yellow-binding-form (y)
#'(define y (+ 42))))
#;(scopes (syntax-find (expand-once #'(def-x)) 'x))
#;(def-x)
(def-y)
(scopes (syntax-find (expand-once #'(print-x)) 'x))
(print-x)
(scopes (syntax-find (expand-once #'(print-y)) 'y))
(print-y)
#;(let-syntax ([x (λ(stx) (syntax-case stx () [_ #'42]))])
(* x 4))
|#
Write Preview
Loading…
Cancel
Save