syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Allow various kinds of statelike processing during pattern analysis

This commit is contained in:
Tony Garnock-Jones 2022-12-24 21:08:57 +13:00
parent 55e5c36725
commit 2124915de2
3 changed files with 93 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
syndicate/pattern.rkt
View File

@ -18,6 +18,10 @@
!dump-registered-preserves-patterns! !dump-registered-preserves-patterns!
transform-pattern-binding
current-pattern-binding-let
pattern-binding-let
(all-from-out "schemas/dataspacePatterns.rkt")) (all-from-out "schemas/dataspacePatterns.rkt"))
(require (for-syntax racket/base)) (require (for-syntax racket/base))
@ -32,6 +36,7 @@
(require preserves-schema) (require preserves-schema)
(require racket/match) (require racket/match)
(require racket/list) (require racket/list)
(require racket/stxparam)
(require "pattern-expander.rkt") (require "pattern-expander.rkt")
(require "smart-pattern.rkt") (require "smart-pattern.rkt")
(require "schemas/dataspacePatterns.rkt") (require "schemas/dataspacePatterns.rkt")
@ -70,6 +75,23 @@
(define-for-syntax orig-insp (define-for-syntax orig-insp
(variable-reference->module-declaration-inspector (#%variable-reference))) (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 (begin-for-syntax
(define (dollar-id? stx) (define (dollar-id? stx)
(and (identifier? stx) (and (identifier? stx)
@ -77,7 +99,7 @@
(define (undollar stx) (define (undollar stx)
(and (dollar-id? 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) (define (id=? expected stx)
(and (identifier? stx) (and (identifier? stx)
@ -112,6 +134,9 @@
[(list _) (raise-syntax-error #f "Odd number of elements in hash-like pattern")] [(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))])) [(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 (define (analyse-pattern stx
#:check-destructuring [check-destructuring (lambda (stx) stx)] #:check-destructuring [check-destructuring (lambda (stx) stx)]
#:wrap-literal [wrap-literal (lambda (stx) stx)]) #:wrap-literal [wrap-literal (lambda (stx) stx)])
@ -153,10 +178,10 @@
[id [id
(dollar-id? #'id) (dollar-id? #'id)
#`(Pattern-DBind (DBind (Pattern-DDiscard (DDiscard))))] (transform-binding (undollar #'id) #`(Pattern-DBind (DBind (Pattern-DDiscard (DDiscard)))))]
[($ id p) [($ id p)
#`(Pattern-DBind (DBind #,(walk #'p)))] (transform-binding #'id #`(Pattern-DBind (DBind #,(walk #'p))))]
[id [id
(discard-id? #'id) (discard-id? #'id)
@ -357,3 +382,9 @@
(for [(k (in-list (free-id-table-keys preserves-pattern-registry)))] (for [(k (in-list (free-id-table-keys preserves-pattern-registry)))]
(printf " - ~v\n" k)) (printf " - ~v\n" k))
#'(void))])) #'(void))]))
;;---------------------------------------------------------------------------
;;; Local Variables:
;;; eval: (put 'pattern-binding-let 'racket-indent-function 1)
;;; eval: (put 'current-pattern-binding-let 'racket-indent-function 1)
;;; End:

78
syndicate/query.rkt
View File

@ -56,10 +56,10 @@
(ref (entity #:name 'field-name (ref (entity #:name 'field-name
#:assert #:assert
(lambda (bindings handle) (lambda (bindings handle)
(match-define (list #,@(analyse-pattern-bindings #'P)) bindings) (pattern-binding-let [P bindings]
(set! assertion-count (+ assertion-count 1)) (set! assertion-count (+ assertion-count 1))
(F expr) (F expr)
on-add.expr) on-add.expr))
#:retract #:retract
(lambda (_handle) (lambda (_handle)
(set! assertion-count (- assertion-count 1)) (set! assertion-count (- assertion-count 1))
@ -77,16 +77,16 @@
(assert (assert
(Observe (:pattern P) (Observe (:pattern P)
(object #:name 'field-name (object #:name 'field-name
[#:asserted bindings [#:asserted* bindings
(match-define (list #,@(analyse-pattern-bindings #'P)) bindings) (pattern-binding-let [P bindings]
(define v expr) (define v expr)
(define-values (bag1 outcome1) (bag-change (F) v 1)) (define-values (bag1 outcome1) (bag-change (F) v 1))
(F bag1) (F bag1)
(when (eq? outcome1 'absent->present) on-add.expr) (when (eq? outcome1 'absent->present) on-add.expr)
#:retracted (lambda ()
(define-values (bag2 outcome2) (bag-change (F) v -1)) (define-values (bag2 outcome2) (bag-change (F) v -1))
(F bag2) (F bag2)
(when (eq? outcome2 'present->absent) on-remove.expr)])))))])) (when (eq? outcome2 'present->absent) on-remove.expr)))])))))]))
(-define-query (query-set field-name args ...) (set) query-set*) (-define-query (query-set field-name args ...) (set) query-set*)
@ -99,16 +99,16 @@
(assert (assert
(Observe (:pattern P) (Observe (:pattern P)
(object #:name 'field-name (object #:name 'field-name
[#:asserted bindings [#:asserted* bindings
(match-define (list #,@(analyse-pattern-bindings #'P)) bindings) (pattern-binding-let [P bindings]
(define v expr) (define v expr)
(when (eq? (bag-change! b v 1) 'absent->present) (when (eq? (bag-change! b v 1) 'absent->present)
(F (set-add (F) v)) (F (set-add (F) v))
on-add.expr) on-add.expr)
#:retracted (lambda ()
(when (eq? (bag-change! b v -1) 'present->absent) (when (eq? (bag-change! b v -1) 'present->absent)
(F (set-remove (F) v)) (F (set-remove (F) v))
on-remove.expr)])))))])) on-remove.expr)))])))))]))
(-define-query (query-hash field-name args ...) (hash) query-hash*) (-define-query (query-hash field-name args ...) (hash) query-hash*)
@ -120,21 +120,21 @@
(assert (assert
(Observe (:pattern P) (Observe (:pattern P)
(object #:name 'field-name (object #:name 'field-name
[#:asserted bindings [#:asserted* bindings
(match-define (list #,@(analyse-pattern-bindings #'P)) bindings) (pattern-binding-let [P bindings]
(define k key-expr) (define k key-expr)
(define v value-expr) (define v value-expr)
(when (hash-has-key? (F) k) (when (hash-has-key? (F) k)
(log-warning (log-warning
"query-hash: field ~s with pattern ~s: overwriting existing entry ~s" "query-hash: field ~s with pattern ~s: overwriting existing entry ~s"
'field-name 'field-name
'P 'P
k)) k))
(F (hash-set (F) k v)) (F (hash-set (F) k v))
on-add.expr on-add.expr
#:retracted (lambda ()
(F (hash-remove (F) k)) (F (hash-remove (F) k))
on-remove.expr])))))])) 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-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 ...))) (define-syntax-rule (define/query-count id P x ...) (define id (query-count id P x ...)))

32
syndicate/syntax.rkt
View File

@ -141,6 +141,14 @@
body+ ... #f] ] body+ ... #f] ]
[more ...])] [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 ...] [(_ name input is-message? [completed ...]
[ [#:asserted pat body+ ... #:retracted body- ...] more ... ]) [ [#:asserted pat body+ ... #:retracted body- ...] more ... ])
#`(-object-clauses name #`(-object-clauses name
@ -342,16 +350,16 @@
(Observe (:pattern pat) (Observe (:pattern pat)
(ref (entity #:message (ref (entity #:message
(lambda (bindings) (lambda (bindings)
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings) (pattern-binding-let [pat bindings]
expr ...)))))))] expr ...))))))))]
[(_ ((~datum asserted) condition:<when> pat) expr ...) [(_ ((~datum asserted) condition:<when> pat) expr ...)
(quasisyntax/loc stx (quasisyntax/loc stx
(assert #:when condition.E (assert #:when condition.E
(Observe (:pattern pat) (Observe (:pattern pat)
(ref (entity #:assert (ref (entity #:assert
(lambda (bindings _handle) (lambda (bindings _handle)
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings) (pattern-binding-let [pat bindings]
expr ...))))))] expr ...)))))))]
[(_ ((~datum retracted) condition:<when> pat) expr ...) [(_ ((~datum retracted) condition:<when> pat) expr ...)
(quasisyntax/loc stx (quasisyntax/loc stx
(assert #:when condition.E (assert #:when condition.E
@ -362,10 +370,10 @@
(hash-set! assertion-map handle bindings)) (hash-set! assertion-map handle bindings))
#:retract #:retract
(lambda (handle) (lambda (handle)
(match-define (list #,@(analyse-pattern-bindings #'pat)) (pattern-binding-let
(hash-ref assertion-map handle)) [pat (hash-ref assertion-map handle)]
(hash-remove! assertion-map handle) (hash-remove! assertion-map handle)
expr ...)))))))] expr ...))))))))]
[(_ (expander args ...) body ...) #:when (event-expander-form? #'(expander args ...)) [(_ (expander args ...) body ...) #:when (event-expander-form? #'(expander args ...))
(event-expander-transform #'(expander [args ...] body ...) (lambda (r) (syntax-rearm r stx)))] (event-expander-transform #'(expander [args ...] body ...) (lambda (r) (syntax-rearm r stx)))]
[_ [_
@ -378,8 +386,8 @@
(quasisyntax/loc stx (quasisyntax/loc stx
(assert (Observe (:pattern pat) (assert (Observe (:pattern pat)
(ref (during* (lambda (bindings) (ref (during* (lambda (bindings)
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings) (pattern-binding-let [pat bindings]
expr ...))))))]))) expr ...)))))))])))
(define-syntax during/spawn (define-syntax during/spawn
(lambda (stx) (lambda (stx)
@ -388,8 +396,8 @@
(quasisyntax/loc stx (quasisyntax/loc stx
(assert (Observe (:pattern pat) (assert (Observe (:pattern pat)
(ref (during* (lambda (bindings) (ref (during* (lambda (bindings)
(match-define (list #,@(analyse-pattern-bindings #'pat)) bindings) (pattern-binding-let [pat bindings]
(spawn/link expr ...)))))))]))) (spawn/link expr ...))))))))])))
(define (during* f #:name [name '?]) (define (during* f #:name [name '?])
(define assertion-map (make-hash)) (define assertion-map (make-hash))