suzanne.soy/beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

make ids hideable

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-06 12:36:25 -07:00
parent f072c9f808
commit 2026c603de
6 changed files with 45 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
brag/brag/codegen/codegen.rkt
View File

@ -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)

14
brag/brag/codegen/runtime.rkt
View File

@ -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))

4
brag/brag/elider/json-elider-toy.rkt
View File

@ -1,4 +1,4 @@
#lang brag
;; Simple baby example of JSON structure
json: ID <":"> ID
thing : foo
foo : <"bar">

2
brag/brag/elider/json-elider.rkt
View File

@ -14,4 +14,4 @@ array: "[" [json ("," json)*] "]"
object: <"{"> [kvpair ("," kvpair)*] <"}">
kvpair: <ID> <":"> json
kvpair: <ID> ":" <json>

9
brag/brag/elider/test-json-elider-toy.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang br
(require "json-elider-toy.rkt"
brag/support
rackunit)
(check-equal?
(syntax->datum
(parse (list "bar")))
'(thing))

4
brag/brag/elider/test-json-elider.rkt
View File

@ -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 )) #\])) #\])) #\])))