suzanne.soy/beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

rerefactoring

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-25 16:20:51 -07:00
parent fc826f9269
commit d9e8be7544
8 changed files with 62 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
beautiful-racket-lib/br/define.rkt
View File

@ -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))

1
beautiful-racket-lib/br/syntax.rkt
View File

@ -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))

5
beautiful-racket/br/demo/basic/expander.rkt
View File

@ -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)]

7
beautiful-racket/br/demo/basic/parser.rkt
View File

@ -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

3
beautiful-racket/br/demo/basic/tokenizer.rkt
View File

@ -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"

6
beautiful-racket/br/demo/hdl-tst/expander.rkt
View File

@ -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 ...))]

94
beautiful-racket/br/demo/txtadv/expander.rkt
View File

@ -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-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 #'(define-thing _id [_vrb _expr] ...)
(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

11
beautiful-racket/br/demo/txtadv/parser.rkt
View File

@ -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+