syndicate-rkt/syndicate/syntax.rkt

;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>

#lang racket/base

(provide this-turn
         this-facet
         this-actor

         entity
         actor-system

         ref
         react
         define-field
         stop-facet
         stop-current-facet
         on-start
         on-stop
         sync!
         send!
         spawn

         begin/dataflow
         define/dataflow
         stop-when-true
         entity/stop-on-retract

         this-target
         at
         assert
         stop-when
         (rename-out [event:when when])
         during
         during/spawn
         during*)

(require racket/match)
(require racket/stxparam)
(require (for-syntax racket/base))
(require (for-syntax racket/syntax))
(require (for-syntax syntax/parse))
(require preserves-schema)

(require "actor.rkt")
(require (prefix-in actor: "actor.rkt"))
(require "entity-ref.rkt")

(require "event-expander.rkt")
(require "pattern.rkt")
(require "syntax-classes.rkt")

(define-syntax this-turn
  (make-set!-transformer
   (lambda (stx)
     (syntax-case stx ()
       [id
        (identifier? #'id)
        #'(or (current-turn) (error 'this-turn "Illegal use outside an Actor turn"))]))))

(define-syntax-rule (with-this-turn turn-expr expr ...)
  (parameterize ([current-turn turn-expr])
    expr ...))

(define-syntax this-facet
  (syntax-id-rules ()
    [_ (turn-active-facet this-turn)]))

(define-syntax this-actor
  (syntax-id-rules ()
    [_ (facet-actor this-facet)]))

(define-syntax (actor-system stx)
  (syntax-parse stx
    [(_ name:<name> expr ...)
     #'(actor:actor-system #:name name.N (lambda () expr ...))]))

(define (ref entity)
  (entity-ref this-facet entity '()))

(define-syntax-rule (react setup-expr ...)
  (turn-facet! this-turn (lambda () setup-expr ...)))

(define-syntax-rule (define-field id initial-value)
  (define id (turn-field! this-turn 'id initial-value)))

(define-syntax stop-facet
  (syntax-rules ()
    [(_ f) (turn-stop! this-turn f)]
    [(_ f expr ...) (turn-stop! this-turn f (lambda () expr ...))]))

(define-syntax-rule (stop-current-facet expr ...)
  (stop-facet this-facet expr ...))

(define-syntax-rule (on-start expr ...)
  (facet-on-end-of-turn! this-facet (lambda () expr ...)))

(define-syntax-rule (on-stop expr ...)
  (facet-on-stop! this-facet (lambda () expr ...)))

(define-syntax-rule (sync! peer expr ...)
  (turn-sync! this-turn peer (lambda (_reply) expr ...)))

(define-syntax-rule (send! peer assertion)
  (turn-message! this-turn peer (->preserve assertion)))

(define-syntax (spawn stx)
  (syntax-parse stx
    [(_ name:<name> daemon:<daemon?>)
     (raise-syntax-error #f "Need body in spawn")]
    [(_ name:<name> daemon:<daemon?> setup-expr ...)
     #'(turn-spawn! #:name name.N
                    #:daemon? daemon.D
                    this-turn
                    (lambda () setup-expr ...))]))

(define-syntax-rule (begin/dataflow expr ...)
  (turn-dataflow! this-turn (lambda () expr ...)))

(define-syntax-rule (define/dataflow id expr)
  (begin (define-field id #f)
         (begin/dataflow (id expr))))

(define-syntax-rule (stop-when-true test expr ...)
  (begin/dataflow
    (when test
      (stop-current-facet expr ...))))

(define (entity/stop-on-retract #:name [name 'stop-on-retract] [k void])
  (entity #:name name #:retract (lambda (_handle) (stop-current-facet (k)))))

;;---------------------------------------------------------------------------

(define-for-syntax orig-insp
  (variable-reference->module-declaration-inspector (#%variable-reference)))

(define-syntax-parameter this-target
  (lambda (stx)
    (raise-syntax-error #f "Illegal use outside an `at` expression" stx)))

(define-syntax (at stx)
  (syntax-case stx ()
    [(_ target-expr items ...)
     #`(let ((target target-expr))
         (syntax-parameterize ([this-target (make-rename-transformer #'target)])
           #,@(for/list [(item-stx (in-list (syntax->list #'(items ...))))]
                (let loop ((item-stx item-stx))
                  (define disarmed-item-stx (syntax-disarm item-stx orig-insp))
                  (syntax-case disarmed-item-stx ()
                    [(expander args ...)
                     (event-expander-id? #'expander)
                     (event-expander-transform disarmed-item-stx
                                               (lambda (r) (loop (syntax-rearm r item-stx))))]
                    [_
                     item-stx])))))]))

(define-event-expander assert
  (lambda (stx)
    (syntax-parse stx
      [(_ condition:<when> expr)
       #`(turn-assert/dataflow! this-turn
                                this-target
                                (lambda ()
                                  (if condition.E
                                      (->preserve expr)
                                      (void))))])))

(define-event-expander stop-when
  (syntax-rules ()
    [(_ event expr ...)
     (event:when event (stop-current-facet expr ...))]))

(require "schemas/gen/dataspace.rkt")

(define-event-expander event:when
  (lambda (stx)
    (syntax-case stx (message asserted retracted)
      [(_ (message pat) expr ...)
       #`(assert (Observe (:pattern pat)
                          (ref (entity #:message
                                       (lambda (bindings)
                                         (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
                                         expr ...)))))]
      [(_ (asserted pat) expr ...)
       #`(assert (Observe (:pattern pat)
                          (ref (entity #:assert
                                       (lambda (bindings _handle)
                                         (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
                                         expr ...)))))]
      [(_ (retracted pat) expr ...)
       #`(assert (Observe (:pattern pat)
                          (let ((assertion-map (make-hash)))
                            (ref (entity #:assert
                                         (lambda (bindings handle)
                                           (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 ...))))))]))
  (syntax-rules ()
    [(_ test expr ...)
     (when test expr ...)]))

(define-event-expander during
  (lambda (stx)
    (syntax-case stx ()
      [(_ pat expr ...)
       #`(assert (Observe (:pattern pat)
                          (ref (during* (lambda (bindings)
                                          (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
                                          expr ...)))))])))

(define-event-expander during/spawn
  (lambda (stx)
    (syntax-parse stx
      [(_ pat name-stx:<name> daemon:<daemon?> expr ...)
       #`(assert
          (Observe (:pattern pat)
                   (ref (during*
                         (lambda (bindings)
                           (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
                           (define name name-stx.N)
                           (define monitor
                             (ref (entity/stop-on-retract #:name (list name 'monitor-in-parent))))
                           (define monitor-handle (turn-assert! this-turn monitor 'alive))
                           (turn-spawn! this-turn
                                        #:name name
                                        #:daemon? daemon.D
                                        #:link
                                        (entity/stop-on-retract #:name
                                                                (list name 'monitor-in-child))
                                        (lambda () expr ...)
                                        (hasheq monitor-handle #t)))))))])))

(define (during* f #:name [name '?])
  (define assertion-map (make-hash))
  (entity #:name name
          #:assert
          (lambda (value handle)
            (let ((facet (react (facet-prevent-inert-check! this-facet)
                                (f value))))
              (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
          (lambda (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:
;;; eval: (put 'actor-system/dataspace 'racket-indent-function 1)
;;; eval: (put 'at 'racket-indent-function 1)
;;; eval: (put 'react 'racket-indent-function 0)
;;; eval: (put 'spawn 'racket-indent-function 0)
;;; eval: (put 'stop-when 'racket-indent-function 1)
;;; eval: (put 'stop-when-true 'racket-indent-function 1)
;;; End: