From b77fe3efbc8db8b0908804a2e856212ce3a8c626 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 2 Jun 2021 13:11:26 +0200 Subject: [PATCH] Steps towards using :pattern/:template in syntax --- syndicate/go.rkt | 27 +++++++------ syndicate/syntax.rkt | 90 ++++++++++++++++++++------------------------ 2 files changed, 54 insertions(+), 63 deletions(-) diff --git a/syndicate/go.rkt b/syndicate/go.rkt index 03c585c..bf64bfb 100644 --- a/syndicate/go.rkt +++ b/syndicate/go.rkt @@ -17,8 +17,8 @@ (define start-time (current-inexact-milliseconds)) (define prev-value 0) (at ds - (assert (BoxState->preserves (BoxState (value)))) - (when (message (SetBox new-value)) + (assert (BoxState (value))) + (when (message (SetBox $new-value)) (when (zero? (remainder new-value REPORT_EVERY)) (define end-time (current-inexact-milliseconds)) (define delta (/ (- end-time start-time) 1000.0)) @@ -35,7 +35,7 @@ (spawn (define root-facet this-facet) (define count 0) (at ds - (when (asserted (BoxState value)) + (when (asserted (BoxState $value)) (send! ds (SetBox->preserves (SetBox (+ value 1))))) ;; (during (BoxState _) ;; (on-start (set! count (+ count 1))) @@ -43,17 +43,16 @@ ;; (when (zero? count) ;; (log-info "Client detected box termination") ;; (stop-facet root-facet)))) - (assert (Observe->preserves - (Observe 'BoxState - (ref (entity #:assert - (action (_v _h) - (set! count (+ count 1))) - #:retract - (action (_h) - (set! count (- count 1)) - (when (zero? count) - (log-info "Client detected box termination") - (stop-facet root-facet)))))))) + (assert (Observe 'BoxState + (ref (entity #:assert + (action (_v _h) + (set! count (+ count 1))) + #:retract + (action (_h) + (set! count (- count 1)) + (when (zero? count) + (log-info "Client detected box termination") + (stop-facet root-facet))))))) ;; (during (BoxState _) ;; (on-stop (log-info "Client detected box termination") ;; (stop-facet root-facet))) diff --git a/syndicate/syntax.rkt b/syndicate/syntax.rkt index 2097ebc..10110e3 100644 --- a/syndicate/syntax.rkt +++ b/syndicate/syntax.rkt @@ -39,6 +39,7 @@ (require (prefix-in actor: "actor.rkt")) (require "event-expander.rkt") +(require "pattern.rkt") (define-syntax-parameter this-turn (lambda (stx) @@ -134,31 +135,25 @@ (define-event-expander assert (syntax-rules () [(_ expr) - (turn-assert/dataflow! this-turn this-target (action () expr))])) + (turn-assert/dataflow! this-turn this-target (action () (:template expr)))])) (require "schemas/gen/dataspace.rkt") (define-event-expander event:when (lambda (stx) (syntax-case stx (message asserted) - [(_ (message (label fields ...)) expr ...) - #`(assert (Observe->preserves - (Observe 'label - (ref (entity #:message - (action (rec) - (match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec) - [(? eof-object?) (void)] - [(label fields ...) - expr ...])))))))] - [(_ (asserted (label fields ...)) expr ...) - #`(assert (Observe->preserves - (Observe 'label - (ref (entity #:assert - (action (rec handle) - (match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec) - [(? eof-object?) (void)] - [(label fields ...) - expr ...])))))))])) + [(_ (message pat) expr ...) + #`(assert (Observe (:pattern pat) + (ref (entity #:message + (action (bindings) + (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings) + expr ...)))))] + [(_ (asserted pat) expr ...) + #`(assert (Observe (:pattern pat) + (ref (entity #:assert + (action (bindings _handle) + (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings) + expr ...)))))])) (syntax-rules () [(_ test expr ...) (when test expr ...)])) @@ -166,36 +161,33 @@ (define-event-expander during (lambda (stx) (syntax-case stx () - [(_ (label fields ...) expr ...) - #`(assert (Observe->preserves - (Observe 'label - (ref (let ((assertion-map (make-hash))) - (entity #:assert - (action (rec handle) - (match (#,(format-id #'label "parse-~a" (syntax-e #'label)) rec) - [(? eof-object?) (void)] - [(label fields ...) - (let ((facet (react - (facet-prevent-inert-check! this-facet) - expr ...))) - (match (hash-ref assertion-map handle #f) - [#f - (hash-set! assertion-map handle facet)] - ['dead - (hash-remove! assertion-map handle) - (stop-facet facet)] - [_ - (error 'during "Duplicate assertion handle ~a" handle)]))])) - #:retract - (action (handle) - (match (hash-ref assertion-map handle #f) - [#f - (hash-set! assertion-map handle 'dead)] - ['dead - (error 'during "Duplicate retraction handle ~a" handle)] - [facet - (hash-remove! assertion-map handle) - (stop-facet facet)]))))))))]))) + [(_ pat expr ...) + #`(assert (Observe (:pattern pat) + (ref (let ((assertion-map (make-hash))) + (entity #:assert + (action (bindings handle) + (match-define (list #,(analyse-pattern-bindings #'pat)) bindings) + (let ((facet (react + (facet-prevent-inert-check! this-facet) + expr ...))) + (match (hash-ref assertion-map handle #f) + [#f + (hash-set! assertion-map handle facet)] + ['dead + (hash-remove! assertion-map handle) + (stop-facet facet)] + [_ + (error 'during "Duplicate assertion handle ~a" handle)]))) + #:retract + (action (handle) + (match (hash-ref assertion-map handle #f) + [#f + (hash-set! assertion-map handle 'dead)] + ['dead + (error 'during "Duplicate retraction handle ~a" handle)] + [facet + (hash-remove! assertion-map handle) + (stop-facet facet)])))))))]))) ;;--------------------------------------------------------------------------- ;;; Local Variables: