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

lhs-id splicing works ; tests pass

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-06 13:22:38 -07:00
parent 6d80193419
commit f6181b90d7
5 changed files with 35 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
brag/brag/codegen/codegen.rkt
View File

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

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

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

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>

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

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

24
brag/brag/rules/stx.rkt
View File

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