From 2124915de2ebbac77b48a281a6894ad5fe590264 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 24 Dec 2022 21:08:57 +1300 Subject: [PATCH] Allow various kinds of statelike processing during pattern analysis --- syndicate/pattern.rkt | 37 ++++++++++++++++++-- syndicate/query.rkt | 78 +++++++++++++++++++++---------------------- syndicate/syntax.rkt | 32 +++++++++++------- 3 files changed, 93 insertions(+), 54 deletions(-) diff --git a/syndicate/pattern.rkt b/syndicate/pattern.rkt index 4052625..0a7d636 100644 --- a/syndicate/pattern.rkt +++ b/syndicate/pattern.rkt @@ -18,6 +18,10 @@ !dump-registered-preserves-patterns! + transform-pattern-binding + current-pattern-binding-let + pattern-binding-let + (all-from-out "schemas/dataspacePatterns.rkt")) (require (for-syntax racket/base)) @@ -32,6 +36,7 @@ (require preserves-schema) (require racket/match) (require racket/list) +(require racket/stxparam) (require "pattern-expander.rkt") (require "smart-pattern.rkt") (require "schemas/dataspacePatterns.rkt") @@ -70,6 +75,23 @@ (define-for-syntax orig-insp (variable-reference->module-declaration-inspector (#%variable-reference))) +(define-syntax-parameter transform-pattern-binding (lambda (id-stx expanded-stx) expanded-stx)) + +(define-syntax-parameter current-pattern-binding-let + (lambda (stx) + (syntax-case stx () + [(_ [(binding ...) bindings] body ...) + (syntax/loc stx + (match-let ([(list binding ...) bindings]) body ...))]))) + +(define-syntax pattern-binding-let + (lambda (stx) + (syntax-case stx () + [(_ [pat bindings] body ...) + (with-syntax (((binding ...) (analyse-pattern-bindings #'pat))) + (syntax/loc stx + (current-pattern-binding-let [(binding ...) bindings] body ...)))]))) + (begin-for-syntax (define (dollar-id? stx) (and (identifier? stx) @@ -77,7 +99,7 @@ (define (undollar stx) (and (dollar-id? stx) - (datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1))))) + (datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1)) stx))) (define (id=? expected stx) (and (identifier? stx) @@ -112,6 +134,9 @@ [(list _) (raise-syntax-error #f "Odd number of elements in hash-like pattern")] [(list* k v more) (append (f k v) (append-map-pairs f more))])) + (define (transform-binding id-stx expanded-stx) + ((syntax-parameter-value #'transform-pattern-binding) id-stx expanded-stx)) + (define (analyse-pattern stx #:check-destructuring [check-destructuring (lambda (stx) stx)] #:wrap-literal [wrap-literal (lambda (stx) stx)]) @@ -153,10 +178,10 @@ [id (dollar-id? #'id) - #`(Pattern-DBind (DBind (Pattern-DDiscard (DDiscard))))] + (transform-binding (undollar #'id) #`(Pattern-DBind (DBind (Pattern-DDiscard (DDiscard)))))] [($ id p) - #`(Pattern-DBind (DBind #,(walk #'p)))] + (transform-binding #'id #`(Pattern-DBind (DBind #,(walk #'p))))] [id (discard-id? #'id) @@ -357,3 +382,9 @@ (for [(k (in-list (free-id-table-keys preserves-pattern-registry)))] (printf " - ~v\n" k)) #'(void))])) + +;;--------------------------------------------------------------------------- +;;; Local Variables: +;;; eval: (put 'pattern-binding-let 'racket-indent-function 1) +;;; eval: (put 'current-pattern-binding-let 'racket-indent-function 1) +;;; End: diff --git a/syndicate/query.rkt b/syndicate/query.rkt index c37e9b4..3c7d888 100644 --- a/syndicate/query.rkt +++ b/syndicate/query.rkt @@ -56,10 +56,10 @@ (ref (entity #:name 'field-name #:assert (lambda (bindings handle) - (match-define (list #,@(analyse-pattern-bindings #'P)) bindings) - (set! assertion-count (+ assertion-count 1)) - (F expr) - on-add.expr) + (pattern-binding-let [P bindings] + (set! assertion-count (+ assertion-count 1)) + (F expr) + on-add.expr)) #:retract (lambda (_handle) (set! assertion-count (- assertion-count 1)) @@ -77,16 +77,16 @@ (assert (Observe (:pattern P) (object #:name 'field-name - [#:asserted bindings - (match-define (list #,@(analyse-pattern-bindings #'P)) bindings) - (define v expr) - (define-values (bag1 outcome1) (bag-change (F) v 1)) - (F bag1) - (when (eq? outcome1 'absent->present) on-add.expr) - #:retracted - (define-values (bag2 outcome2) (bag-change (F) v -1)) - (F bag2) - (when (eq? outcome2 'present->absent) on-remove.expr)])))))])) + [#:asserted* bindings + (pattern-binding-let [P bindings] + (define v expr) + (define-values (bag1 outcome1) (bag-change (F) v 1)) + (F bag1) + (when (eq? outcome1 'absent->present) on-add.expr) + (lambda () + (define-values (bag2 outcome2) (bag-change (F) v -1)) + (F bag2) + (when (eq? outcome2 'present->absent) on-remove.expr)))])))))])) (-define-query (query-set field-name args ...) (set) query-set*) @@ -99,16 +99,16 @@ (assert (Observe (:pattern P) (object #:name 'field-name - [#:asserted bindings - (match-define (list #,@(analyse-pattern-bindings #'P)) bindings) - (define v expr) - (when (eq? (bag-change! b v 1) 'absent->present) - (F (set-add (F) v)) - on-add.expr) - #:retracted - (when (eq? (bag-change! b v -1) 'present->absent) - (F (set-remove (F) v)) - on-remove.expr)])))))])) + [#:asserted* bindings + (pattern-binding-let [P bindings] + (define v expr) + (when (eq? (bag-change! b v 1) 'absent->present) + (F (set-add (F) v)) + on-add.expr) + (lambda () + (when (eq? (bag-change! b v -1) 'present->absent) + (F (set-remove (F) v)) + on-remove.expr)))])))))])) (-define-query (query-hash field-name args ...) (hash) query-hash*) @@ -120,21 +120,21 @@ (assert (Observe (:pattern P) (object #:name 'field-name - [#:asserted bindings - (match-define (list #,@(analyse-pattern-bindings #'P)) bindings) - (define k key-expr) - (define v value-expr) - (when (hash-has-key? (F) k) - (log-warning - "query-hash: field ~s with pattern ~s: overwriting existing entry ~s" - 'field-name - 'P - k)) - (F (hash-set (F) k v)) - on-add.expr - #:retracted - (F (hash-remove (F) k)) - on-remove.expr])))))])) + [#:asserted* bindings + (pattern-binding-let [P bindings] + (define k key-expr) + (define v value-expr) + (when (hash-has-key? (F) k) + (log-warning + "query-hash: field ~s with pattern ~s: overwriting existing entry ~s" + 'field-name + 'P + k)) + (F (hash-set (F) k v)) + on-add.expr + (lambda () + (F (hash-remove (F) k)) + on-remove.expr))])))))])) (define-syntax-rule (define/query-value id ae P x ...) (define id (query-value id ae P x ...))) (define-syntax-rule (define/query-count id P x ...) (define id (query-count id P x ...))) diff --git a/syndicate/syntax.rkt b/syndicate/syntax.rkt index 54644d3..c373710 100644 --- a/syndicate/syntax.rkt +++ b/syndicate/syntax.rkt @@ -141,6 +141,14 @@ body+ ... #f] ] [more ...])] + [(_ name input is-message? [completed ...] + [ [#:asserted* pat body ...] more ... ]) + #`(-object-clauses name + input + is-message? + [ completed ... [(-object-pattern pat) #:when (not is-message?) body ...] ] + [more ...])] + [(_ name input is-message? [completed ...] [ [#:asserted pat body+ ... #:retracted body- ...] more ... ]) #`(-object-clauses name @@ -342,16 +350,16 @@ (Observe (:pattern pat) (ref (entity #:message (lambda (bindings) - (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings) - expr ...)))))))] + (pattern-binding-let [pat bindings] + expr ...))))))))] [(_ ((~datum asserted) condition: pat) expr ...) (quasisyntax/loc stx (assert #:when condition.E (Observe (:pattern pat) (ref (entity #:assert (lambda (bindings _handle) - (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings) - expr ...))))))] + (pattern-binding-let [pat bindings] + expr ...)))))))] [(_ ((~datum retracted) condition: pat) expr ...) (quasisyntax/loc stx (assert #:when condition.E @@ -362,10 +370,10 @@ (hash-set! assertion-map handle bindings)) #:retract (lambda (handle) - (match-define (list #,@(analyse-pattern-bindings #'pat)) - (hash-ref assertion-map handle)) - (hash-remove! assertion-map handle) - expr ...)))))))] + (pattern-binding-let + [pat (hash-ref assertion-map handle)] + (hash-remove! assertion-map handle) + expr ...))))))))] [(_ (expander args ...) body ...) #:when (event-expander-form? #'(expander args ...)) (event-expander-transform #'(expander [args ...] body ...) (lambda (r) (syntax-rearm r stx)))] [_ @@ -378,8 +386,8 @@ (quasisyntax/loc stx (assert (Observe (:pattern pat) (ref (during* (lambda (bindings) - (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings) - expr ...))))))]))) + (pattern-binding-let [pat bindings] + expr ...)))))))]))) (define-syntax during/spawn (lambda (stx) @@ -388,8 +396,8 @@ (quasisyntax/loc stx (assert (Observe (:pattern pat) (ref (during* (lambda (bindings) - (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings) - (spawn/link expr ...)))))))]))) + (pattern-binding-let [pat bindings] + (spawn/link expr ...))))))))]))) (define (during* f #:name [name '?]) (define assertion-map (make-hash))