From 2feaa1084d10d4217026fe7df14394bfa490df0f Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Tue, 26 Apr 2016 16:22:59 -0700
Subject: [PATCH] convert to `define-inverting`

---
 beautiful-racket/br/demo/hdl/expander.rkt | 88 +++++++++--------------
 beautiful-racket/br/demo/hdl/parser.rkt   | 10 ++-
 2 files changed, 39 insertions(+), 59 deletions(-)

diff --git a/beautiful-racket/br/demo/hdl/expander.rkt b/beautiful-racket/br/demo/hdl/expander.rkt
index 4f94eb4..28d5146 100644
--- a/beautiful-racket/br/demo/hdl/expander.rkt
+++ b/beautiful-racket/br/demo/hdl/expander.rkt
@@ -1,73 +1,49 @@
 #lang br
-(provide #%top-interaction #%module-begin #%datum #%top #%app)
+(provide #%top-interaction #%module-begin (all-defined-out))
 
-(provide chip-program)
-(define #'(chip-program "CHIP" _arg ...)
+(define-inverting #'(chip-program "CHIP" _arg ...)
   #'(chip _arg ...))
 
-(provide pin-spec)
-(define #'(pin-spec _label _pin-list ";")
+(define-inverting #'(pin-spec _label _pin-list ";")
   #'_pin-list)
 
-(require (for-syntax sugar/debug))
+(define-inverting #'(pin-list  _id _comma-id ...)
+  #'(_id _comma-id ...))
 
+(define-inverting #'(comma-id "," _id)
+  #'_id)
 
-(define-for-syntax (remove-separators stx-or-list sep)
-  (for/list ([item (in-list (if (list? stx-or-list)
-                                stx-or-list
-                                (syntax->list stx-or-list)))]
-             #:when (not (equal? sep (syntax->datum item))))
-            item))
-
-(provide pin-list)
-(define #'(pin-list . _pin-or-commas)
-  (remove-separators #'_pin-or-commas ","))
-
-(begin-for-syntax
-  (define (expand-macro mac)
-    (syntax-disarm (local-expand mac 'expression #f) #f)))
-
-(provide part-spec)
-(define #'(part-spec "PARTS:" _part-list)
+(define-inverting #'(part-spec "PARTS:" _part-list)
   #'_part-list)
 
-(provide part-list)
-(define #'(part-list . _part-or-semicolons)
-  (inject-syntax ([#'(part ...) (remove-separators #'_part-or-semicolons "'")])
-                 #'(begin part ...)))
-
-(require (for-syntax sugar/list))
-(define-for-syntax (ugly-processing stx)
-  (slice-at (remove-separators (remove-separators stx ",") "=") 2))
+(define-inverting #'(part-list _part ...)
+  #'(begin _part ...))
 
-(provide part)
-(define #'(part _partname "(" _pin-id-etc ... out "=" _pin-out ")" ";")
-  (with-syntax ([((_pin-in _val-id) ...) (ugly-processing #'(_pin-id-etc ...))])
-           #'(begin
-               (define _pin-out (call-part _partname [_pin-in _val-id] ...)))))
+(define-inverting #'(part _partname "(" _firstpin "=" _firstval _commaidpair ... (_lastpin _pinout) ")" ";")
+  #'(begin
+      (define _pinout (call-part _partname [_firstpin _firstval] _commaidpair ...))))
 
-(define #'(chip _chipname "{"
-                _input-pins
-                _output-pins
-                _part-spec "}")
-  (inject-syntax ([#'(_input-pin ...) (expand-macro #'_input-pins)]
-                  [#'(_output-pin ...) (expand-macro #'_output-pins)]
-                  [#'_part (expand-macro #'_part-spec)])
-                 #'(begin
-                     (provide _chipname)
-                     (define _chipname
-                       (procedure-rename
-                        (make-keyword-procedure
-                        (λ (kws kw-args . rest)
-                          (define kw-pairs (map cons kws kw-args))
-                          (let ([_input-pin (cdr (assq (string->keyword (format "~a" '_input-pin)) kw-pairs))] ...)
-                            _part 
-                            (values _output-pin ...)))) '_chipname)))))
+(define #'(comma-id-pair "," _firstid "=" _secondid)
+  #'(_firstid _secondid))
 
-(provide call-part)
-(define #'(call-part _Part [_pin-in _val-id] ...)
+(define-inverting #'(call-part _Part [_pin-in _val-id] ...)
   (with-syntax ([part-path (format "~a.hdl" (syntax->datum #'_Part))]
                 [(kw ...) (map (λ(pi) (string->keyword (format "~a" (syntax->datum pi)))) (syntax->list #'(_pin-in ...)))])
     #'(let ()
         (local-require (rename-in part-path [_Part local-name]))
-        (keyword-apply local-name '(kw ...) (list _val-id ...) null))))
\ No newline at end of file
+        (keyword-apply local-name '(kw ...) (list _val-id ...) null))))
+
+(define-inverting #'(chip _chipname "{"
+                          (_input-pin ...)
+                          (_output-pin ...)
+                          _part-spec "}")
+  #'(begin
+      (provide _chipname)
+      (define _chipname
+        (procedure-rename
+         (make-keyword-procedure
+          (λ (kws kw-args . rest)
+            (define kw-pairs (map cons kws kw-args))
+            (let ([_input-pin (cdr (assq (string->keyword (format "~a" '_input-pin)) kw-pairs))] ...)
+              _part-spec
+              (values _output-pin ...)))) '_chipname))))
diff --git a/beautiful-racket/br/demo/hdl/parser.rkt b/beautiful-racket/br/demo/hdl/parser.rkt
index 9ddd06c..00b2c98 100644
--- a/beautiful-racket/br/demo/hdl/parser.rkt
+++ b/beautiful-racket/br/demo/hdl/parser.rkt
@@ -4,10 +4,14 @@ chip-program : "CHIP" ID "{" pin-spec pin-spec part-spec "}"
 
 pin-spec : ("IN" | "OUT") pin-list ";"
 
-pin-list : ID ["," ID]*
+pin-list : ID comma-id*
+
+comma-id : "," ID
 
 part-spec : "PARTS:" part-list
 
-part-list : [part]+
+part-list : part+
+
+part : ID "(" ID "=" ID comma-id-pair* ")" ";"
 
-part : ID "(" ID "=" ID ["," ID "=" ID]* ")" ";"
+comma-id-pair : "," ID "=" ID
\ No newline at end of file