diff --git a/beautiful-racket/br/demo/txtadv/expander.rkt b/beautiful-racket/br/demo/txtadv/expander.rkt index af11bf1..6c714ab 100644 --- a/beautiful-racket/br/demo/txtadv/expander.rkt +++ b/beautiful-racket/br/demo/txtadv/expander.rkt @@ -30,70 +30,38 @@ (parameterize ([cmd-line-mode? #t]) (do-place))))) + +;; ============================================================== +;; Process parse trees from the reader: + (provide txtadv-program) -(define #'(txtadv-program _section ...) - #'(module-begin _section ...)) +(define #'txtadv-program #'module-begin) (provide verb-section) -(define-inverting #'(verb-section _heading _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 - ;; cases with literals go first, so they're not caught by wildcards - [#'(_ "," _id) #'(_id #f)] - [#'(_ "," _id _underscore) #'(_id #t)] - [#'(_ _id) #'(_id #f)] - [#'(_ _id _underscore) #'(_id #t)]) + [_name0 #,@(if (syntax->datum #'_transitive0?) #'(_) #'()) (= _name ...) _desc] ...))) (provide everywhere-section) -(define-inverting #'(everywhere-section _heading [_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 _heading _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 _heading _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] - [#'(_ _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 - [#'(_ "(" _sx ... ")") #'(_sx ...)] - [#'(_ _sx) #'_sx]) + [#'(_ _sx) #'_sx] + [#'(_ _sx ... ) #'(_sx ...)]) ;; todo: consolidate the game-starters. @@ -107,7 +75,7 @@ everywhere-actions))) (provide start-section) -(define #'(start-section _heading _where) +(define #'(start-section _where) (inject-syntax ([#'in-verbs (shared-syntax 'in-verbs)]) #'(init-game _where in-verbs diff --git a/beautiful-racket/br/demo/txtadv/parser.rkt b/beautiful-racket/br/demo/txtadv/parser.rkt index afa8e0f..91c08f1 100644 --- a/beautiful-racket/br/demo/txtadv/parser.rkt +++ b/beautiful-racket/br/demo/txtadv/parser.rkt @@ -2,30 +2,26 @@ txtadv-program : verb-section everywhere-section things-section places-section start-section -verb-section : "===VERBS===" verb-item+ +verb-section : <"===VERBS==="> verb-item+ -verb-item : verb-name+ s-exp + : verb-name+ s-exp -verb-name : [","] ID ["_"] + : [<",">] ID ["_"] -everywhere-section : "===EVERYWHERE===" id-desc+ +everywhere-section : <"===EVERYWHERE==="> id-desc+ -things-section : "===THINGS===" thing-item+ +things-section : <"===THINGS==="> thing-item+ -thing-item : DASHED-NAME id-desc+ + : DASHED-NAME id-desc+ -places-section : "===PLACES===" place-item+ +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 + : ID s-exp -start-section : "===START===" place-name - -id-desc : ID s-exp - -s-exp : ID | STRING | "(" s-exp* ")" \ No newline at end of file +s-exp : ID | STRING | <"("> s-exp* <")"> \ No newline at end of file diff --git a/brag/brag/codegen/codegen.rkt b/brag/brag/codegen/codegen.rkt index aeb5ec8..214d014 100755 --- a/brag/brag/codegen/codegen.rkt +++ b/brag/brag/codegen/codegen.rkt @@ -1,4 +1,4 @@ -#lang br +#lang racket/base (require (for-template racket/base) racket/list @@ -38,25 +38,9 @@ ;; We flatten the rules so we can use the yacc-style ruleset that parser-tools ;; supports. - - #| - MB: `rules` still carries 'hide syntax property - |# - #;(report flattened-rules) - - - #| - MB: `flattened-rules` still carries 'hide syntax property - |# (define flattened-rules (flatten-rules rules)) - #;(report flattened-rules) (define generated-rule-codes (map flat-rule->yacc-rule flattened-rules)) - - #| - MB: `generated-rule-codes` loses the 'hide syntax property - |# - #;(report generated-rule-codes) ;; The first rule, by default, is the start rule. (define rule-ids (for/list ([a-rule (in-list rules)]) @@ -179,7 +163,6 @@ ;; stx :== (name (U tokens rule-stx) ...) ;; (define (flat-rule->yacc-rule a-flat-rule) - #;(report a-flat-rule) (syntax-case a-flat-rule () [(rule-type origin name clauses ...) (begin @@ -216,29 +199,29 @@ (for/list ([translated-pattern (in-list translated-patterns)] [primitive-pattern (syntax->list a-clause)] [pos (in-naturals 1)]) - (with-syntax ([$X - (format-id translated-pattern "$~a" pos)] - [$X-start-pos - (format-id translated-pattern "$~a-start-pos" pos)] - [$X-end-pos - (format-id translated-pattern "$~a-end-pos" pos)]) - (syntax-case primitive-pattern (id lit token inferred-id) - - ;; When a rule usage is inferred, the value of $X is a syntax object - ;; whose head is the name of the inferred rule . We strip that out, - ;; leaving the residue to be absorbed. - [(inferred-id val reason) - #'(syntax-case $X () - [(inferred-rule-name . rest) - (syntax->list #'rest)])] - [(id val) - #'(list $X)] - ;; move the 'hide syntax property into the translated-action - ;; because syntax gets datum-ized - [(lit val) - #`(list (atomic-datum->syntax $X $X-start-pos $X-end-pos #,(syntax-property primitive-pattern 'hide)))] - [(token val) - #`(list (atomic-datum->syntax $X $X-start-pos $X-end-pos #,(syntax-property primitive-pattern 'hide)))])))) + (if (syntax-property primitive-pattern 'hide) + #'null + (with-syntax ([$X + (format-id translated-pattern "$~a" pos)] + [$X-start-pos + (format-id translated-pattern "$~a-start-pos" pos)] + [$X-end-pos + (format-id translated-pattern "$~a-end-pos" pos)]) + (syntax-case primitive-pattern (id lit token inferred-id) + + ;; When a rule usage is inferred, the value of $X is a syntax object + ;; whose head is the name of the inferred rule . We strip that out, + ;; leaving the residue to be absorbed. + [(inferred-id val reason) + #'(syntax-case $X () + [(inferred-rule-name . rest) + (syntax->list #'rest)])] + [(id val) + #'(list $X)] + [(lit val) + #'(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))] + [(token val) + #'(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))]))))) (define whole-rule-loc (if (empty? translated-patterns) @@ -246,12 +229,14 @@ (with-syntax ([$1-start-pos (datum->syntax (first translated-patterns) '$1-start-pos)] [$n-end-pos (format-id (last translated-patterns) "$~a-end-pos" (length translated-patterns))]) #`(positions->srcloc $1-start-pos $n-end-pos)))) - + + ;; move 'splice property into function because name is datum-ized (with-syntax ([(translated-pattern ...) translated-patterns] [(translated-action ...) translated-actions]) #`[(translated-pattern ...) (rule-components->syntax '#,rule-name/false translated-action ... - #:srcloc #,whole-rule-loc)])) + #:srcloc #,whole-rule-loc + #:splice? #,(syntax-property rule-name/false 'splice))])) diff --git a/brag/brag/codegen/flatten.rkt b/brag/brag/codegen/flatten.rkt index a6a9fb6..e1d9baf 100755 --- a/brag/brag/codegen/flatten.rkt +++ b/brag/brag/codegen/flatten.rkt @@ -1,4 +1,4 @@ -#lang br +#lang racket/base (require brag/rules/stx-types (for-syntax racket/base)) diff --git a/brag/brag/codegen/runtime.rkt b/brag/brag/codegen/runtime.rkt index eb220da..bfa28da 100755 --- a/brag/brag/codegen/runtime.rkt +++ b/brag/brag/codegen/runtime.rkt @@ -1,4 +1,4 @@ -#lang br +#lang racket/base (require racket/match racket/list @@ -150,26 +150,30 @@ This would be the place to check a syntax property for hiding. (define stx-with-original?-property (read-syntax #f (open-input-string "meaningless-string"))) -(define elided (gensym)) ;; atomic-datum->syntax: datum position position ;; Helper that does the ugly work in wrapping a datum into a syntax ;; with source location. -(define (atomic-datum->syntax d start-pos end-pos [hide? #f]) - (if hide? - elided - (datum->syntax #f d (positions->srcloc start-pos end-pos) stx-with-original?-property))) - +(define (atomic-datum->syntax d start-pos end-pos) + (datum->syntax #f d (positions->srcloc start-pos end-pos) stx-with-original?-property)) +(define splice-signal '@) ;; rule-components->syntax: (U symbol false) (listof stx) ... #:srcloc (U #f (list src line column offset span)) -> stx ;; Creates an stx out of the rule name and its components. ;; The location information of the rule spans that of its components. -(define (rule-components->syntax rule-name/false #:srcloc [srcloc #f] . components) - (define flattened-elided-components (filter-not (λ(c) (eq? c elided)) (apply append components))) - (datum->syntax #f - (cons - (datum->syntax #f rule-name/false srcloc stx-with-original?-property) - flattened-elided-components) - srcloc - stx-with-original?-property)) +(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 (list (syntax-case (car cs) () + [(rule-name c ...) + #'(c ...)]))) + (list cs))) componentss)]) + (syntax-property + (datum->syntax #f + (cons + (datum->syntax #f rule-name/false srcloc stx-with-original?-property) + (apply append spliced-componentss)) + srcloc + stx-with-original?-property) + 'splice splice))) \ No newline at end of file diff --git a/brag/brag/elider/json-elider-toy.rkt b/brag/brag/elider/json-elider-toy.rkt deleted file mode 100644 index 3d55a38..0000000 --- a/brag/brag/elider/json-elider-toy.rkt +++ /dev/null @@ -1,4 +0,0 @@ -#lang brag - -;; Simple baby example of JSON structure -json: ID <":"> ID diff --git a/brag/brag/elider/json-elider.rkt b/brag/brag/examples/baby-json-hider.rkt similarity index 79% rename from brag/brag/elider/json-elider.rkt rename to brag/brag/examples/baby-json-hider.rkt index 224acd4..eb2097f 100755 --- a/brag/brag/elider/json-elider.rkt +++ b/brag/brag/examples/baby-json-hider.rkt @@ -1,8 +1,7 @@ #lang brag ;; Simple baby example of JSON structure -json: number - | string +json: number | string | array | object @@ -14,4 +13,4 @@ array: "[" [json ("," json)*] "]" object: <"{"> [kvpair ("," kvpair)*] <"}"> -kvpair: <":"> json +: ":" diff --git a/brag/brag/rules/lexer.rkt b/brag/brag/rules/lexer.rkt index 877f563..32a205f 100755 --- a/brag/brag/rules/lexer.rkt +++ b/brag/brag/rules/lexer.rkt @@ -22,9 +22,6 @@ (:+ id-char))) - - - (define lex/1 (lexer-src-pos [(:: "'" @@ -64,6 +61,8 @@ (token-EOF lexeme)] [(:: id (:* whitespace) ":") (token-RULE_HEAD lexeme)] + [(:: "<" id ">" (:* whitespace) ":") + (token-RULE_HEAD_HIDDEN lexeme)] [id (token-ID lexeme)] diff --git a/brag/brag/rules/parser.rkt b/brag/brag/rules/parser.rkt index a9dc02d..d348980 100755 --- a/brag/brag/rules/parser.rkt +++ b/brag/brag/rules/parser.rkt @@ -1,4 +1,4 @@ -#lang br +#lang racket/base (require parser-tools/yacc parser-tools/lex racket/list @@ -17,6 +17,7 @@ token-PIPE token-REPEAT token-RULE_HEAD + token-RULE_HEAD_HIDDEN token-ID token-LIT token-EOF @@ -45,6 +46,7 @@ PIPE REPEAT RULE_HEAD + RULE_HEAD_HIDDEN ID LIT EOF)) @@ -84,6 +86,21 @@ (position-col $1-start-pos)) trimmed #f) + $2))] + + ;; angles indicate splicing. set splice value to #t + [(RULE_HEAD_HIDDEN pattern) + (begin + (define trimmed (cadr (regexp-match #px"<(.+)>\\s*:$" $1))) + (rule (position->pos $1-start-pos) + (position->pos $2-end-pos) + (lhs-id (position->pos $1-start-pos) + (pos (+ (position-offset $1-start-pos) + (string-length trimmed)) + (position-line $1-start-pos) + (position-col $1-start-pos)) + trimmed + #t) $2))]] [pattern diff --git a/brag/brag/rules/rule-structs.rkt b/brag/brag/rules/rule-structs.rkt index b4d64af..33a2e8d 100755 --- a/brag/brag/rules/rule-structs.rkt +++ b/brag/brag/rules/rule-structs.rkt @@ -12,7 +12,7 @@ (struct rule (start end lhs pattern) #:transparent) -(struct lhs-id (start end val hide) +(struct lhs-id (start end val splice) #:transparent) diff --git a/brag/brag/rules/stx.rkt b/brag/brag/rules/stx.rkt index 0317fcf..c481911 100755 --- a/brag/brag/rules/stx.rkt +++ b/brag/brag/rules/stx.rkt @@ -1,4 +1,4 @@ -#lang br +#lang racket/base (require "rule-structs.rkt" parser-tools/lex @@ -21,17 +21,19 @@ (define (rule->stx source a-rule) (define id-stx - (datum->syntax #f - (string->symbol (lhs-id-val (rule-lhs a-rule))) - (list source - (pos-line (lhs-id-start (rule-lhs a-rule))) - (pos-col (lhs-id-start (rule-lhs a-rule))) - (pos-offset (lhs-id-start (rule-lhs a-rule))) - (if (and (number? (pos-offset (lhs-id-start (rule-lhs a-rule)))) - (number? (pos-offset (lhs-id-end (rule-lhs a-rule))))) - (- (pos-offset (lhs-id-end (rule-lhs a-rule))) - (pos-offset (lhs-id-start (rule-lhs a-rule)))) - #f)))) + (syntax-property + (datum->syntax #f + (string->symbol (lhs-id-val (rule-lhs a-rule))) + (list source + (pos-line (lhs-id-start (rule-lhs a-rule))) + (pos-col (lhs-id-start (rule-lhs a-rule))) + (pos-offset (lhs-id-start (rule-lhs a-rule))) + (if (and (number? (pos-offset (lhs-id-start (rule-lhs a-rule)))) + (number? (pos-offset (lhs-id-end (rule-lhs a-rule))))) + (- (pos-offset (lhs-id-end (rule-lhs a-rule))) + (pos-offset (lhs-id-start (rule-lhs a-rule)))) + #f))) + 'splice (lhs-id-splice (rule-lhs a-rule)))) (define pattern-stx (pattern->stx source (rule-pattern a-rule))) (define line (pos-line (rule-start a-rule))) (define column (pos-col (rule-start a-rule))) diff --git a/brag/brag/test/test-all.rkt b/brag/brag/test/test-all.rkt index 8917aec..f23fabe 100755 --- a/brag/brag/test/test-all.rkt +++ b/brag/brag/test/test-all.rkt @@ -1,4 +1,4 @@ -#lang br +#lang racket/base (require "test-0n1.rkt" diff --git a/brag/brag/elider/test-json-elider.rkt b/brag/brag/test/test-baby-json-hider.rkt similarity index 83% rename from brag/brag/elider/test-json-elider.rkt rename to brag/brag/test/test-baby-json-hider.rkt index bbb7e4d..fb64dd6 100755 --- a/brag/brag/elider/test-json-elider.rkt +++ b/brag/brag/test/test-baby-json-hider.rkt @@ -1,5 +1,5 @@ -#lang br -(require "json-elider.rkt" +#lang racket/base +(require brag/examples/baby-json-hider brag/support rackunit) @@ -10,7 +10,7 @@ ":" (token 'STRING "'hello world'") "}"))) - '(json (object (kvpair (json (string "'hello world'")))))) + '(json (object (":")))) (check-equal? diff --git a/brag/brag/test/test-parser.rkt b/brag/brag/test/test-parser.rkt index 94adba1..22fcd98 100755 --- a/brag/brag/test/test-parser.rkt +++ b/brag/brag/test/test-parser.rkt @@ -1,4 +1,4 @@ -#lang br +#lang racket/base (require rackunit