From 2026c603de63cb04bcc8449d484b6457956b9910 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 6 May 2016 12:36:25 -0700 Subject: [PATCH] make ids hideable --- brag/brag/codegen/codegen.rkt | 52 +++++++++++------------ brag/brag/codegen/runtime.rkt | 14 +++--- brag/brag/elider/json-elider-toy.rkt | 4 +- brag/brag/elider/json-elider.rkt | 2 +- brag/brag/elider/test-json-elider-toy.rkt | 9 ++++ brag/brag/elider/test-json-elider.rkt | 4 +- 6 files changed, 45 insertions(+), 40 deletions(-) create mode 100644 brag/brag/elider/test-json-elider-toy.rkt diff --git a/brag/brag/codegen/codegen.rkt b/brag/brag/codegen/codegen.rkt index 2b91fd3..c459fe1 100755 --- a/brag/brag/codegen/codegen.rkt +++ b/brag/brag/codegen/codegen.rkt @@ -43,8 +43,8 @@ MB: `rules` still carries 'hide syntax property |# #;(report flattened-rules) - - + + #| MB: `flattened-rules` still carries 'hide syntax property |# @@ -52,7 +52,7 @@ #;(report flattened-rules) (define generated-rule-codes (map flat-rule->yacc-rule flattened-rules)) - + #| MB: `generated-rule-codes` loses the 'hide syntax property |# @@ -216,29 +216,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) diff --git a/brag/brag/codegen/runtime.rkt b/brag/brag/codegen/runtime.rkt index eb220da..03eed87 100755 --- a/brag/brag/codegen/runtime.rkt +++ b/brag/brag/codegen/runtime.rkt @@ -150,15 +150,12 @@ 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)) @@ -166,10 +163,9 @@ This would be the place to check a syntax property for hiding. ;; 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) + (datum->syntax #f rule-name/false srcloc stx-with-original?-property) + (apply append components)) srcloc - stx-with-original?-property)) + stx-with-original?-property)) \ No newline at end of file diff --git a/brag/brag/elider/json-elider-toy.rkt b/brag/brag/elider/json-elider-toy.rkt index 3d55a38..8eed9e8 100644 --- a/brag/brag/elider/json-elider-toy.rkt +++ b/brag/brag/elider/json-elider-toy.rkt @@ -1,4 +1,4 @@ #lang brag -;; Simple baby example of JSON structure -json: ID <":"> ID +thing : foo +foo : <"bar"> diff --git a/brag/brag/elider/json-elider.rkt b/brag/brag/elider/json-elider.rkt index 224acd4..cdebc9e 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: <":"> json +kvpair: ":" diff --git a/brag/brag/elider/test-json-elider-toy.rkt b/brag/brag/elider/test-json-elider-toy.rkt new file mode 100644 index 0000000..c3072c3 --- /dev/null +++ b/brag/brag/elider/test-json-elider-toy.rkt @@ -0,0 +1,9 @@ +#lang br +(require "json-elider-toy.rkt" + brag/support + rackunit) + +(check-equal? + (syntax->datum + (parse (list "bar"))) + '(thing)) diff --git a/brag/brag/elider/test-json-elider.rkt b/brag/brag/elider/test-json-elider.rkt index bbb7e4d..89287ed 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 (json (string "'hello world'")))))) + '(json (object (kvpair "message" (json (string "'hello world'")))))) -(check-equal? +#;(check-equal? (syntax->datum (parse "[[[{}]],[],[[{}]]]")) '(json (array #\[ (json (array #\[ (json (array #\[ (json (object)) #\])) #\])) #\, (json (array #\[ #\])) #\, (json (array #\[ (json (array #\[ (json (object )) #\])) #\])) #\])))