`partition-syntax-case`

beautiful-racket-lib/br/syntax.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
 (require (for-syntax racket/base syntax/parse racket/syntax syntax/strip-context)
-         syntax/strip-context racket/function)
+         syntax/strip-context racket/function racket/list)
 (provide (all-defined-out) (all-from-out syntax/strip-context))
 
 
@@ -33,13 +33,17 @@
          (for/list ([arg (in-list (syntax->list args))])
                    (_proc arg)))]))
 
-(define-syntax (partition-syntax stx)
+(define identity (λ(arg) arg))
+(define-syntax (partition-syntax-case stx)
   (syntax-case stx ()
-    [(_ _proc _args)
+    [(_ (_matchers ...) _stx-list)
-     #'(let ([args _args])
+     #'(let* ([stx-list _stx-list]
-         (unless (and (syntax? args) (list? (syntax-e args)))
+              [stxs (cond
-           (raise-argument-error 'map-syntax "not a syntax list"))
+                      [(and (syntax? stx-list) (syntax->list stx-list)) => identity]
-         (partition _proc (syntax->list args)))]))
+                      [(and (list? stx-list) (andmap syntax? list)) stx-list]
+                      [else (raise-argument-error 'partition-syntax-case "syntaxed list or list of syntax objects" stx-list)])])
+         (partition (λ(stx-item) (syntax-case stx-item ()
+                                   _matchers ...)) stxs))]))
 
 (define-syntax (filter-syntax stx)
   (syntax-case stx ()

beautiful-racket/br/demo/hdl/expander.rkt

@@ -1,5 +1,5 @@
 #lang br
-(require "helper.rkt" (for-syntax racket/base racket/syntax "helper.rkt" racket/list racket/require-transform))
+(require "helper.rkt" (for-syntax racket/base racket/syntax racket/require-transform br/syntax))
 (provide #%top-interaction #%module-begin #%app #%datum and or (all-defined-out))
 
 
@@ -36,11 +36,10 @@
 
 (define #'(handle-wires _wire-assignments ...)
   (let-values ([(in-wire-stxs out-wire-stxs)
-                (partition (λ(wa)
+                (partition-syntax-case
-                             (syntax-case wa ()
+                 ([((prefixed-wire . _wireargs) _)
-                               [((prefixed-wire . _wireargs) _)
+                   (syntax-local-eval (syntax-shift-phase-level #'(input-bus? prefixed-wire) 1))])
-                                (input-bus? (syntax-local-eval #'prefixed-wire))]))
+                 #'(_wire-assignments ...))])
-                           (syntax->list #'(_wire-assignments ...)))])
     (with-syntax* ([(((in-wire in-arg ...) input-expr) ...) in-wire-stxs]
                    [(in-wire-write ...) (map (λ(iw) (format-id iw "~a-write" iw)) (syntax->list #'(in-wire ...)))]
                    [(((out-wire out-arg ...) (out-bus)) ...) out-wire-stxs])