commit 95f455a89dde7f9d656b51b456b2144032149f71
parent 777f9712f4fa7ebafabba554064a790576f0e830
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 25 Aug 2016 22:30:58 +0200
Works, but needs cleanup for the ~optional.
Diffstat:
2 files changed, 91 insertions(+), 77 deletions(-)
diff --git a/structure-options2.rkt b/structure-options2.rkt
@@ -27,15 +27,53 @@
(pattern (~optional (~seq #:? predicate:id)
#:name "#:? predicate")))
-(define-and-for-syntax instance-no-values-error
+(define-and-for-syntax no-values-err
(~a "The #:instance keyword implies the use of [field value],"
" [field : type value] or [field value : type]."))
+
+(define-and-for-syntax values-err
+ (~a "The #:builder keyword implies the use of [field], field"
+ " or [field : type]."))
+
+(define-and-for-syntax empty-err
+ (~a "If no fields are specified, then either #:builder or #:instance"
+ " must be present"))
+
(define-eh-alternative-mixin structure-kw-fields
- (pattern (~once (~seq [field:id] ...
- (~post-fail instance-no-values-error
- #:when (and (attribute instance)
- (not (stx-null? #'(field ...))))))
- #:name "[field]")))
+ (pattern
+ (~optional (~and
+ (~seq clause42 ...)
+ ;; can't use #f, because of the bug
+ ;; https://github.com/racket/racket/issues/1437
+ (~bind [clause42-match? 1])
+ (~or (~seq (~or-bug [field:id] field:id) …+
+ (~post-fail no-values-err #:when (attribute instance)))
+ (~seq [field:id : type] …+
+ (~post-fail no-values-err #:when (attribute instance)))
+ (~seq [field:id value:expr] …+
+ (~post-fail values-err #:when (attribute builder)))
+ (~seq (~or-bug [field:id value:expr : type]
+ [field:id : type value:expr])
+ …+
+ (~post-fail values-err #:when (attribute builder)))))
+ #:defaults ([(field 1) #'()]
+ [(clause42 1) #'()]
+ [clause42-match?
+ (begin (syntax-parse #'dummy
+ [(~and dummy
+ (~post-check (~fail #:when
+ (and (= (attribute clause42-match?) 0)
+ (and (not (attribute builder))
+ (not (attribute instance))))
+ empty-err)))
+ #'()])
+ 0)])
+ #;(~post-fail empty-err
+ #:when (and (not (attribute builder))
+ (not (attribute instance))))
+ #:name (~a "field or [field] or [field : type] for #:builder,"
+ " [field value] or [field : type value]"
+ " or [field value : type] for #:instance"))))
(define-eh-alternative-mixin structure-kw-all
(pattern (~or (structure-kw-instance-or-builder-mixin)
@@ -45,28 +83,9 @@
;; ---------
(define-splicing-syntax-class structure-kws
- (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)))))
+ (pattern (~no-order (structure-kw-all-mixin))))
+#|
(check-equal? (syntax->datum
(syntax-parse #'(#:instance #:? p)
[(:structure-kws) #'(instance instance-or-builder predicate)]))
@@ -77,24 +96,34 @@
[(k:structure-kws) #'(k.builder k.instance-or-builder)]))
'(#:builder #:builder))
-(check-equal? (syntax->datum
- (syntax-parse #'()
- [(:structure-kws) #'()]))
- '())
+(test-exn
+ "Check that () is rejected, as it has neither #:instance nor #:builder"
+ (regexp (regexp-quote empty-err))
+ (λ ()
+ (syntax-parse #'()
+ [(:structure-kws) #'()])))
-;; This one is appropriately rejected :)
-(check-exn (regexp (regexp-quote instance-no-values-error))
- (λ ()
- (syntax-parse #'(#:instance [f1] [f2])
- [(:structure-kws) #'([field ...] instance)])))
+(test-exn
+ "Check that (#:instance [f1] [f2]) is rejected, as #:instance conflicts with
+builder-style field declarations"
+ (regexp (regexp-quote no-values-err))
+ (λ ()
+ (syntax-parse #'(#:instance [f1] [f2])
+ [(:structure-kws) #'([field ...] instance)])))
+|#
(check-equal? (syntax->datum
(syntax-parse #'(#:builder #:? p [f1] [f2])
[(:structure-kws) #'([field ...] builder)]))
'([f1 f2] #:builder))
+(check-equal? (syntax-parse #'([f1] [f2]); #:? p
+ [(:structure-kws) (cons (attribute builder)
+ (syntax->datum #'([field ...])))])
+ '(#f [f1 f2]))
+
;; This one is appropriately rejected
-(check-exn #px"unexpected term"
- (λ ()
- (syntax-parse #'(#:a)
- [(:structure-kws) 'err])))
-\ No newline at end of file
+#;(check-exn #px"unexpected term"
+ (λ ()
+ (syntax-parse #'(#:instance #:a)
+ [(:structure-kws) 'err])))
+\ No newline at end of file
diff --git a/structure-options2b.rkt b/structure-options2b.rkt
@@ -16,7 +16,8 @@
(expander-out eh-mixin)
~no-order
~post-check
- ~post-fail)
+ ~post-fail
+ ~nop)
;; ------------
;; eh-mixin — TODO: move to phc-toolkit once the PR #7 for reqprov in
@@ -25,7 +26,7 @@
(define-expander-type eh-mixin)
(define-for-syntax eh-post-accumulate (make-parameter #f))
-#;(define-for-syntax current-no-order-clause (make-parameter #f))
+(define-for-syntax clause-counter (make-parameter #f))
(define-syntax define-eh-alternative-mixin
(syntax-parser
@@ -49,28 +50,8 @@
(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
+;; TODO: ~no-order should also be a eh-mixin-expander, so that when there are
+;; nested ~no-order, the ~post-fail is caught by the nearest ~no-order.
(define-syntax ~no-order
(pattern-expander
(λ (stx)
@@ -79,17 +60,25 @@
((λ (x) (pretty-write (syntax->datum x)) (newline) x)
(let ()
(define acc '())
+ (define counter 0)
+ (define (increment-counter)
+ (begin0 counter
+ (set! counter (add1 counter))))
(define (add-to-acc p)
- (set! acc (cons p #;(replace-context #'self p) acc)))
+ (set! acc (cons p acc)))
(define alts
- (parameterize ([eh-post-accumulate add-to-acc])
- #;(expand-no-order-clauses #'(~or pat ...))
+ (parameterize ([eh-post-accumulate add-to-acc]
+ [clause-counter increment-counter])
(inline-or (expand-all-eh-mixin-expanders #'(~or pat ...)))))
#`(~delimit-cut
(~and (~seq (~or . #,alts) (... ...))
~!
#,@acc))))]))))
+(define-syntax ~nop
+ (pattern-expander
+ (λ/syntax-case (_) () #'(~do))))
+
(define-for-syntax (eh-post-accumulate! name p)
(unless (eh-post-accumulate)
(raise-syntax-error
@@ -107,7 +96,7 @@
[(_ post)
(begin
(eh-post-accumulate! '~post-check #'post)
- #'(~do))])))
+ #'(~nop))])))
(define-eh-mixin-expander ~post-fail
(let ()
@@ -115,18 +104,14 @@
(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))
+ (define/with-syntax clause-present
+ (string->symbol (format "clause~a" ((clause-counter)))))
(eh-post-accumulate!
'~post-fail
- #`(~fail #:when (and (attribute (~bind [clause-present #t])
- #;#,(current-no-order-clause))
+ #`(~fail #:when (and (attribute clause-present)
condition)
message))
- #'(~do))]
+ #'(~bind [clause-present #t]))]
[(self #:when condition message)
(parse #'(self message #:when condition))]))
parse))
