commit 23eba12634c88c0e120ffce2611f9ae0dbe66bcc
parent e8e24a4db615fc921b1acdf36f0aeb8dfb614639
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 8 Sep 2016 14:23:22 +0200
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.
Diffstat:
5 files changed, 157 insertions(+), 28 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
