id manipulation, `inject-syntax*`

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

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

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)

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* 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 ...))
 
 

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 ...) ...)))
-
-
-(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) ...))))
+  (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 _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 ...))) ...))))
+(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)) ...))))