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

add syntax-property annotations to parse tree

Browse Source
This commit is contained in:
Matthew Butterick 2016-06-02 11:31:20 -07:00
parent 281bd09e25
commit 157787a99f
2 changed files with 18 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -158,21 +158,32 @@ 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)) (datum->syntax #f d (positions->srcloc start-pos end-pos) stx-with-original?-property))
(require sugar/debug)
;; rule-components->syntax: (U symbol false) (listof stx) ... #:srcloc (U #f (list src line column offset span)) -> stx ;; 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. ;; Creates an stx out of the rule name and its components.
;; The location information of the rule spans that of its components. ;; The location information of the rule spans that of its components.
(define (rule-components->syntax rule-name/false #:srcloc [srcloc #f] #:hide-or-splice? [hide-or-splice #f] . componentss) (define (rule-components->syntax rule-name/false #:srcloc [srcloc #f] #:hide-or-splice? [hide-or-splice #f] . componentss)
(define (remove-rule-name cs) (cdr (syntax->list cs))) (define (remove-rule-name cs)
;; when removing a rule name, we apply it as a syntax property to the remaining elements
;; for possible later usage (aka, why throw away information)
;; todo: distinguish hiding and splicing behavior.
;; when hiding, returned list should be a syntaxed list with the property.
;; when splicing, returned list should be a regualr list, with each element having the property.
(let* ([cs-list (syntax->list cs)]
[rule-name (syntax->datum (car cs-list))]
[elements (cdr cs-list)])
(map (λ(e) (syntax-property e rule-name #t)) elements)))
(define spliced-componentss (define spliced-componentss
(apply append (apply append
(for/list ([css (in-list componentss)]) (for/list ([css (in-list componentss)])
(list (list
(cond (cond
[(and (pair? css) (eq? (syntax-property (car css) 'hide-or-splice) 'hide)) [(and (pair? css) (eq? (syntax-property (car css) 'hide-or-splice) 'hide))
(list (remove-rule-name (car css)))] ; hidden version still contained in sublist (list (remove-rule-name (car css)))] ; hidden version still contained in `list`
[(and (pair? css) (or (eq? (syntax-property (car css) 'hide-or-splice) 'splice) [(and (pair? css) (or (eq? (syntax-property (car css) 'hide-or-splice) 'splice)
(syntax-property (car css) 'splice-rh-id))) (syntax-property (car css) 'splice-rh-id)))
(remove-rule-name (car css))] ; spliced version is "unlisted" (remove-rule-name (car css))] ; spliced version is "delisted"
[else css]))))) [else css])))))
(syntax-property (syntax-property
(datum->syntax #f (datum->syntax #f

8
brag/brag/test/test-baby-json-hider.rkt
View File

@ -3,15 +3,15 @@
brag/support brag/support
rackunit) rackunit)
(check-equal? (define parse-result (parse (list "{"
(syntax->datum
(parse (list "{"
(token 'ID "message") (token 'ID "message")
":" ":"
(token 'STRING "'hello world'") (token 'STRING "'hello world'")
"}"))) "}")))
'(json ":")) (check-equal? (syntax->datum parse-result) '(json ":"))
(define syntaxed-colon (cadr (syntax->list parse-result)))
(check-true (syntax-property syntaxed-colon 'kvpair))
(check-equal? (check-equal?
(syntax->datum (syntax->datum