commit 777f9712f4fa7ebafabba554064a790576f0e830
parent a8e46bb5f454c90cc7046e2e6ffffb026e3dcc09
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 25 Aug 2016 17:10:43 +0200
WIP on ~no-order. Before cleaning up implementation of ~post-fail.
Diffstat:
2 files changed, 173 insertions(+), 115 deletions(-)
diff --git a/structure-options2.rkt b/structure-options2.rkt
@@ -1,7 +1,21 @@
#lang racket
+(require racket/require
+ syntax/parse
+ (subtract-in syntax/stx phc-toolkit/untyped)
+ rackunit
+ racket/format
+ phc-toolkit/untyped
+ (for-syntax syntax/parse
+ syntax/stx
+ racket/format))
+
(require "structure-options2b.rkt")
+(provide structure-kw-instance-or-builder-mixin
+ structure-kw-predicate-mixin
+ structure-kw-fields-mixin
+ structure-kw-all-mixin)
(define-eh-alternative-mixin structure-kw-instance-or-builder
(pattern (~optional (~and instance-or-builder
@@ -13,73 +27,74 @@
(pattern (~optional (~seq #:? predicate:id)
#:name "#:? predicate")))
+(define-and-for-syntax instance-no-values-error
+ (~a "The #:instance keyword implies the use of [field value],"
+ " [field : type value] or [field value : type]."))
(define-eh-alternative-mixin structure-kw-fields
- (pattern (~once (~seq [field:id] ...)
- #:name "[field]"))
- #:post (~fail #:when (and (attribute instance)
- (not (stx-null? #'(field ...))))))
+ (pattern (~once (~seq [field:id] ...
+ (~post-fail instance-no-values-error
+ #:when (and (attribute instance)
+ (not (stx-null? #'(field ...))))))
+ #:name "[field]")))
(define-eh-alternative-mixin structure-kw-all
(pattern (~or (structure-kw-instance-or-builder-mixin)
(structure-kw-predicate-mixin)
(structure-kw-fields-mixin))))
+;; ---------
-#;(define-splicing-syntax-class-with-eh-mixins structure-kws
- (pattern (~no-order (structure-kw-all-mixin) ...)))
(define-splicing-syntax-class structure-kws
- #;(pattern (~no-order (structure-kw-all-mixin)))
- (pattern (~and
- (~seq
- (~or
- (~optional
- (~and
- instance-or-builder
- (~or (~and instance #:instance) (~and builder #:builder)))
- #:name
- "either #:instance or #:builder")
- (~optional (~seq #:? predicate:id) #:name "#:? predicate")
- (~once (~seq (field:id) ...) #:name "[field]"))
- ...)
- (~fail #:when (and (attribute instance) (not (stx-null? #'(field ...))))))))
-
-#;(define-splicing-syntax-class
- structure-kws
- (pattern
- (~and
- (~seq
- (~or
- (~or
- (~or
- (~optional
- (~and
- instance-or-builder
- (~or (~and instance #:instance) (~and builder #:builder)))
- #:name
- "either #:instance or #:builder"))
- (~or (~optional (~seq #:? predicate:id)
- #:name "#:? predicate"))
- (~or (~once (~and (~seq (field:id) ...))
- #:name "[field] …"))))
- ...)
- (~fail #:when (and (attribute instance)
- (not (stx-null? #'(field ...))))))))
+ (pattern #;(~no-order (structure-kw-all-mixin))
+ (~delimit-cut
+ (~and
+ (~seq
+ (~or
+ (~optional
+ (~and
+ instance-or-builder
+ (~or (~and instance #:instance) (~and builder #:builder)))
+ #:name
+ "either #:instance or #:builder")
+ (~optional (~seq #:? predicate:id) #:name "#:? predicate")
+ (~optional (~seq (field:id) ...+ (~bind [clause178673 #t]))
+ #:name "[field]"))
+ ...)
+ ~!
+ (~fail
+ #:when
+ (and (attribute clause178673)
+ (and (attribute instance)))
+ instance-no-values-error)))))
-#;(begin
- (syntax-parse #'(#:instance #:? p)
- [(:structure-kws) #'(instance instance-or-builder predicate)])
+(check-equal? (syntax->datum
+ (syntax-parse #'(#:instance #:? p)
+ [(:structure-kws) #'(instance instance-or-builder predicate)]))
+ '(#:instance #:instance p))
- (syntax-parse #'(#:builder)
- [(k:structure-kws) #'(k.builder k.instance-or-builder)])
+(check-equal? (syntax->datum
+ (syntax-parse #'(#:builder)
+ [(k:structure-kws) #'(k.builder k.instance-or-builder)]))
+ '(#:builder #:builder))
- (syntax-parse #'()
- [(:structure-kws) #'()])
+(check-equal? (syntax->datum
+ (syntax-parse #'()
+ [(:structure-kws) #'()]))
+ '())
- (syntax-parse #'(#:instance #:? p [f1] [f2])
- [(:structure-kws) #'([field ...] instance)])
+;; This one is appropriately rejected :)
+(check-exn (regexp (regexp-quote instance-no-values-error))
+ (λ ()
+ (syntax-parse #'(#:instance [f1] [f2])
+ [(:structure-kws) #'([field ...] instance)])))
- (syntax-parse #'(#:builder [f1] [f2])
- [(:structure-kws) #'([field ...] builder)]))
+(check-equal? (syntax->datum
+ (syntax-parse #'(#:builder #:? p [f1] [f2])
+ [(:structure-kws) #'([field ...] builder)]))
+ '([f1 f2] #:builder))
-#;(syntax-parse #'(#:a)
- [(:structure-kws) 'err])
-\ No newline at end of file
+;; This one is appropriately rejected
+(check-exn #px"unexpected term"
+ (λ ()
+ (syntax-parse #'(#:a)
+ [(:structure-kws) 'err])))
+\ No newline at end of file
diff --git a/structure-options2b.rkt b/structure-options2b.rkt
@@ -3,67 +3,44 @@
(require syntax/parse
syntax/parse/experimental/eh
generic-syntax-expanders
- syntax/stx
(for-syntax syntax/parse
racket/syntax
- syntax/stx
- racket/pretty)) ;; debug
+ phc-toolkit/untyped
+ racket/list
+ generic-syntax-expanders
+ racket/pretty))
+
+(provide ;define-splicing-syntax-class-with-eh-mixins
+ ;define-syntax-class-with-eh-mixins
+ define-eh-alternative-mixin
+ (expander-out eh-mixin)
+ ~no-order
+ ~post-check
+ ~post-fail)
;; ------------
;; eh-mixin — TODO: move to phc-toolkit once the PR #7 for reqprov in
-;; generic-syntax-expander is merged. Look for "End eh-mixin" below for the end.
+;; generic-syntax-expander is merged.
(define-expander-type eh-mixin)
-(begin-for-syntax
- (define eh-post-accumulate (make-parameter #f)))
+(define-for-syntax eh-post-accumulate (make-parameter #f))
+#;(define-for-syntax current-no-order-clause (make-parameter #f))
(define-syntax define-eh-alternative-mixin
(syntax-parser
- [(_ name ((~literal pattern) pat) ... (~optional (~seq #:post post)))
+ [(_ name ((~literal pattern) pat) ...)
(let ()
(define/with-syntax mixin (format-id #'name "~a-mixin" #'name))
- ;(display "post:") (displayln (attribute post))
- #`(begin
- (define-eh-mixin-expander mixin
- (λ (_)
- #,@(if (attribute post)
- #'((unless (eh-post-accumulate)
- (raise-syntax-error
- 'define-eh-alternative-mixin
- "#:post used outside of ~no-order"))
- ((eh-post-accumulate) (quote-syntax post)))
- #'())
- (quote-syntax (~or pat ...))))
- #;(define-eh-alternative-set name
- #,@(stx-map (λ (p)
- #`(pattern #,(expand-all-eh-mixin-expanders p)))
- #'(pat ...)))))]))
-
-(define-for-syntax (define-?-syntax-class-with-eh-mixins original-form)
- (syntax-parser
- [(_ signature {~and opts {~not ({~literal pattern} . _)}} ...
- ({~literal pattern} pat . pat-opts) ...)
- ;((λ (x) (pretty-write (syntax->datum x)) x)
- #`(#,original-form
- signature opts ...
- #,@(stx-map (λ (p po)
- #`(pattern #,(expand-all-eh-mixin-expanders p) . #,po))
- #'(pat ...)
- #'(pat-opts ...)))]))
-
-(define-syntax define-splicing-syntax-class-with-eh-mixins
- (define-?-syntax-class-with-eh-mixins #'define-splicing-syntax-class))
+ (define-temp-ids "~a/clause" (pat ...))
+ #'(define-eh-mixin-expander mixin
+ (λ (_)
+ (quote-syntax (~or pat ...))
+ #;#`(~or #,(parameterize ([current-no-order-clause #'pat/clause])
+ (quote-syntax pat))
+ ...))))]))
-(define-syntax define-syntax-class-with-eh-mixins
- (define-?-syntax-class-with-eh-mixins #'define-syntax-class))
-
-
-
-(provide define-splicing-syntax-class-with-eh-mixins
- define-syntax-class-with-eh-mixins
- define-eh-alternative-mixin
- (expander-out eh-mixin))
+;; ----------
(define-for-syntax (inline-or stx)
(syntax-case stx ()
@@ -72,24 +49,91 @@
(apply append (stx-map inline-or #'rest))]
[x (list #'x)]))
+#;(define-for-syntax (expand-no-order-clauses/tree x)
+ (cond
+ [(syntax? x) (datum->syntax x
+ (expand-no-order-clauses/tree (syntax-e x))
+ x
+ x)]))
+
+#;(define-for-syntax (expand-no-order-clauses stx)
+ (syntax-case stx (~or)
+ [(~or pat ...) (append-map expand-no-order-clauses
+ (syntax->list #'(pat ...)))]
+ [(exp . args)
+ (let ([slv (syntax-local-value #'exp (λ _ #f))])
+ (and slv (expander? slv) (eh-mixin-expander? slv)))
+ (let* ([slv (syntax-local-value #'exp (λ _ #f))]
+ [transformer (expander-transformer slv)])
+ (expand-no-order-clauses (transformer stx)))]
+ [pat (parameterize ([current-no-order-clause #`#,(gensym 'clause)])
+ (list (expand-all-eh-mixin-expanders #'pat)))]))
+
+;; TODO: ~no-order should also be a eh-mixin-expander, so that nested ~post-fail
+;; are caught
(define-syntax ~no-order
(pattern-expander
(λ (stx)
(syntax-case stx ()
- [(_ pat ...)
- ((λ (x) (pretty-write (syntax->datum x)) x)
+ [(self pat ...)
+ ((λ (x) (pretty-write (syntax->datum x)) (newline) x)
(let ()
(define acc '())
(define (add-to-acc p)
- (displayln p)
- (newline)
- (set! acc (cons p acc)))
+ (set! acc (cons p #;(replace-context #'self p) acc)))
(define alts
(parameterize ([eh-post-accumulate add-to-acc])
- (expand-all-eh-mixin-expanders
- #'(~or pat ...))))
- #`(~and (~seq (~or . #,(inline-or alts)) (... ...))
- #,@acc)))]))))
+ #;(expand-no-order-clauses #'(~or pat ...))
+ (inline-or (expand-all-eh-mixin-expanders #'(~or pat ...)))))
+ #`(~delimit-cut
+ (~and (~seq (~or . #,alts) (... ...))
+ ~!
+ #,@acc))))]))))
+
+(define-for-syntax (eh-post-accumulate! name p)
+ (unless (eh-post-accumulate)
+ (raise-syntax-error
+ name
+ (string-append (symbol->string name) " used outside of ~no-order")))
+ ((eh-post-accumulate) p))
+
+(define-eh-mixin-expander ~post-check
+ (λ (stx)
+ (syntax-case stx ()
+ [(_ pat post)
+ (begin
+ (eh-post-accumulate! '~post-check #'post)
+ #'pat)]
+ [(_ post)
+ (begin
+ (eh-post-accumulate! '~post-check #'post)
+ #'(~do))])))
+
+(define-eh-mixin-expander ~post-fail
+ (let ()
+ (define (parse stx)
+ (syntax-case stx ()
+ [(_ message #:when condition)
+ (begin
+ #;(unless (current-no-order-clause)
+ (raise-syntax-error
+ '~post-fail
+ "~post-fail cannot be used directly as an ellipsis-head pattern"))
+ (define/with-syntax clause-present (gensym 'clause))
+ (eh-post-accumulate!
+ '~post-fail
+ #`(~fail #:when (and (attribute (~bind [clause-present #t])
+ #;#,(current-no-order-clause))
+ condition)
+ message))
+ #'(~do))]
+ [(self #:when condition message)
+ (parse #'(self message #:when condition))]))
+ parse))
-;; End eh-mixin
-;; ------------
-\ No newline at end of file
+(define-syntax ~mutex
+ (pattern-expander
+ (λ (stx)
+ (syntax-case stx ()
+ [(self (mutex:id ...) pat ...)
+ #'(???)]))))
