From 23eba12634c88c0e120ffce2611f9ae0dbe66bcc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 8 Sep 2016 14:23:22 +0200 Subject: [PATCH] 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. --- main.rkt | 10 +- private/no-order.rkt | 104 +++++++++++++++----- private/parameters.rkt | 2 + test/test-order-point.rkt | 44 +++++++++ test/test-scopes-mixin-in-syntax-parser.rkt | 21 ++++ 5 files changed, 154 insertions(+), 27 deletions(-) create mode 100644 test/test-order-point.rkt create mode 100644 test/test-scopes-mixin-in-syntax-parser.rkt diff --git a/main.rkt b/main.rkt index ba702e0..f91c6e0 100644 --- a/main.rkt +++ b/main.rkt @@ -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 diff --git a/private/no-order.rkt b/private/no-order.rkt index 047df30..8d90a23 100644 --- a/private/no-order.rkt +++ b/private/no-order.rkt @@ -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})))) \ No newline at end of file + #'({~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)))) \ No newline at end of file diff --git a/private/parameters.rkt b/private/parameters.rkt index 76c4add..acce164 100644 --- a/private/parameters.rkt +++ b/private/parameters.rkt @@ -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)))))) \ No newline at end of file diff --git a/test/test-order-point.rkt b/test/test-order-point.rkt new file mode 100644 index 0000000..52a33be --- /dev/null +++ b/test/test-order-point.rkt @@ -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") \ No newline at end of file diff --git a/test/test-scopes-mixin-in-syntax-parser.rkt b/test/test-scopes-mixin-in-syntax-parser.rkt new file mode 100644 index 0000000..71ceacc --- /dev/null +++ b/test/test-scopes-mixin-in-syntax-parser.rkt @@ -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) \ No newline at end of file