#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
         stop-when-true

         this-target
         at
         assert
         stop-when
         (rename-out [event:when when])
         during
         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 actor-system
  (syntax-rules ()
    [(_ #:name name expr ...)
     (actor:actor-system #:name name (action () expr ...))]
    [(_ 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 (:template assertion)))

(define-syntax spawn
  (syntax-rules ()
    [(_ #:name name setup-expr ...)
     (turn-spawn! #:name name this-turn (action () setup-expr ...))]
    [(_ 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-syntax-rule (stop-when-true test expr ...)
  (begin/dataflow
    (when test
      (stop-current-facet 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)))]))

(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
                                       (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 ...)))))]
      [(_ (retracted pat) expr ...)
       #`(assert (Observe (:pattern pat)
                          (let ((assertion-map (make-hash)))
                            (ref (entity #:assert
                                         (action (bindings handle)
                                           (hash-set! assertion-map handle bindings))
                                         #:retract
                                         (action (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* (action (bindings)
                                          (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
                                          expr ...)))))])))

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