rerefactoring

beautiful-racket-lib/br/define.rkt

@@ -297,10 +297,12 @@
 
 (define-syntax (br:define-macro stx)
   (syntax-case stx (syntax)
+    [(_ id #'other-id) ; (define-macro id #'other-id)
+     #'(br:define #'id #'other-id)]
     [(_ (id . patargs) . body)
-     #'(br:define (syntax (id . patargs)) . body)]
+     #'(br:define #'(id . patargs) . body)]
     [(_ id [pat . patbody] ...)
-     #'(br:define-cases (syntax id) [pat . patbody] ...)]))
+     #'(br:define-cases #'id [pat . patbody] ...)]))
 
 (define-syntax (br:define-macro-cases stx)
   (syntax-case stx (syntax)
@@ -314,4 +316,6 @@
   (br:define-macro-cases add-again [(_ X) #'(+ X X)])
   (check-equal? (add-again 5) 10)
   (br:define-macro add-3rd [(_ X) #'(+ X X)])
-  (check-equal? (add-3rd 5) 10))
+  (check-equal? (add-3rd 5) 10)
+  (br:define-macro add-4th #'add-3rd)
+  (check-equal? (add-4th 5) 10))

beautiful-racket-lib/br/syntax.rkt

@@ -132,4 +132,5 @@
     . body))
 
 (define-syntax with-shared-id (make-rename-transformer #'introduce-id))
+(define-syntax mark-as-shared-id (make-rename-transformer #'introduce-id))
 

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

@@ -69,11 +69,8 @@
                   (current-return-stack (cons NUMBER (current-return-stack)))
                   (basic:GOTO WHERE)]
                  [else (current-return-stack (cdr (current-return-stack)))]))))]
-  [(_ NUMBER STATEMENT-LIST) #'(cons NUMBER (λ _ STATEMENT-LIST))])
+  [(_ NUMBER STATEMENT ...) #'(cons NUMBER (λ _ STATEMENT ...))])
 
-(define-macro statement-list
-  [(_ STATEMENT) #'(begin STATEMENT)]
-  [(_ STATEMENT ":" STATEMENT-LIST) #'(begin STATEMENT STATEMENT-LIST)])
 
 (define-macro statement
   [(statement ID "=" EXPR) #'(set! ID EXPR)]

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

@@ -1,11 +1,8 @@
 #lang brag
 
-;; recursive rules destucture easily in the expander
+program : line*
-program : [CR]* [line [CR line]*] [CR]*
 
-line: NUMBER statement-list
+line: NUMBER statement [":" statement]*
-
-statement-list : statement [":" statement-list]
 
 statement : "END"
 | "GOSUB" NUMBER

beautiful-racket/br/demo/basic/tokenizer.rkt

@@ -15,9 +15,8 @@
     (define get-token
       (lexer
        [(eof) eof]
-       [(union #\tab #\space
+       [(union #\tab #\space #\newline
                (seq number " REM" (repetition 1 +inf.0 (char-complement #\newline)) #\newline)) (get-token input-port)]
-       [(seq #\newline (repetition 0 +inf.0 whitespace)) (token 'CR "cr")]
        [(union "PRINT" "FOR" "TO" "STEP" "IF" "GOTO"
                "INPUT" "LET" "NEXT"  "RETURN"
                "CLEAR" "LIST" "RUN" "END"

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

@@ -49,7 +49,7 @@
 
 
 (define-macro (output-file-expr OUTPUT-FILE-STRING)
-  (with-shared-id
+  (mark-as-shared-id
    (output-file output-filename)
    #'(begin
        (define output-filename OUTPUT-FILE-STRING)
@@ -60,14 +60,14 @@
 
 
 (define-macro (compare-to-expr COMPARE-FILE-STRING)
-  (with-shared-id
+  (mark-as-shared-id
    (compare-files)
    #'(define (compare-files)
        (check-equal? (file->lines output-filename) (file->lines COMPARE-FILE-STRING)))))
 
 
 (define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...)
-  (with-shared-id
+  (mark-as-shared-id
    (eval-result eval-chip output)
    (with-pattern
     ([(COL-ID ...) (suffix-id #'(COL-NAME ...))]

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

@@ -21,7 +21,7 @@
 ;; ============================================================
 ;; Overall module:
 
-(define #'(module-begin _lines ...)
+(define-macro (module-begin _lines ...)
   #'(#%module-begin
      _lines ...
      
@@ -35,46 +35,44 @@
 ;; Process parse trees from the reader:
 
 (provide txtadv-program)
-(define #'txtadv-program #'module-begin)
+(define-macro txtadv-program #'module-begin)
 
 (provide verb-section)
-(define #'(verb-section
+(define-macro-cases verb-section
-           ((_name0 . _transitive0?)
+  [(_ ((NAME0 . TRANSITIVE0?) (NAME . _) ... DESC) ...)
-            (_name . _transitive?) ... _desc) ...)
+   (mark-as-shared-id
-  (inject-syntax ([#'in-verbs (shared-syntax 'in-verbs)])
+    (in-verbs)
-                 #'(define-verbs in-verbs
+    #'(define-verbs in-verbs
-                     [_name0 #,@(if (syntax->datum #'_transitive0?) #'(_) #'()) (= _name ...) _desc] ...)))
+        [(NAME0 . TRANSITIVE0?) (= NAME ...) DESC] ...))])
 
 (provide everywhere-section)
-(define #'(everywhere-section [_id _desc] ...)
+(define-macro (everywhere-section [ID DESC] ...)
   #'(define-everywhere everywhere-actions
-      ([_id _desc] ...)))
+      ([ID DESC] ...)))
 
 (provide things-section)
-(define #'(things-section (_thingname (_actionname _actiondesc) ...) ...)
+(define-macro (things-section (THINGNAME (ACTIONNAME ACTIONDESC) ...) ...)
-  #'(begin (define-thing _thingname [_actionname _actiondesc] ...) ...))
+  #'(begin (define-thing THINGNAME [ACTIONNAME ACTIONDESC] ...) ...))
 
 (provide places-section)
-(define #'(places-section (_place-id _place-desc [_place-item ...] [_actionname _actiondesc] ...) ...)
+(define-macro (places-section (PLACE-ID PLACE-DESC [PLACE-ITEM ...] [ACTIONNAME ACTIONDESC] ...) ...)
-  #'(begin (define-place _place-id _place-desc [_place-item ...] ([_actionname _actiondesc] ...)) ...))
+  #'(begin (define-place PLACE-ID PLACE-DESC [PLACE-ITEM ...] ([ACTIONNAME ACTIONDESC] ...)) ...))
 
 
 ;; todo: consolidate the game-starters.
 ;; `start-game-at` works with s-exp language,
 ;; `start-section` works with text lang. 
 (provide start-game-at)
-(define #'(start-game-at _where)
+(define-macro (start-game-at WHERE)
-  (inject-syntax ([#'in-verbs (shared-syntax 'in-verbs)])
+  #'(init-game WHERE
-                 #'(init-game _where
+               in-verbs
-                              in-verbs
+               everywhere-actions))
-                              everywhere-actions)))
 
 (provide start-section)
-(define #'(start-section _where)
+(define-macro (start-section WHERE)
-  (inject-syntax ([#'in-verbs (shared-syntax 'in-verbs)])
+  #'(init-game WHERE
-                 #'(init-game _where
+               in-verbs
-                              in-verbs
+               everywhere-actions))
-                              everywhere-actions)))
 
 ;; ============================================================
 ;; Model:
@@ -108,42 +106,42 @@
 ;; ============================================================
 ;; Macros for constructing and registering elements:
 
-(define #'(define-verbs _all-id [_id _spec ...] ...)
+(define-macro (define-verbs ALL-ID [(ID . MAYBE-UNDERSCORE) SPEC ...] ...)
   #'(begin
-      (define-one-verb _id _spec ...) ...
+      (define-one-verb (ID . MAYBE-UNDERSCORE) SPEC ...) ...
-      (record-element! '_id _id) ...
+      (record-element! 'ID ID) ...
-      (define _all-id (list _id ...))))
+      (define ALL-ID (list ID ...))))
 
 
 ;; todo: the underscore arguments in cases 2 & 4 should be literal underscores, not wildcards
-(define-cases #'define-one-verb
+(define-macro (define-one-verb (ID . MAYBE-UNDERSCORE) . REST)
-  [#'(_ _id (= _alias ...) _desc)
+  (with-pattern
-   #'(define _id (verb (list '_id '_alias ...) _desc #f))]
+   ([TRANSITIVE? (equal? '("_") (syntax->datum #'MAYBE-UNDERSCORE))]
-  [#'(_ _id _ (= _alias ...) _desc)
+    [VERB-ARGS (syntax-case #'REST ()
-   #'(define _id (verb (list '_id '_alias ...) _desc #t))]
+                 [((= ALIAS ...) DESC)
-  [#'(_ _id)
+                  #'((list 'ID 'ALIAS ...) DESC TRANSITIVE?)]
-   #'(define _id (verb (list '_id) (symbol->string '_id) #f))]
+                 [else
-  [#'(_ _id _)
+                  #'((list 'ID) (symbol->string 'ID) TRANSITIVE?)])])
-   #'(define _id (verb (list '_id) (symbol->string '_id) #t))])
+   #'(define ID (verb . VERB-ARGS))))
-
+
-
+
-(define #'(define-thing _id [_vrb _expr] ...)
+(define-macro (define-thing ID [VERB-ARG EXPR] ...)
   #'(begin
-      (define _id
+      (define ID
-        (thing '_id #f (list (cons _vrb (λ () _expr)) ...)))
+        (thing 'ID #f (list (cons VERB-ARG (λ () EXPR)) ...)))
-      (record-element! '_id _id)))
+      (record-element! 'ID ID)))
 
 
-(define #'(define-place _id _desc (_thng ...) ([_vrb _expr] ...))
+(define-macro (define-place ID DESC (THING-ARG ...) ([VERB-ARG EXPR] ...))
   #'(begin
-      (define _id (place _desc
+      (define ID (place DESC
-                         (list _thng ...)
+                        (list THING-ARG ...)
-                         (list (cons _vrb (λ () _expr)) ...)))
+                        (list (cons VERB-ARG (λ () EXPR)) ...)))
-      (record-element! '_id _id)))
+      (record-element! 'ID ID)))
 
 
-(define #'(define-everywhere _id ([_vrb _expr] ...))
+(define-macro (define-everywhere ID ([VERB-ARG EXPR] ...))
-  #'(define _id (list (cons _vrb (λ () _expr)) ...)))
+  #'(define ID (list (cons VERB-ARG (λ () EXPR)) ...)))
 
 ;; ============================================================
 ;; Game state

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

@@ -2,15 +2,6 @@
 
 txtadv-program : verb-section everywhere-section things-section places-section start-section
 
-;; hide on right side: remove element
-;; useful for: getting rid of literals
-;; splice on right side: lift element
-;; useful for: selective splicing
-;; hide on left side: remove name, leave container
-;; useful for: grouping args, avoiding "alternation" pattern
-;; splice on left side: lift everywhere
-;; useful for: flattening recursive structures
-
 verb-section : /"===VERBS===" verb-item+
 
 /verb-item :  verb-list s-exp
@@ -19,7 +10,7 @@ verb-section : /"===VERBS===" verb-item+
 
 /verb : ID ["_"]
 
-everywhere-section : /"===EVERYWHERE===" id-desc+
+everywhere-section : /"===EVERYWHERE===" id-desc*
 
 things-section : /"===THINGS===" thing-item+