commit 3feb92c09da38ec622b2f8a1a1c7b4341eb88f1f
parent 95f455a89dde7f9d656b51b456b2144032149f71
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Fri, 26 Aug 2016 20:15:03 +0200
Implemented ~global-or, ~global-and and ~global-counter, but they don't work properly due to backtracking.
Diffstat:
3 files changed, 163 insertions(+), 101 deletions(-)
diff --git a/structure-options2.rkt b/structure-options2.rkt
@@ -6,12 +6,11 @@
rackunit
racket/format
phc-toolkit/untyped
+ "structure-options2b.rkt"
(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
@@ -41,39 +40,25 @@
(define-eh-alternative-mixin structure-kw-fields
(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"))))
+ (~optional/else
+ (~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) (list)]
+ [(value 1) (list)]
+ [(type 1) (list)])
+ #:else-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)
@@ -85,16 +70,20 @@
(define-splicing-syntax-class structure-kws
(pattern (~no-order (structure-kw-all-mixin))))
-#|
(check-equal? (syntax->datum
(syntax-parse #'(#:instance #:? p)
- [(:structure-kws) #'(instance instance-or-builder predicate)]))
- '(#:instance #:instance p))
+ [(:structure-kws)
+ #'(instance instance-or-builder
+ predicate
+ [field ...]
+ [value ...])]))
+ '(#:instance #:instance p [] []))
(check-equal? (syntax->datum
(syntax-parse #'(#:builder)
- [(k:structure-kws) #'(k.builder k.instance-or-builder)]))
- '(#:builder #:builder))
+ [(k:structure-kws)
+ #'(k.builder k.instance-or-builder [k.field ...])]))
+ '(#:builder #:builder []))
(test-exn
"Check that () is rejected, as it has neither #:instance nor #:builder"
@@ -110,7 +99,6 @@ builder-style field declarations"
(λ ()
(syntax-parse #'(#:instance [f1] [f2])
[(:structure-kws) #'([field ...] instance)])))
-|#
(check-equal? (syntax->datum
(syntax-parse #'(#:builder #:? p [f1] [f2])
@@ -123,7 +111,7 @@ builder-style field declarations"
'(#f [f1 f2]))
;; This one is appropriately rejected
-#;(check-exn #px"unexpected term"
- (λ ()
- (syntax-parse #'(#:instance #: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-test.rkt b/structure-options2b-test.rkt
@@ -0,0 +1,15 @@
+#lang racket
+
+(require "structure-options2b.rkt"
+ 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))
+
+(syntax-parse #'(1 #:kw 3)
+ [{~no-order {~once {~global-counter #:kw }} }
diff --git a/structure-options2b.rkt b/structure-options2b.rkt
@@ -3,12 +3,13 @@
(require syntax/parse
syntax/parse/experimental/eh
generic-syntax-expanders
+ phc-toolkit/untyped
(for-syntax syntax/parse
racket/syntax
phc-toolkit/untyped
racket/list
generic-syntax-expanders
- racket/pretty))
+ racket/contract))
(provide ;define-splicing-syntax-class-with-eh-mixins
;define-syntax-class-with-eh-mixins
@@ -17,7 +18,11 @@
~no-order
~post-check
~post-fail
- ~nop)
+ ~nop
+ ~optional/else
+ ~global-or
+ ~global-and
+ ~global-counter)
;; ------------
;; eh-mixin — TODO: move to phc-toolkit once the PR #7 for reqprov in
@@ -25,8 +30,24 @@
(define-expander-type eh-mixin)
-(define-for-syntax eh-post-accumulate (make-parameter #f))
+(define-syntax-rule (define-dynamic-accumulator-parameter parameter-name name!)
+ (begin
+ (define-for-syntax parameter-name (make-parameter #f))
+ (define-for-syntax (name! name . args)
+ (unless (parameter-name)
+ (raise-syntax-error name
+ (string-append (symbol->string name)
+ " used outside of ~no-order")))
+ (apply (parameter-name) args))))
+
+(define-dynamic-accumulator-parameter eh-post-accumulate eh-post-accumulate!)
+(define-dynamic-accumulator-parameter eh-pre-declarations eh-pre-declare!)
+
+;; ----
+
(define-for-syntax clause-counter (make-parameter #f))
+(define-for-syntax (get-new-clause!)
+ (string->symbol (format "clause~a" ((clause-counter)))))
(define-syntax define-eh-alternative-mixin
(syntax-parser
@@ -36,10 +57,7 @@
(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))
- ...))))]))
+ (quote-syntax (~or pat ...)))))]))
;; ----------
@@ -57,64 +75,65 @@
(λ (stx)
(syntax-case stx ()
[(self pat ...)
- ((λ (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 acc)))
- (define alts
- (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))))]))))
+ (let ()
+ (define counter 0)
+ (define (increment-counter)
+ (begin0 counter
+ (set! counter (add1 counter))))
+ (define post-acc '())
+ (define (add-to-post! v) (set! post-acc (cons v post-acc)))
+ ;; pre-acc gathers some bindings that have to be pre-declared
+ (define pre-acc (make-hash))
+ (define/contract (add-to-pre! s v) (-> symbol? any/c identifier?)
+ (define not-found (gensym))
+ (define ref (hash-ref pre-acc s #f))
+ (if ref
+ (car ref)
+ (let ([id (datum->syntax (syntax-local-introduce #'here) s)])
+ (hash-set! pre-acc s (cons id v))
+ id)))
+ ;(define-values (pre-acc add-to-pre) (make-mutable-accumulator))
+ (define alts
+ (parameterize ([eh-post-accumulate add-to-post!]
+ [eh-pre-declarations add-to-pre!]
+ [clause-counter increment-counter])
+ (inline-or (expand-all-eh-mixin-expanders #'(~or pat ...)))))
+ (define pre-acc-bindings (hash-map pre-acc
+ (λ (s bv) #`(define . #,bv))))
+ #`(~delimit-cut
+ (~and (~do #,@pre-acc-bindings)
+ (~seq (~or . #,alts) (... ...))
+ ~!
+ #,@post-acc)))]))))
(define-syntax ~nop
(pattern-expander
(λ/syntax-case (_) () #'(~do))))
-(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)]
+ (begin (eh-post-accumulate! '~post-check #'post)
+ #'pat)]
[(_ post)
- (begin
- (eh-post-accumulate! '~post-check #'post)
- #'(~nop))])))
-
-(define-eh-mixin-expander ~post-fail
- (let ()
- (define (parse stx)
- (syntax-case stx ()
- [(_ message #:when condition)
- (begin
- (define/with-syntax clause-present
- (string->symbol (format "clause~a" ((clause-counter)))))
- (eh-post-accumulate!
- '~post-fail
- #`(~fail #:when (and (attribute clause-present)
- condition)
- message))
- #'(~bind [clause-present #t]))]
- [(self #:when condition message)
- (parse #'(self message #:when condition))]))
- parse))
+ (begin (eh-post-accumulate! '~post-check #'post)
+ #'(~nop))])))
+
+(define-for-syntax (post-fail stx)
+ (syntax-case stx ()
+ [(_ message #:when condition)
+ (begin
+ (define/with-syntax clause-present (get-new-clause!))
+ (eh-post-accumulate! '~post-fail
+ #`(~fail #:when (and (attribute clause-present)
+ condition)
+ message))
+ #'(~bind [clause-present #t]))]
+ [(self #:when condition message)
+ (post-fail #'(self message #:when condition))]))
+
+(define-eh-mixin-expander ~post-fail post-fail)
(define-syntax ~mutex
(pattern-expander
@@ -122,3 +141,42 @@
(syntax-case stx ()
[(self (mutex:id ...) pat ...)
#'(???)]))))
+
+(define-syntax-rule (define-~global ~global-name init f)
+ (define-eh-mixin-expander ~global-name
+ (λ/syntax-case (_ name v pat) ()
+ (eh-pre-declare! '~bool-or (syntax-e #'name) init)
+ #`(~and (~do (define tmp name))
+ (~do (define name (#,f tmp v)))
+ pat))))
+
+(define-~global ~global-or #f (λ (acc v) (or acc v)))
+(define-~global ~global-and #t (λ (acc v) (and acc v)))
+(define-~global ~global-counter 0 add1)
+
+(define-eh-mixin-expander ~optional/else
+ (syntax-parser
+ [(_ pat
+ (~optional (~seq #:defaults (default-binding ...))
+ #:defaults ([(default-binding 1) (list)]))
+ (~seq #:else-post-fail (~or (~seq message #:when condition)
+ (~seq #:when condition message)))
+ ...
+ (~optional (~seq #:name name)))
+ #:with clause-whole (get-new-clause!)
+ #:with clause-present (get-new-clause!)
+ (for ([message (in-syntax #'(message ...))]
+ [condition (in-syntax #'(condition ...))])
+ (eh-post-accumulate! '~optional/else
+ #`(~fail #:when (and (eq? (attr clause-present) 0)
+ #,condition)
+ #,message)))
+ #`(~optional (~and pat
+ ;(~seq clause-whole (... ...))
+ ;; can't use #f, because of the bug
+ ;; https://github.com/racket/racket/issues/1437
+ (~bind [clause-present 1]))
+ #:defaults (default-binding ...
+ ;[(clause-whole 1) #'()]
+ [clause-present 0])
+ #,@(if (attribute name) #'(#:name name) #'()))]))
+\ No newline at end of file
