diff --git a/beautiful-racket/br/demo/txtadv/expander.rkt b/beautiful-racket/br/demo/txtadv/expander.rkt index 2c64400..b07c10f 100644 --- a/beautiful-racket/br/demo/txtadv/expander.rkt +++ b/beautiful-racket/br/demo/txtadv/expander.rkt @@ -30,61 +30,30 @@ (parameterize ([cmd-line-mode? #t]) (do-place))))) + (provide txtadv-program) -(define #'(txtadv-program _section ...) - #'(module-begin _section ...)) +(define #'txtadv-program #'module-begin) (provide verb-section) -(define-inverting #'(verb-section _verb-item ...) +(define #'(verb-section + ((_name0 . _transitive0?) + (_name . _transitive?) ... _desc) ...) (inject-syntax ([#'in-verbs (shared-syntax 'in-verbs)]) #'(define-verbs in-verbs - _verb-item ...))) - - -(provide verb-item) -(define-inverting #'(verb-item (_name0 _transitive0?) (_name _transitive?) ... _desc) - #`[_name0 #,@(if (syntax->datum #'_transitive0?) #'(_) #'()) (= _name ...) _desc]) - -(provide verb-name) -(define-cases #'verb-name - [#'(_ _id) #'(_id #f)] - [#'(_ _id _underscore) #'(_id #t)]) + [_name0 #,@(if (syntax->datum #'_transitive0?) #'(_) #'()) (= _name ...) _desc] ...))) (provide everywhere-section) -(define-inverting #'(everywhere-section [_name _desc] ...) +(define #'(everywhere-section [_id _desc] ...) #'(define-everywhere everywhere-actions - ([_name _desc] ...))) - -(provide id-desc) -(define-inverting #'(id-desc _id _desc) - #'(_id _desc)) + ([_id _desc] ...))) (provide things-section) -(define-inverting #'(things-section _thing ...) - #'(begin _thing ...)) - -(provide thing-item) -(define-inverting #'(thing-item _thingname (_actionname _actiondesc) ...) - #'(define-thing _thingname [_actionname _actiondesc] ...)) +(define #'(things-section (_thingname (_actionname _actiondesc) ...) ...) + #'(begin (define-thing _thingname [_actionname _actiondesc] ...) ...)) (provide places-section) -(define-inverting #'(places-section _placeitem ...) - #'(begin _placeitem ...)) - -(provide place-item) -(define-inverting #'(place-item _place-id _place-desc [_place-item ...] [_actionname _actiondesc] ...) - #'(define-place _place-id _place-desc [_place-item ...] ([_actionname _actiondesc] ...))) - -(provide place-descrip) -(define #'(place-descrip _desc) #'_desc) - -(provide place-items) -(define-inverting #'(place-items _id ...) #'(_id ...)) - -(provide place-name) -(define-cases #'place-name - [#'(_ _id) #'_id]) - +(define #'(places-section (_place-id _place-desc [_place-item ...] [_actionname _actiondesc] ...) ...) + #'(begin (define-place _place-id _place-desc [_place-item ...] ([_actionname _actiondesc] ...)) ...)) (provide s-exp) (define-cases-inverting #'s-exp diff --git a/beautiful-racket/br/demo/txtadv/parser.rkt b/beautiful-racket/br/demo/txtadv/parser.rkt index 9a0798c..91c08f1 100644 --- a/beautiful-racket/br/demo/txtadv/parser.rkt +++ b/beautiful-racket/br/demo/txtadv/parser.rkt @@ -4,28 +4,24 @@ txtadv-program : verb-section everywhere-section things-section places-section s verb-section : <"===VERBS==="> verb-item+ -verb-item : verb-name+ s-exp + : verb-name+ s-exp -verb-name : [<",">] ID ["_"] + : [<",">] ID ["_"] everywhere-section : <"===EVERYWHERE==="> id-desc+ things-section : <"===THINGS==="> thing-item+ -thing-item : DASHED-NAME id-desc+ + : DASHED-NAME id-desc+ places-section : <"===PLACES==="> place-item+ -place-item : DASHED-NAME place-descrip place-items id-desc+ + : DASHED-NAME STRING place-items id-desc+ -place-descrip : STRING ; `place-desc` is already used in expander + : <"["> ([<",">] ID)* <"]"> -place-items : <"["> place-name* <"]"> ; `place-things` is already used +start-section : <"===START==="> ID -place-name : [<",">] ID - -start-section : <"===START==="> place-name - -id-desc : ID s-exp + : ID s-exp s-exp : ID | STRING | <"("> s-exp* <")"> \ No newline at end of file diff --git a/brag/brag/codegen/runtime.rkt b/brag/brag/codegen/runtime.rkt index 03235da..bfa28da 100755 --- a/brag/brag/codegen/runtime.rkt +++ b/brag/brag/codegen/runtime.rkt @@ -165,7 +165,9 @@ This would be the place to check a syntax property for hiding. (define (rule-components->syntax rule-name/false #:srcloc [srcloc #f] #:splice? [splice #f] . componentss) (let ([spliced-componentss (append-map (λ(cs) (if (and (pair? cs) (syntax-property (car cs) 'splice)) - (list (cdr (syntax->list (car cs)))) ; pop off the rule name and splice its components into this rule + (list (list (syntax-case (car cs) () + [(rule-name c ...) + #'(c ...)]))) (list cs))) componentss)]) (syntax-property (datum->syntax #f diff --git a/brag/brag/test/test-baby-json-hider.rkt b/brag/brag/test/test-baby-json-hider.rkt index 81af1a1..fb64dd6 100755 --- a/brag/brag/test/test-baby-json-hider.rkt +++ b/brag/brag/test/test-baby-json-hider.rkt @@ -10,7 +10,7 @@ ":" (token 'STRING "'hello world'") "}"))) - '(json (object ":"))) + '(json (object (":")))) (check-equal?