From f6181b90d72250cca79353bc406a3b53a1feb9d2 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 6 May 2016 13:22:38 -0700 Subject: [PATCH] lhs-id splicing works ; tests pass --- brag/brag/codegen/codegen.rkt | 8 +++++--- brag/brag/codegen/runtime.rkt | 22 ++++++++++++++-------- brag/brag/elider/json-elider.rkt | 2 +- brag/brag/elider/test-json-elider.rkt | 4 ++-- brag/brag/rules/stx.rkt | 24 +++++++++++++----------- 5 files changed, 35 insertions(+), 25 deletions(-) diff --git a/brag/brag/codegen/codegen.rkt b/brag/brag/codegen/codegen.rkt index c459fe1..f8ec6dc 100755 --- a/brag/brag/codegen/codegen.rkt +++ b/brag/brag/codegen/codegen.rkt @@ -42,7 +42,7 @@ #| MB: `rules` still carries 'hide syntax property |# - #;(report flattened-rules) + #;(report rules) #| @@ -54,7 +54,7 @@ (define generated-rule-codes (map flat-rule->yacc-rule flattened-rules)) #| - MB: `generated-rule-codes` loses the 'hide syntax property + MB: `generated-rule-codes` loses the 'hide syntax property (but not for lhs-ids) |# #;(report generated-rule-codes) @@ -179,6 +179,7 @@ ;; stx :== (name (U tokens rule-stx) ...) ;; (define (flat-rule->yacc-rule a-flat-rule) + ;; lhs-ids still carry 'hide property on #'name field #;(report a-flat-rule) (syntax-case a-flat-rule () [(rule-type origin name clauses ...) @@ -251,7 +252,8 @@ [(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 'hide))])) diff --git a/brag/brag/codegen/runtime.rkt b/brag/brag/codegen/runtime.rkt index 03eed87..ebb8902 100755 --- a/brag/brag/codegen/runtime.rkt +++ b/brag/brag/codegen/runtime.rkt @@ -158,14 +158,20 @@ 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] . components) - (datum->syntax #f - (cons - (datum->syntax #f rule-name/false srcloc stx-with-original?-property) - (apply append components)) - srcloc - stx-with-original?-property)) \ No newline at end of file +(define (rule-components->syntax rule-name/false #:srcloc [srcloc #f] #:splice? [splice #f] . componentss) + (let ([componentss (append-map (λ(cs) + (if (and (pair? cs) (syntax-property (car cs) 'splice)) + (list (cdr (syntax->list (car cs)))) + (list cs))) componentss)]) + (syntax-property + (datum->syntax #f + (cons + (datum->syntax #f rule-name/false srcloc stx-with-original?-property) + (apply append componentss)) + srcloc + stx-with-original?-property) + 'splice splice))) \ No newline at end of file diff --git a/brag/brag/elider/json-elider.rkt b/brag/brag/elider/json-elider.rkt index cdebc9e..677a02d 100755 --- a/brag/brag/elider/json-elider.rkt +++ b/brag/brag/elider/json-elider.rkt @@ -14,4 +14,4 @@ array: "[" [json ("," json)*] "]" object: <"{"> [kvpair ("," kvpair)*] <"}"> -kvpair: ":" + : ":" diff --git a/brag/brag/elider/test-json-elider.rkt b/brag/brag/elider/test-json-elider.rkt index 89287ed..c7e48d0 100755 --- a/brag/brag/elider/test-json-elider.rkt +++ b/brag/brag/elider/test-json-elider.rkt @@ -10,10 +10,10 @@ ":" (token 'STRING "'hello world'") "}"))) - '(json (object (kvpair "message" (json (string "'hello world'")))))) + '(json (object ":"))) -#;(check-equal? +(check-equal? (syntax->datum (parse "[[[{}]],[],[[{}]]]")) '(json (array #\[ (json (array #\[ (json (array #\[ (json (object)) #\])) #\])) #\, (json (array #\[ #\])) #\, (json (array #\[ (json (array #\[ (json (object )) #\])) #\])) #\]))) diff --git a/brag/brag/rules/stx.rkt b/brag/brag/rules/stx.rkt index 0317fcf..80197b5 100755 --- a/brag/brag/rules/stx.rkt +++ b/brag/brag/rules/stx.rkt @@ -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))) + 'hide (lhs-id-hide (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)))