From 187230041ed42ff38a4223ff003b68fa6eaa9937 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Fri, 20 May 2016 22:33:20 -0700
Subject: [PATCH] syntaxing

---
 beautiful-racket-lib/br/syntax.rkt        | 50 +++++++++++++----------
 beautiful-racket/br/demo/hdl/expander.rkt | 21 ++++++----
 2 files changed, 41 insertions(+), 30 deletions(-)

diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt
index 31850cc..2bad0f9 100644
--- a/beautiful-racket-lib/br/syntax.rkt
+++ b/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 racket/list)
+         syntax/strip-context racket/function racket/list racket/syntax)
 (provide (all-defined-out) (all-from-out syntax/strip-context))
 
 
@@ -33,29 +33,37 @@
          (for/list ([arg (in-list (syntax->list args))])
                    (_proc arg)))]))
 
+
 (define identity (λ(arg) arg))
-(define-syntax (partition-syntax-case stx)
+(define-syntax (syntax-case-partition stx)
   (syntax-case stx ()
-    [(_ (_matchers ...) _stx-list)
-     #'(let* ([stx-list _stx-list]
-              [stxs (cond
-                      [(and (syntax? stx-list) (syntax->list stx-list)) => identity]
-                      [(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)
+    [(_ _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))]))
+
+(define-syntax (syntax-case-filter stx)
   (syntax-case stx ()
-    [(_ _proc _args)
-     #'(let ([args _args])
-         (datum->syntax args
-                        (if (and (syntax? args) (list? (syntax-e args)))
-                            (for*/list ([arg (in-list (syntax->list args))]
-                                        [result (in-value (_proc (syntax->datum arg)))]
-                                        #:when result)
-                                       arg)
-                            (error 'not-syntax-list))))]))
+    [(_ _stx-list literals . _matchers)
+     #'(let-values ([(matches others) (syntax-case-partition _stx-list literals . _matchers)])
+         matches)]))
+
+
+(define-syntax (syntax-case-map stx)
+  (syntax-case stx ()
+    [(_ _stx-list literals . _matchers)
+     #'(map (λ(stx-item)
+              (syntax-case stx-item literals
+                . _matchers)) (if (syntax? _stx-list)
+                                    (syntax->list _stx-list)
+                                    _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))
diff --git a/beautiful-racket/br/demo/hdl/expander.rkt b/beautiful-racket/br/demo/hdl/expander.rkt
index 0b21ab6..351f7d1 100644
--- a/beautiful-racket/br/demo/hdl/expander.rkt
+++ b/beautiful-racket/br/demo/hdl/expander.rkt
@@ -7,9 +7,11 @@
                         (in-spec (_input-pin _input-width ...) ...)
                         (out-spec (_output-pin _output-width ...) ...)
                         _part ...)
-  (with-syntax* ([chip-prefix (format-id #'_chipname "~a-" #'_chipname)]
-                 [(in-pin-write ...) (map (λ(iw) (format-id iw "~a-write" iw)) (syntax->list #'(_input-pin ...)))]
-                 [(prefixed-output-pin ...) (map (λ(op) (format-id op "~a~a" #'chip-prefix op)) (syntax->list #'(_output-pin ...)))])
+  (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 ...) ...
@@ -19,7 +21,8 @@
 
 
 (define #'(part _prefix ((_wire . _wireargs) _wirevalue) ...)
-  (with-syntax ([(prefixed-wire ...) (map (λ(s) (format-id s "~a-~a" #'_prefix s)) (syntax->list #'(_wire ...)))]
+  (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)))
@@ -36,12 +39,12 @@
 
 (define #'(handle-wires _wire-assignments ...)
   (let-values ([(in-wire-stxs out-wire-stxs)
-                (partition-syntax-case
-                 ([((prefixed-wire . _wireargs) _)
-                   (syntax-local-eval (syntax-shift-phase-level #'(input-bus? prefixed-wire) 1))])
-                 #'(_wire-assignments ...))])
+                (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 ...) (map (λ(iw) (format-id iw "~a-write" iw)) (syntax->list #'(in-wire ...)))]
+                   [(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