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-item> : verb-name+ s-exp
-verb-name : [","] ID ["_"]
+<verb-name> : [<",">] 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+
+<thing-item> : DASHED-NAME id-desc+
-places-section : "===PLACES===" place-item+
+places-section : <"===PLACES==="> place-item+
-place-item : DASHED-NAME place-descrip place-items id-desc+
+<place-item> : DASHED-NAME STRING place-items id-desc+
-place-descrip : STRING ; `place-desc` is already used in expander
+<place-items> : <"["> ([<",">] ID)* <"]">
-place-items : "[" place-name* "]" ; `place-things` is already used
+start-section : <"===START==="> ID
-place-name : [","] ID
+<id-desc> : 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: <ID> <":"> json
+<kvpair>: <ID> ":" <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