From d9e8be7544ecd9891d2cd8ae96dd0f4c7ba93dfe Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 25 May 2016 16:20:51 -0700 Subject: [PATCH] rerefactoring --- beautiful-racket-lib/br/define.rkt | 10 +- beautiful-racket-lib/br/syntax.rkt | 1 + beautiful-racket/br/demo/basic/expander.rkt | 5 +- beautiful-racket/br/demo/basic/parser.rkt | 7 +- beautiful-racket/br/demo/basic/tokenizer.rkt | 3 +- beautiful-racket/br/demo/hdl-tst/expander.rkt | 6 +- beautiful-racket/br/demo/txtadv/expander.rkt | 98 +++++++++---------- beautiful-racket/br/demo/txtadv/parser.rkt | 11 +-- 8 files changed, 64 insertions(+), 77 deletions(-) diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index 7a28f90..da19ca2 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/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)) \ No newline at end of file + (check-equal? (add-3rd 5) 10) + (br:define-macro add-4th #'add-3rd) + (check-equal? (add-4th 5) 10)) \ No newline at end of file diff --git a/beautiful-racket-lib/br/syntax.rkt b/beautiful-racket-lib/br/syntax.rkt index 91c19e2..f6815f2 100644 --- a/beautiful-racket-lib/br/syntax.rkt +++ b/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)) diff --git a/beautiful-racket/br/demo/basic/expander.rkt b/beautiful-racket/br/demo/basic/expander.rkt index f758950..7b2cb7d 100644 --- a/beautiful-racket/br/demo/basic/expander.rkt +++ b/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)] diff --git a/beautiful-racket/br/demo/basic/parser.rkt b/beautiful-racket/br/demo/basic/parser.rkt index 152362a..00ef33d 100644 --- a/beautiful-racket/br/demo/basic/parser.rkt +++ b/beautiful-racket/br/demo/basic/parser.rkt @@ -1,11 +1,8 @@ #lang brag -;; recursive rules destucture easily in the expander -program : [CR]* [line [CR line]*] [CR]* +program : line* -line: NUMBER statement-list - -statement-list : statement [":" statement-list] +line: NUMBER statement [":" statement]* statement : "END" | "GOSUB" NUMBER diff --git a/beautiful-racket/br/demo/basic/tokenizer.rkt b/beautiful-racket/br/demo/basic/tokenizer.rkt index b758743..e239317 100644 --- a/beautiful-racket/br/demo/basic/tokenizer.rkt +++ b/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" diff --git a/beautiful-racket/br/demo/hdl-tst/expander.rkt b/beautiful-racket/br/demo/hdl-tst/expander.rkt index f6f9bbb..39f88f1 100644 --- a/beautiful-racket/br/demo/hdl-tst/expander.rkt +++ b/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 ...))] diff --git a/beautiful-racket/br/demo/txtadv/expander.rkt b/beautiful-racket/br/demo/txtadv/expander.rkt index a844056..97f8b88 100644 --- a/beautiful-racket/br/demo/txtadv/expander.rkt +++ b/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 - ((_name0 . _transitive0?) - (_name . _transitive?) ... _desc) ...) - (inject-syntax ([#'in-verbs (shared-syntax 'in-verbs)]) - #'(define-verbs in-verbs - [_name0 #,@(if (syntax->datum #'_transitive0?) #'(_) #'()) (= _name ...) _desc] ...))) +(define-macro-cases verb-section + [(_ ((NAME0 . TRANSITIVE0?) (NAME . _) ... DESC) ...) + (mark-as-shared-id + (in-verbs) + #'(define-verbs in-verbs + [(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) ...) ...) - #'(begin (define-thing _thingname [_actionname _actiondesc] ...) ...)) +(define-macro (things-section (THINGNAME (ACTIONNAME ACTIONDESC) ...) ...) + #'(begin (define-thing THINGNAME [ACTIONNAME ACTIONDESC] ...) ...)) (provide places-section) -(define #'(places-section (_place-id _place-desc [_place-item ...] [_actionname _actiondesc] ...) ...) - #'(begin (define-place _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] ...)) ...)) ;; 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) - (inject-syntax ([#'in-verbs (shared-syntax 'in-verbs)]) - #'(init-game _where - in-verbs - everywhere-actions))) +(define-macro (start-game-at WHERE) + #'(init-game WHERE + in-verbs + everywhere-actions)) (provide start-section) -(define #'(start-section _where) - (inject-syntax ([#'in-verbs (shared-syntax 'in-verbs)]) - #'(init-game _where - in-verbs - everywhere-actions))) +(define-macro (start-section WHERE) + #'(init-game WHERE + in-verbs + 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 ...) ... - (record-element! '_id _id) ... - (define _all-id (list _id ...)))) + (define-one-verb (ID . MAYBE-UNDERSCORE) SPEC ...) ... + (record-element! 'ID 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 - [#'(_ _id (= _alias ...) _desc) - #'(define _id (verb (list '_id '_alias ...) _desc #f))] - [#'(_ _id _ (= _alias ...) _desc) - #'(define _id (verb (list '_id '_alias ...) _desc #t))] - [#'(_ _id) - #'(define _id (verb (list '_id) (symbol->string '_id) #f))] - [#'(_ _id _) - #'(define _id (verb (list '_id) (symbol->string '_id) #t))]) - - -(define #'(define-thing _id [_vrb _expr] ...) +(define-macro (define-one-verb (ID . MAYBE-UNDERSCORE) . REST) + (with-pattern + ([TRANSITIVE? (equal? '("_") (syntax->datum #'MAYBE-UNDERSCORE))] + [VERB-ARGS (syntax-case #'REST () + [((= ALIAS ...) DESC) + #'((list 'ID 'ALIAS ...) DESC TRANSITIVE?)] + [else + #'((list 'ID) (symbol->string 'ID) TRANSITIVE?)])]) + #'(define ID (verb . VERB-ARGS)))) + + +(define-macro (define-thing ID [VERB-ARG EXPR] ...) #'(begin - (define _id - (thing '_id #f (list (cons _vrb (λ () _expr)) ...))) - (record-element! '_id _id))) + (define ID + (thing 'ID #f (list (cons VERB-ARG (λ () EXPR)) ...))) + (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 - (list _thng ...) - (list (cons _vrb (λ () _expr)) ...))) - (record-element! '_id _id))) + (define ID (place DESC + (list THING-ARG ...) + (list (cons VERB-ARG (λ () EXPR)) ...))) + (record-element! 'ID ID))) -(define #'(define-everywhere _id ([_vrb _expr] ...)) - #'(define _id (list (cons _vrb (λ () _expr)) ...))) +(define-macro (define-everywhere ID ([VERB-ARG EXPR] ...)) + #'(define ID (list (cons VERB-ARG (λ () EXPR)) ...))) ;; ============================================================ ;; Game state diff --git a/beautiful-racket/br/demo/txtadv/parser.rkt b/beautiful-racket/br/demo/txtadv/parser.rkt index 937d6e8..2e98fdc 100644 --- a/beautiful-racket/br/demo/txtadv/parser.rkt +++ b/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+