From c98580570333bc8e2d0ba820012a8e5e8c99d60c Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Tue, 10 May 2016 11:29:31 -0700 Subject: [PATCH] add @ prefix for splicing --- brag/brag/codegen/codegen.rkt | 4 ++-- brag/brag/codegen/runtime.rkt | 18 ++++++++++-------- brag/brag/examples/baby-json-hider.rkt | 2 +- brag/brag/rules/lexer.rkt | 2 ++ brag/brag/rules/parser.rkt | 21 +++++++++++++++++++-- brag/brag/rules/stx.rkt | 2 +- brag/brag/test/test-baby-json-hider.rkt | 2 +- 7 files changed, 36 insertions(+), 15 deletions(-) diff --git a/brag/brag/codegen/codegen.rkt b/brag/brag/codegen/codegen.rkt index 214d014..95e4057 100755 --- a/brag/brag/codegen/codegen.rkt +++ b/brag/brag/codegen/codegen.rkt @@ -230,13 +230,13 @@ [$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 + ;; move 'hide-or-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 - #:splice? #,(syntax-property rule-name/false 'splice))])) + #:hide-or-splice? #,(syntax-property rule-name/false 'hide-or-splice))])) diff --git a/brag/brag/codegen/runtime.rkt b/brag/brag/codegen/runtime.rkt index bfa28da..0b9f13d 100755 --- a/brag/brag/codegen/runtime.rkt +++ b/brag/brag/codegen/runtime.rkt @@ -158,17 +158,19 @@ This would be the place to check a syntax property for hiding. (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] #:splice? [splice #f] . componentss) +(define (rule-components->syntax rule-name/false #:srcloc [srcloc #f] #:hide-or-splice? [hide-or-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)]) + (cond + [(and (pair? cs) (equal? (syntax-property (car cs) 'hide-or-splice) "hide")) + (list (list (syntax-case (car cs) () + [(rule-name c ...) + #'(c ...)])))] + [(and (pair? cs) (equal? (syntax-property (car cs) 'hide-or-splice) "splice")) + (list (cdr (syntax->list (car cs))))] + [else (list cs)])) componentss)]) (syntax-property (datum->syntax #f (cons @@ -176,4 +178,4 @@ This would be the place to check a syntax property for hiding. (apply append spliced-componentss)) srcloc stx-with-original?-property) - 'splice splice))) \ No newline at end of file + 'hide-or-splice hide-or-splice))) \ No newline at end of file diff --git a/brag/brag/examples/baby-json-hider.rkt b/brag/brag/examples/baby-json-hider.rkt index 12f2f22..676e5f9 100755 --- a/brag/brag/examples/baby-json-hider.rkt +++ b/brag/brag/examples/baby-json-hider.rkt @@ -13,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 5068b70..0667a5f 100755 --- a/brag/brag/rules/lexer.rkt +++ b/brag/brag/rules/lexer.rkt @@ -63,6 +63,8 @@ (token-RULE_HEAD lexeme)] [(:: "!" id (:* whitespace) ":") (token-RULE_HEAD_HIDDEN lexeme)] + [(:: "@" id (:* whitespace) ":") + (token-RULE_HEAD_SPLICED lexeme)] [id (token-ID lexeme)] diff --git a/brag/brag/rules/parser.rkt b/brag/brag/rules/parser.rkt index d277516..f8c3d59 100755 --- a/brag/brag/rules/parser.rkt +++ b/brag/brag/rules/parser.rkt @@ -18,6 +18,7 @@ token-REPEAT token-RULE_HEAD token-RULE_HEAD_HIDDEN + token-RULE_HEAD_SPLICED token-ID token-LIT token-EOF @@ -47,6 +48,7 @@ REPEAT RULE_HEAD RULE_HEAD_HIDDEN + RULE_HEAD_SPLICED ID LIT EOF)) @@ -88,7 +90,7 @@ #f) $2))] - ;; bang indicates hiding. set hide value to #t + ;; bang indicates hiding. set hide value to "hide" [(RULE_HEAD_HIDDEN pattern) (begin (define trimmed (cadr (regexp-match #px"!(\\S+)\\s*:$" $1))) @@ -100,7 +102,22 @@ (position-line $1-start-pos) (position-col $1-start-pos)) trimmed - #t) + "hide") ; symbols won't work for these signals + $2))] + + ;; atsign indicates splicing. set hide value to "splice" + [(RULE_HEAD_SPLICED pattern) + (begin + (define trimmed (cadr (regexp-match #px"@(\\S+)\\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 + "splice") $2))]] [pattern diff --git a/brag/brag/rules/stx.rkt b/brag/brag/rules/stx.rkt index c481911..cc87e57 100755 --- a/brag/brag/rules/stx.rkt +++ b/brag/brag/rules/stx.rkt @@ -33,7 +33,7 @@ (- (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)))) + 'hide-or-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-baby-json-hider.rkt b/brag/brag/test/test-baby-json-hider.rkt index fb64dd6..81af1a1 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?