#lang racket/base

(provide this-turn
         this-facet
         this-actor

         action

         entity
         actor-system

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

         begin/dataflow
         define/dataflow

         this-target
         at
         assert
         (rename-out [event:when when])
         during)

(require racket/match)
(require racket/stxparam)
(require (for-syntax racket/base))
(require (for-syntax racket/syntax))

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

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

(define-syntax-parameter this-turn
  (lambda (stx)
    (raise-syntax-error #f "Illegal use outside an Actor turn" stx)))

(define-syntax-rule (with-this-turn id expr ...)
  (syntax-parameterize ([this-turn (make-rename-transformer #'id)])
    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-rule (action formals expr ...)
  (lambda (turn . formals)
    (with-this-turn turn expr ...)))

(define-syntax-rule (actor-system expr ...)
  (actor:actor-system (action () expr ...)))

(define-syntax-rule (with-fresh-turn expr ...)
  (turn-freshen this-turn (action () expr ...)))

(define-syntax-rule (ref e)
  (turn-ref this-turn e))

(define-syntax-rule (react setup-expr ...)
  (turn-facet! this-turn (action () 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 (action () expr ...))]))

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

(define-syntax-rule (on-start expr ...)
  ;; TODO: delay to end of turn (?)
  (begin expr ...))

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

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

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

(define-syntax-rule (spawn setup-expr ...)
  (turn-spawn! this-turn (action () setup-expr ...)))

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

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

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

(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 Actor turn" 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
  (syntax-rules ()
    [(_ 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 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 ...)]))

(define-event-expander during
  (lambda (stx)
    (syntax-case stx ()
      [(_ 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:
;;; eval: (put 'action 'scheme-indent-function 1)
;;; eval: (put 'action 'racket-indent-function 1)
;;; End: