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

id manipulation, `inject-syntax*`

Browse Source
pull/2/head
Matthew Butterick 9 years ago
parent c59b34f868
commit 2d5db8afb5
5 changed files with 202 additions and 176 deletions
Show Stats Download Patch File Download Diff File

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

@ -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))]))

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

@ -1,5 +1,5 @@
#lang br
(require (for-syntax br/syntax))
(require (for-syntax br/scope))
(begin-for-syntax
(define-scope blue))

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

@ -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)

179
beautiful-racket-lib/br/syntax.rkt
Unescape Escape View File

@ -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* stx)
(syntax-case stx ()
[(_ () . body) #'(begin . body)]
[(_ (stx-expr0 stx-expr ...) . body)
#'(inject-syntax (stx-expr0)
(inject-syntax* (stx-expr ...) . body))]))
(define-syntax inject-syntax (make-rename-transformer #'add-syntax))
(define-syntax syntax-let (make-rename-transformer #'inject-syntax))
(define-syntax add-syntax (make-rename-transformer #'inject-syntax))
(define-syntax (map-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)))]))
(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-rule (format-string fmt id0 id ...)
(datum->syntax id0 (format fmt (syntax->datum id0) (syntax->datum id) ...)))
#;(define-syntax syntax-variable (make-rename-transformer #'format-id))
(define (context stx)
(hash-ref (syntax-debug-info stx) 'context))
(define-syntax-rule (->unsyntax x)
(if (syntax? x)
(syntax->datum x)
x))
(define-syntax-rule (scopes stx)
(format "~a = ~a" 'stx
(cons (syntax->datum stx)
(for/list ([scope (in-list (context stx))])
scope))))
(define-syntax-rule (prefix-id _prefix ... _base)
(format-id _base "~a~a" (string-append (format "~a" (->unsyntax _prefix)) ...) _base))
(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 (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 x)
(if (syntax? x) x (datum->syntax #f x)))
(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 (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 (suffix-ids _bases _suffix ...)
(infix-ids "" _bases _suffix ...))

50
beautiful-racket/br/demo/hdl/expander.rkt
Unescape Escape View File

@ -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)])])
(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 _input-pin ... in-pin-write ...)))
(define-input-bus _input-pin _input-width ...) ...
(provide (prefix-out _chip-prefix (combine-out _in-bus ... _in-bus-write ...)))
(define-input-bus _in-bus _in-width ...) ...
_part ...
(provide prefixed-output-pin ...)
(define-output-bus prefixed-output-pin _output-pin _output-width ...) ...)))
(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)))])
(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-wires ((prefixed-wire . _wireargs) _wirevalue) ...))))
(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 ...) ()
(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))])])
(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])
(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 out-bus
(define-output-bus _new-out-bus
(λ ()
(in-wire-write in-arg ... input-expr) ...
(out-wire out-arg ...))) ...))))
(_in-bus-write _in-bus-arg ... _in-bus-value) ...
_out-bus-expr)) ...))))
Write Preview
Loading…
Cancel
Save