refactoring
This commit is contained in:
parent
12f7a3d332
commit
146e460a8f
|
@ -164,32 +164,36 @@ This would be the place to check a syntax property for hiding.
|
||||||
;; 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)
|
(define (remove-rule-name components-stx)
|
||||||
;; when removing a rule name, we apply it as a syntax property to the remaining elements
|
;; 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)
|
;; for possible later usage (aka, why throw away information)
|
||||||
;; todo: distinguish hiding and splicing behavior.
|
;; todo: distinguish hiding and splicing behavior.
|
||||||
;; when hiding, returned list should be a syntaxed list with the property.
|
;; 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.
|
;; when splicing, returned list should be a regular list, with each element having the property.
|
||||||
(let* ([cs-list (syntax->list cs)]
|
(let* ([name+elements (syntax->list components-stx)]
|
||||||
[rule-name (syntax->datum (car cs-list))]
|
[name-datum (syntax->datum (car name+elements))]
|
||||||
[elements (cdr cs-list)])
|
[elements (cdr name+elements)])
|
||||||
(map (λ(e) (syntax-property e rule-name #t)) elements)))
|
(map (λ(e) (syntax-property e name-datum #t)) elements)))
|
||||||
(define spliced-componentss
|
(define componentss-hoisted
|
||||||
(apply append
|
(apply append
|
||||||
(for/list ([css (in-list componentss)])
|
(for/list ([css (in-list componentss)])
|
||||||
(list
|
(list
|
||||||
(cond
|
;; each `css` is a list that's either empty, or has a single syntaxed component list
|
||||||
[(and (pair? css) (eq? (syntax-property (car css) 'hide-or-splice) 'hide))
|
(let ([components-stx (and (pair? css) (car css))])
|
||||||
(list (remove-rule-name (car css)))] ; hidden version still contained in `list`
|
(if components-stx
|
||||||
[(and (pair? css) (or (eq? (syntax-property (car css) 'hide-or-splice) 'splice)
|
(cond
|
||||||
(syntax-property (car css) 'splice-rh-id)))
|
[(eq? (syntax-property components-stx 'hide-or-splice) 'hide)
|
||||||
(remove-rule-name (car css))] ; spliced version is "delisted"
|
(list (remove-rule-name components-stx))] ; hidden version still wrapped in a sub-`list`
|
||||||
[else css])))))
|
[(or (eq? (syntax-property components-stx 'hide-or-splice) 'splice)
|
||||||
|
(syntax-property components-stx 'splice-rh-id))
|
||||||
|
(remove-rule-name components-stx)] ; spliced version is "delisted"
|
||||||
|
[else css])
|
||||||
|
css))))))
|
||||||
(syntax-property
|
(syntax-property
|
||||||
(datum->syntax #f
|
(datum->syntax #f
|
||||||
(cons
|
(cons
|
||||||
(datum->syntax #f rule-name/false srcloc stx-with-original?-property)
|
(datum->syntax #f rule-name/false srcloc stx-with-original?-property)
|
||||||
(apply append spliced-componentss))
|
(apply append componentss-hoisted))
|
||||||
srcloc
|
srcloc
|
||||||
stx-with-original?-property)
|
stx-with-original?-property)
|
||||||
;; not 'hide-or-splice-lhs-id, because it is now a component in a different rule
|
;; not 'hide-or-splice-lhs-id, because it is now a component in a different rule
|
||||||
|
|
|
@ -4,10 +4,10 @@
|
||||||
rackunit)
|
rackunit)
|
||||||
|
|
||||||
(define parse-result (parse (list "{"
|
(define parse-result (parse (list "{"
|
||||||
(token 'ID "message")
|
(token 'ID "message")
|
||||||
":"
|
":"
|
||||||
(token 'STRING "'hello world'")
|
(token 'STRING "'hello world'")
|
||||||
"}")))
|
"}")))
|
||||||
(check-equal? (syntax->datum parse-result) '(json ":"))
|
(check-equal? (syntax->datum parse-result) '(json ":"))
|
||||||
|
|
||||||
(define syntaxed-colon (cadr (syntax->list parse-result)))
|
(define syntaxed-colon (cadr (syntax->list parse-result)))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user