suzanne.soy/extensible-parser-specifications
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

Implemented partial order with ~order-point, order-point< and order-point>. Fixed bug with unwanted scope which prevented the attributes from being visible when a mixin was used directly within syntax-parse.

Browse Source
This commit is contained in:
Georges Dupéron 2016-09-08 14:23:22 +02:00
parent e8e24a4db6
commit 23eba12634
5 changed files with 154 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
main.rkt
View File

@ -7,7 +7,12 @@
"private/global.rkt"
"private/optional.rkt"
"private/mixin.rkt"
(for-template "private/define-syntax+simple-api.rkt"))
(for-template "private/define-syntax+simple-api.rkt")
syntax/parse)
;; from syntax/parse, so that define-eh-alternative-mixin can recognize uses of
;; (pattern …)
(provide pattern)
(provide #;define-splicing-syntax-class-with-eh-mixins
#;define-syntax-class-with-eh-mixins
@ -15,6 +20,9 @@
(expander-out eh-mixin)
~seq-no-order
~no-order
~order-point
order-point<
order-point>
~mixin
~post-check
~post-fail

104
private/no-order.rkt
View File

@ -33,6 +33,9 @@
(provide define-eh-alternative-mixin
~seq-no-order
~no-order
~order-point
order-point<
order-point>
(expander-out eh-mixin))
(define-expander-type eh-mixin)
@ -44,7 +47,8 @@
#`(begin
(define-eh-mixin-expander name
(λ (_)
(quote-syntax (~or pat ...))))
(syntax-local-syntax-parse-pattern-introduce
(quote-syntax (~or pat ...)))))
#,@(if (attribute splicing-name)
#'((define-splicing-syntax-class splicing-name
(pattern {~seq-no-order {name}})))
@ -57,6 +61,15 @@
(apply append (stx-map inline-or #'rest))]
[x (list #'x)]))
(define-for-syntax parse-seq-order-sym-introducer (make-syntax-introducer))
(define-for-syntax (fix-disappeared-uses)
;; Fix for https://github.com/racket/racket/issues/1452
(let ([dis (current-recorded-disappeared-uses)])
#`{~do #,(with-disappeared-uses
(record-disappeared-uses dis)
#'(void))}))
;; TODO: ~seq-no-order should also be a eh-mixin-expander, so that when there
;; are nested ~seq-no-order, the ~post-fail is caught by the nearest
;; ~seq-no-order.
@ -80,32 +93,71 @@
(define (add-to-post-groups! . v)
(set! post-groups-acc (cons v post-groups-acc)))
;; expand EH alternatives:
(define alts
(parameterize ([eh-post-accumulate add-to-post!]
[eh-post-group add-to-post-groups!]
[clause-counter increment-counter])
;(inline-or
(expand-all-eh-mixin-expanders #'(~or pat ...))))
(define post-group-bindings
(for/list ([group (group-by car
post-groups-acc
free-identifier=?)])
;; each item in `group` is a four-element list:
;; (list result-id aggregate-function attribute)
(define/with-syntax name (first (car group))
#;(syntax-local-introduce
(datum->syntax #'here
(first (car group)))))
(define/with-syntax f (second (car group)))
#`[name (f . #,(map (λ (i) #`(attribute #,(third i)))
group))]))
#`(~delimit-cut
(~and (~seq #,alts (... ...)) ;;(~or . #,alts)
~!
(~bind #,@post-group-bindings)
#,@post-acc))))]))))
(parameterize ([eh-post-accumulate add-to-post!]
[eh-post-group add-to-post-groups!]
[clause-counter increment-counter])
(define alts
(expand-all-eh-mixin-expanders #'(~or pat ...)))
(define post-group-bindings
(for/list ([group (group-by car
post-groups-acc
free-identifier=?)])
;; each item in `group` is a four-element list:
;; (list result-id aggregate-function attribute)
(define/with-syntax name (first (car group))
#;(syntax-local-introduce
(datum->syntax #'here
(first (car group)))))
(define/with-syntax f (second (car group)))
#`[name (f . #,(map (λ (i) #`(attribute #,(third i)))
group))]))
(define/with-syntax whole-clause (get-new-clause!))
(define/with-syntax parse-seq-order-sym-id
(datum->syntax (parse-seq-order-sym-introducer
(syntax-local-introduce #'here))
'parse-seq-order-sym))
#`(~delimit-cut
(~and #,(fix-disappeared-uses)
{~seq whole-clause (… …)}
{~do (define parse-seq-order-sym-id
(gensym 'parse-seq-order))}
{~parse ({~seq #,alts (… …)})
#`#,(for/list
([xi (in-syntax #'(whole-clause (… …)))]
[i (in-naturals)])
;; Add a syntax property before parsing,
;; to track the position of matched elements
;; using ~order-point
(syntax-property xi
parse-seq-order-sym-id
i))}
~!
(~bind #,@post-group-bindings)
#,@post-acc)))))]))))
(define-syntax ~no-order
(pattern-expander
(λ/syntax-case (_ . rest) ()
#'({~seq-no-order . rest}))))
#'({~seq-no-order . rest}))))
(define-eh-mixin-expander ~order-point
(λ (stx)
(define/with-syntax clause-point (get-new-clause!))
(define/with-syntax parse-seq-order-sym-id
(datum->syntax (parse-seq-order-sym-introducer
(syntax-local-introduce #'here))
'parse-seq-order-sym))
(syntax-case stx ()
[(_ point-name pat …)
#'(~and (~seq clause-point _ (… …))
(~bind [point-name (syntax-property #'clause-point
parse-seq-order-sym-id)])
{~seq pat …})])))
(define-syntax-rule (order-point< a b)
(and (attribute a) (attribute b)
(< (attribute a) (attribute b))))
(define-syntax-rule (order-point> a b)
(and (attribute a) (attribute b)
(> (attribute a) (attribute b))))

2
private/parameters.rkt
View File

@ -30,6 +30,8 @@
(define-for-syntax clause-counter (make-parameter #f))
(define-for-syntax (get-new-clause!)
(unless clause-counter
(error "Use get-new-clause! within (parameterize ([clause-counter …]) …)"))
(datum->syntax #'here
;; keep the spaces, they allow us to recognize clauses later.
(string->symbol (format " -clause-~a " ((clause-counter))))))

44
test/test-order-point.rkt Normal file
View File

@ -0,0 +1,44 @@
#lang racket
(require syntax/parse
extensible-parser-specifications
phc-toolkit/untyped
rackunit)
(define-syntax-class abc-order
(pattern
{~no-order
{~optional {~order-point a-point #:a
{~post-fail "#:a must appear after #:b"
#:when (order-point> a-point b-point)}}}
{~optional {~order-point b-point #:b}}
{~optional {~order-point c-point #:c}}}))
(define-syntax-rule (check-parse-abc stx)
(check-true (syntax-parse stx
[:abc-order #t]
[_ #f])))
(define-syntax-rule (check-fail-abc stx exn)
(check-exn exn
(λ ()
(syntax-parse stx
[:abc-order 'ok]))))
(check-parse-abc #'(#:a))
(check-parse-abc #'(#:b))
(check-parse-abc #'(#:c))
(check-parse-abc #'(#:a #:b))
(check-parse-abc #'(#:c #:a))
(check-parse-abc #'(#:a #:c))
(check-parse-abc #'(#:c #:b))
(check-parse-abc #'(#:b #:c))
(check-parse-abc #'(#:c #:a #:b))
(check-parse-abc #'(#:a #:c #:b))
(check-parse-abc #'(#:a #:b #:c))
(check-fail-abc #'(#:b #:a) #px"#:a must appear after #:b")
(check-fail-abc #'(#:c #:b #:a) #px"#:a must appear after #:b")
(check-fail-abc #'(#:b #:c #:a) #px"#:a must appear after #:b")
(check-fail-abc #'(#:b #:a #:c) #px"#:a must appear after #:b")
(check-fail-abc #'(#:a #:a) #px"unexpected term")
(check-fail-abc #'(#:c #:c) #px"unexpected term")

21
test/test-scopes-mixin-in-syntax-parser.rkt Normal file
View File

@ -0,0 +1,21 @@
#lang racket
(require phc-toolkit/untyped
extensible-parser-specifications
syntax/parse
rackunit)
(define-eh-alternative-mixin props-mixin
(pattern
(~optional (~seq #:foo bar))))
(define test
(syntax-parser
[(~no-order {~mixin props-mixin})
(attribute bar)]))
(test-equal?
"Without the bugfix, the pattern variable \"bar\" above had the wrong scopes,
and couldn't be used with (attribute bar), and #'bar just gave #'bar instead of
producing #'42"
(syntax-e (test #'(#:foo bar)))
42)