From 2d5db8afb5dc6fa5b53ed23fbc3bc1c7a96eeb23 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Sat, 21 May 2016 10:21:00 -0700
Subject: [PATCH] id manipulation, `inject-syntax*`
---
beautiful-racket-lib/br/scope.rkt | 127 ++++++++++++
.../br/syntax-scopes-test-2.rkt | 2 +-
.../br/syntax-scopes-test.rkt | 2 +-
beautiful-racket-lib/br/syntax.rkt | 193 +++++-------------
beautiful-racket/br/demo/hdl/expander.rkt | 64 +++---
5 files changed, 207 insertions(+), 181 deletions(-)
create mode 100644 beautiful-racket-lib/br/scope.rkt
diff --git a/beautiful-racket-lib/br/scope.rkt b/beautiful-racket-lib/br/scope.rkt
new file mode 100644
index 0000000..7d0e6ef
--- /dev/null
+++ b/beautiful-racket-lib/br/scope.rkt
@@ -0,0 +1,127 @@
+#lang racket/base
+(require (for-syntax racket/base br/syntax racket/syntax) syntax/strip-context racket/function)
+(provide (all-defined-out))
+
+(define (->syntax x)
+ (if (syntax? x) x (datum->syntax #f x)))
+
+
+(define (context stx)
+ (hash-ref (syntax-debug-info stx) 'context))
+
+(define-syntax-rule (scopes stx)
+ (format "~a = ~a" 'stx
+ (cons (syntax->datum stx)
+ (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 (define-scope stx)
+ (syntax-case stx ()
+ [(_ id)
+ #'(define-scope id ())]
+ [(_ id scope-ids)
+ (with-syntax ([id-sis (suffix-id #'id "-sis")]
+ [add-id (prefix-id "add-" #'id)]
+ [flip-id (prefix-id "flip-" #'id)]
+ [id-binding-form (suffix-id #'id "-binding-form")]
+ [define-id (prefix-id "define-" #'id)]
+ [with-id-identifiers (infix-id "with-" #'id "-identifiers")]
+ [let-id-syntax (infix-id "let-" #'id "-syntax")]
+ [with-id-binding-form (infix-id "with-" #'id "-binding-form")]
+ [remove-id (prefix-id "remove-" #'id)]
+ [id? (suffix-id #'id "?")]
+ [id* (suffix-id #'id "*")]
+ [(scope-id-sis ...) (suffix-ids #'scope-ids "-sis")])
+ #'(begin
+ (define id-sis
+ (let ([sis-in (list scope-id-sis ...)])
+ (if (pair? sis-in)
+ (apply append sis-in)
+ (list
+ (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)))))))
+ (define add-id (λ(x) ((apply compose1 (map car id-sis)) (->syntax x))))
+ (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))
+ (define-syntax-rule (with-id-identifiers (name (... ...)) . body)
+ (with-syntax ([name (id* 'name)] (... ...)) . body))
+ (define-syntax-rule (with-id-binding-form (name (... ...)) . body)
+ (with-syntax ([name (id-binding-form 'name)] (... ...)) . 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"
+ (bound-identifier=? (datum->syntax stxl '_) (datum->syntax stxr '_)))
+
+
+(module+ test
+ (require rackunit)
+ (define-scope red)
+
+ (define stx (datum->syntax #f 'x))
+
+ (define red-stx (add-red stx))
+ (define double-red-stx (add-red (add-red stx)))
+
+
+ (check-false (red? stx))
+ (check-true (red? red-stx))
+ (check-true (red? double-red-stx))
+ (check-false (scopes-equal? stx red-stx))
+ (check-true (scopes-equal? red-stx double-red-stx))
+ (check-false (scopes-equal? red-stx (remove-red double-red-stx)))
+
+
+ (define-scope blue) ; scope addition is commutative
+ (define blue-stx (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))))
+
+
+ (define-scope green) ; replace scopes at outer layer
+ (check-true (scopes-equal? (green red-stx) (green blue-stx)))
+
+
+ ;; replace scopes everywhere
+ (check-true (scopes-equal? (car (syntax->list (green* #`(#,blue-stx #,red-stx))))
+ (car (syntax->list (green* #`(#,red-stx #,blue-stx))))))
+
+ ;; todo: test flipping
+
+
+ (define-scope purple (red blue))
+
+ (check-true (purple? (add-purple stx)))
+ (check-true (scopes-equal? (purple (green stx)) (add-blue (remove-green (add-red (add-green (add-blue stx))))))))
+
+
+(define-syntax (with-scopes stx)
+ (syntax-case stx (syntax)
+ [(_ (scope-id) (syntax expr))
+ (with-syntax ([add-scope-id (format-id #'scope-id "add-~a" #'scope-id)])
+ #'(add-scope-id expr))]))
+
diff --git a/beautiful-racket-lib/br/syntax-scopes-test-2.rkt b/beautiful-racket-lib/br/syntax-scopes-test-2.rkt
index fdbe367..5f5afae 100644
--- a/beautiful-racket-lib/br/syntax-scopes-test-2.rkt
+++ b/beautiful-racket-lib/br/syntax-scopes-test-2.rkt
@@ -1,5 +1,5 @@
#lang br
-(require (for-syntax br/syntax))
+(require (for-syntax br/scope))
(begin-for-syntax
(define-scope blue))
diff --git a/beautiful-racket-lib/br/syntax-scopes-test.rkt b/beautiful-racket-lib/br/syntax-scopes-test.rkt
index 697c45a..f6d068d 100644
--- a/beautiful-racket-lib/br/syntax-scopes-test.rkt
+++ b/beautiful-racket-lib/br/syntax-scopes-test.rkt
@@ -1,5 +1,5 @@
#lang br
-(require (for-syntax br/syntax sugar/debug) br/syntax)
+(require (for-syntax br/syntax sugar/debug br/scope) br/syntax br/scope)
(begin-for-syntax
(define-scope blue)
diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt
index cbb0c19..d89c2b8 100644
--- a/beautiful-racket-lib/br/syntax.rkt
+++ b/beautiful-racket-lib/br/syntax.rkt
@@ -10,7 +10,7 @@
#'(syntax-case stx-arg ()
[pattern body ...] ...)]))
-(define-syntax (add-syntax stx)
+(define-syntax (inject-syntax stx)
;; todo: permit mixing of two-arg and one-arg binding forms
;; one-arg form allows you to inject an existing syntax object using its current name
(syntax-case stx (syntax)
@@ -20,171 +20,74 @@
[(_ ([sid] ...) body ...)
#'(with-syntax ([sid sid] ...) body ...)]))
-(define-syntax syntax-let (make-rename-transformer #'add-syntax))
-
-(define-syntax inject-syntax (make-rename-transformer #'add-syntax))
-
-(define-syntax (map-syntax stx)
+(define-syntax (inject-syntax* stx)
(syntax-case stx ()
- [(_ _proc _args)
- #'(let ([args _args])
- (unless (and (syntax? args) (list? (syntax-e args)))
- (raise-argument-error 'map-syntax "not a syntax list"))
- (for/list ([arg (in-list (syntax->list args))])
- (_proc arg)))]))
+ [(_ () . body) #'(begin . body)]
+ [(_ (stx-expr0 stx-expr ...) . body)
+ #'(inject-syntax (stx-expr0)
+ (inject-syntax* (stx-expr ...) . body))]))
+
+(define-syntax syntax-let (make-rename-transformer #'inject-syntax))
+(define-syntax add-syntax (make-rename-transformer #'inject-syntax))
+
+
+(define (check-syntax-list-argument caller-name arg)
+ (cond
+ [(and (syntax? arg) (syntax->list arg))]
+ [(list? arg) arg]
+ [else (raise-argument-error caller-name "list of syntax, or syntaxed list" arg)]))
-(define identity (λ(arg) arg))
(define-syntax-rule (syntax-case-partition _stx-list _literals . _matchers)
(partition (λ(stx-item)
(with-handlers ([exn:fail:syntax? (λ (exn) #f)])
(syntax-case stx-item _literals
- . _matchers))) (if (syntax? _stx-list)
- (syntax->list _stx-list)
- _stx-list)))
+ . _matchers))) (check-syntax-list-argument 'syntax-case-partition _stx-list)))
(define-syntax-rule (syntax-case-filter _stx-list _literals . _matchers)
- (let-values ([(matches others) (syntax-case-partition _stx-list _literals . _matchers)])
- matches))
+ (filter (λ(stx-item)
+ (with-handlers ([exn:fail:syntax? (λ (exn) #f)])
+ (syntax-case stx-item _literals
+ . _matchers))) (check-syntax-list-argument 'syntax-case-filter _stx-list)))
(define-syntax-rule (syntax-case-map _stx-list _literals . _matchers)
(map (λ(stx-item)
(syntax-case stx-item _literals
- . _matchers)) (if (syntax? _stx-list)
- (syntax->list _stx-list)
- _stx-list)))
+ . _matchers)) (check-syntax-list-argument 'syntax-case-map _stx-list)))
(define-syntax-rule (reformat-id fmt id0 id ...)
(format-id id0 fmt id0 id ...))
-
-#;(define-syntax syntax-variable (make-rename-transformer #'format-id))
-
-(define (context stx)
- (hash-ref (syntax-debug-info stx) 'context))
-
-(define-syntax-rule (scopes stx)
- (format "~a = ~a" 'stx
- (cons (syntax->datum stx)
- (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-rule (format-string fmt id0 id ...)
+ (datum->syntax id0 (format fmt (syntax->datum id0) (syntax->datum id) ...)))
-(define (->syntax x)
- (if (syntax? x) x (datum->syntax #f x)))
-
-
-(define-syntax (define-scope stx)
- (syntax-case stx ()
- [(_ id)
- #'(define-scope id ())]
- [(_ id scope-ids)
- (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)]
- [define-id (format-id #'id "define-~a" #'id)]
- [with-id-identifiers (format-id #'id "with-~a-identifiers" #'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)]
- [(scope-id-sis ...) (map (λ(sid) (format-id sid "~a-sis" sid)) (syntax->list #'scope-ids))])
- #'(begin
- (define id-sis
- (let ([sis-in (list scope-id-sis ...)])
- (if (pair? sis-in)
- (apply append sis-in)
- (list
- (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)))))))
- (define add-id (λ(x) ((apply compose1 (map car id-sis)) (->syntax x))))
- (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))
- (define-syntax-rule (with-id-identifiers (name (... ...)) . body)
- (with-syntax ([name (id* 'name)] (... ...)) . body))
- (define-syntax-rule (with-id-binding-form (name (... ...)) . body)
- (with-syntax ([name (id-binding-form 'name)] (... ...)) . 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"
- (bound-identifier=? (datum->syntax stxl '_) (datum->syntax stxr '_)))
-
-
-(module+ test
- (require rackunit)
- (define-scope red)
-
- (define stx (datum->syntax #f 'x))
-
- (define red-stx (add-red stx))
- (define double-red-stx (add-red (add-red stx)))
-
-
- (check-false (red? stx))
- (check-true (red? red-stx))
- (check-true (red? double-red-stx))
- (check-false (scopes-equal? stx red-stx))
- (check-true (scopes-equal? red-stx double-red-stx))
- (check-false (scopes-equal? red-stx (remove-red double-red-stx)))
-
-
- (define-scope blue) ; scope addition is commutative
- (define blue-stx (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))))
-
-
- (define-scope green) ; replace scopes at outer layer
- (check-true (scopes-equal? (green red-stx) (green blue-stx)))
-
-
- ;; replace scopes everywhere
- (check-true (scopes-equal? (car (syntax->list (green* #`(#,blue-stx #,red-stx))))
- (car (syntax->list (green* #`(#,red-stx #,blue-stx))))))
-
- ;; todo: test flipping
-
-
- (define-scope purple (red blue))
-
- (check-true (purple? (add-purple stx)))
- (check-true (scopes-equal? (purple (green stx)) (add-blue (remove-green (add-red (add-green (add-blue stx))))))))
-
-
-(define-syntax (with-scopes stx)
- (syntax-case stx (syntax)
- [(_ (scope-id) (syntax expr))
- (with-syntax ([add-scope-id (format-id #'scope-id "add-~a" #'scope-id)])
- #'(add-scope-id expr))]))
+(define-syntax-rule (->unsyntax x)
+ (if (syntax? x)
+ (syntax->datum x)
+ x))
+
+(define-syntax-rule (prefix-id _prefix ... _base)
+ (format-id _base "~a~a" (string-append (format "~a" (->unsyntax _prefix)) ...) _base))
+
+(define-syntax-rule (prefix-ids _prefix ... _bases)
+ (syntax-case-map _bases ()
+ [_base (prefix-id _prefix ... #'_base)]))
+
+(define-syntax-rule (infix-id _prefix _base _suffix ...)
+ (format-id _base "~a~a~a" (->unsyntax _prefix) _base (string-append (format "~a" (->unsyntax _suffix)) ...)))
+
+(define-syntax-rule (infix-ids _prefix _bases _suffix ...)
+ (syntax-case-map _bases ()
+ [_base (infix-id _prefix #'_base _suffix ...)]))
+
+(define-syntax-rule (suffix-id _base _suffix ...)
+ (infix-id "" _base _suffix ...))
+
+(define-syntax-rule (suffix-ids _bases _suffix ...)
+ (infix-ids "" _bases _suffix ...))
diff --git a/beautiful-racket/br/demo/hdl/expander.rkt b/beautiful-racket/br/demo/hdl/expander.rkt
index 351f7d1..3e290e7 100644
--- a/beautiful-racket/br/demo/hdl/expander.rkt
+++ b/beautiful-racket/br/demo/hdl/expander.rkt
@@ -4,29 +4,26 @@
(define #'(chip-program _chipname
- (in-spec (_input-pin _input-width ...) ...)
- (out-spec (_output-pin _output-width ...) ...)
+ (in-spec (_in-bus _in-width ...) ...)
+ (out-spec (_out-bus _out-width ...) ...)
_part ...)
- (with-syntax* ([chip-prefix (reformat-id "~a-" #'_chipname)]
- [(in-pin-write ...) (syntax-case-map #'(_input-pin ...) ()
- [iw (reformat-id "~a-write" #'iw)])]
- [(prefixed-output-pin ...) (syntax-case-map #'(_output-pin ...) ()
- [op (format-id #'op "~a~a" #'chip-prefix #'op)])])
- #'(begin
- (provide (prefix-out chip-prefix (combine-out _input-pin ... in-pin-write ...)))
- (define-input-bus _input-pin _input-width ...) ...
- _part ...
- (provide prefixed-output-pin ...)
- (define-output-bus prefixed-output-pin _output-pin _output-width ...) ...)))
+ (inject-syntax* ([#'_chip-prefix (suffix-id #'_chipname "-")]
+ [#'(_in-bus-write ...) (suffix-ids #'(_in-bus ...) "-write")]
+ [#'(_prefix-out-bus ...) (prefix-ids #'_chip-prefix #'(_out-bus ...))])
+ #'(begin
+ (provide (prefix-out _chip-prefix (combine-out _in-bus ... _in-bus-write ...)))
+ (define-input-bus _in-bus _in-width ...) ...
+ _part ...
+ (provide _prefix-out-bus ...)
+ (define-output-bus _prefix-out-bus _out-bus _out-width ...) ...)))
-(define #'(part _prefix ((_wire . _wireargs) _wirevalue) ...)
- (with-syntax ([(prefixed-wire ...) (syntax-case-map #'(_wire ...) ()
- [s (format-id #'s "~a-~a" #'_prefix #'s)])]
- [chip-module-path (datum->syntax #'_prefix (format "~a.hdl.rkt" (syntax->datum #'_prefix)))])
- #'(begin
- (require (import-chip chip-module-path) (for-syntax (import-chip chip-module-path)))
- (handle-wires ((prefixed-wire . _wireargs) _wirevalue) ...))))
+(define #'(part _partname ((_bus-left . _busargs) _bus-expr-right) ...)
+ (inject-syntax ([#'(_partname-bus-left ...) (prefix-ids #'_partname "-" #'(_bus-left ...))]
+ [#'_chip-module-path (format-string "~a.hdl.rkt" #'_partname)])
+ #'(begin
+ (require (import-chip _chip-module-path) (for-syntax (import-chip _chip-module-path)))
+ (handle-buses ((_partname-bus-left . _busargs) _bus-expr-right) ...))))
(define-syntax import-chip
@@ -37,17 +34,16 @@
(expand-import #'module-path)]))))
-(define #'(handle-wires _wire-assignments ...)
- (let-values ([(in-wire-stxs out-wire-stxs)
- (syntax-case-partition #'(_wire-assignments ...) ()
- [((prefixed-wire . _wireargs) _)
- (syntax-local-eval (syntax-shift-phase-level #'(input-bus? prefixed-wire) 1))])])
- (with-syntax* ([(((in-wire in-arg ...) input-expr) ...) in-wire-stxs]
- [(in-wire-write ...) (syntax-case-map #'(in-wire ...) ()
- [iw (reformat-id "~a-write" #'iw)])]
- [(((out-wire out-arg ...) (out-bus)) ...) out-wire-stxs])
- #'(begin
- (define-output-bus out-bus
- (λ ()
- (in-wire-write in-arg ... input-expr) ...
- (out-wire out-arg ...))) ...))))
\ No newline at end of file
+(define #'(handle-buses _bus-assignments ...)
+ (let-values ([(_in-bus-assignments _out-bus-assignments)
+ (syntax-case-partition #'(_bus-assignments ...) ()
+ [((prefixed-wire . _wireargs) _)
+ (syntax-local-eval (syntax-shift-phase-level #'(input-bus? prefixed-wire) 1))])])
+ (inject-syntax* ([#'(((_in-bus _in-bus-arg ...) _in-bus-value) ...) _in-bus-assignments]
+ [#'(_in-bus-write ...) (suffix-ids #'(_in-bus ...) "-write")]
+ [#'((_out-bus-expr (_new-out-bus)) ...) _out-bus-assignments])
+ #'(begin
+ (define-output-bus _new-out-bus
+ (λ ()
+ (_in-bus-write _in-bus-arg ... _in-bus-value) ...
+ _out-bus-expr)) ...))))
\ No newline at end of file