From 3feb92c09da38ec622b2f8a1a1c7b4341eb88f1f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Fri, 26 Aug 2016 20:15:03 +0200 Subject: [PATCH] Implemented ~global-or, ~global-and and ~global-counter, but they don't work properly due to backtracking. --- structure-options2.rkt | 78 +++++++--------- structure-options2b-test.rkt | 15 ++++ structure-options2b.rkt | 166 +++++++++++++++++++++++------------ 3 files changed, 160 insertions(+), 99 deletions(-) create mode 100644 structure-options2b-test.rkt diff --git a/structure-options2.rkt b/structure-options2.rkt index 395d426..f48498a 100644 --- 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 new file mode 100644 index 0000000..78a1772 --- /dev/null +++ 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 index d195e5b..96288bd 100644 --- 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))]))) + (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)) +(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