refine inversion

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

@@ -1,45 +1,12 @@
 #lang br
-(provide #%top-interaction #%module-begin (all-defined-out))
+(provide #%top-interaction #%module-begin #%app #%datum (all-defined-out))
 
-(define #'(chip-program "CHIP" _arg ...)
-  #'(chip _arg ...))
-
-(define #'(pin-spec _label _pin-list ";")
-  #'_pin-list)
-
-(define-inverting #'(pin-list _id _another-id ...)
-  #'(_id _another-id ...))
-
-(define #'(another-id "," _id)
-  #'_id)
-
-(define #'(part-spec "PARTS:" _part-list)
-  #'_part-list)
-
-(define #'(part-list _part ...)
-  #'(begin _part ...))
-
-(define-inverting #'(part _partname "(" _firstpin "=" _firstval _another-id-pair ... (_lastpin _pinout) ")" ";")
-  #'(begin
-      (define _pinout (call-part _partname [_firstpin _firstval] _another-id-pair ...))))
-
-(define #'(another-id-pair "," _firstid "=" _secondid)
-  #'(_firstid _secondid))
-
-(define #'(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))))
-
-(define-inverting #'(chip _chipname "{"
-                          (_input-pin ...)
-                          (_output-pin ...)
-                          _part-spec "}")
+(define-inverting #'(chip-program "CHIP" _chipname "{"
+                                  (_input-pin ...)
+                                  (_output-pin ...)
+                                  _part-spec "}")
   #'(begin
-      (provide _chipname)
-      (define _chipname
+      (define+provide _chipname
         (procedure-rename
          (make-keyword-procedure
           (λ (kws kw-args . rest)
@@ -47,3 +14,27 @@
             (let ([_input-pin (cdr (assq (string->keyword (format "~a" '_input-pin)) kw-pairs))] ...)
               _part-spec
               (values _output-pin ...)))) '_chipname))))
+
+(define-inverting #'(pin-spec _label _pin ... ";")
+  #'(_pin ...))
+
+(define-cases #'pin
+  [#'(_ _pin ",") #'_pin]
+  [#'(_ _pin) #'_pin])
+
+(define #'(part-spec "PARTS:" _part ...)
+  #'(begin _part ...))
+
+(define-inverting #'(part _partname "(" (_pin _val) ... (_lastpin _pinout) ")" ";")
+  #'(define _pinout (call-part _partname [_pin _val] ...)))
+
+(define-cases #'pin-val-pair
+  [#'(_ _pin "=" _val ",") #'(_pin _val)]
+  [#'(_ _pin "=" _val) #'(_pin _val)])
+
+(define #'(call-part _partname [_pin _val] ...)
+  (inject-syntax ([#'part-path (format "~a.hdl" (syntax->datum #'_partname))]
+                  [#'(kw ...) (map (λ(pi) (string->keyword (format "~a" (syntax->datum pi)))) (syntax->list #'(_pin ...)))])
+                 #'(let ()
+                     (local-require (rename-in part-path [_partname local-name]))
+                     (keyword-apply local-name '(kw ...) (list _val ...) null))))

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

@@ -1,17 +1,21 @@
 #lang ragg
 
-chip-program : "CHIP" ID "{" pin-spec pin-spec part-spec "}"
-
-pin-spec : ("IN" | "OUT") pin-list ";"
+;; rule of thumb: use [optional] bits judiciously as they multiply the cases needed for a production rule
+;; rule of thumb: for a set of related IDs, put each into the same grammar entity
+;; rule of thumb: avoid mushing unrelated IDs into one grammar entity
+;; whereas a * corresponds directly to an ... in the expander macro
+;; syntax patterns are good for
+;; + single case / nonrecursive structure
+;; + nonalternating pattern (no "this that this that ...")
 
-pin-list : ID another-id*
+chip-program : "CHIP" ID "{" pin-spec pin-spec part-spec "}"
 
-another-id : "," ID
+pin-spec : ("IN" | "OUT") pin+ ";"
 
-part-spec : "PARTS:" part-list
+pin : ID [","]
 
-part-list : part+
+part-spec : "PARTS:" part+
 
-part : ID "(" ID "=" ID another-id-pair* ")" ";"
+part : ID "(" pin-val-pair+ ")" ";"
 
-another-id-pair : "," ID "=" ID
+pin-val-pair : ID "=" ID [","]