;;; 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
         object

         ref
         react
         react/suspend
         until
         define-field
         stop-facet
         stop-current-facet
         on-start
         on-stop
         sync!
         send!
         spawn
         spawn/link

         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-syntax (object stx)
  (syntax-parse stx
    [(_ name:<name> handler ...)
     #`(let ((state (make-hash)))
         (define (handler-function assertion)
           (-object-clauses assertion [] [handler ...]))
         (ref (entity #:name name.N
                      #:assert (lambda (m h) (-object-assert state handler-function m h))
                      #:retract (lambda (h) (-object-retract state h))
                      #:message (lambda (m) (-object-message handler-function m)))))]))

(define (-object-assert state handler-function assertion handle)
  (define k (handler-function assertion))
  (when k (hash-set! state handle k)))

(define (-object-retract state handle)
  (define k (hash-ref state handle #f))
  (when k
    (hash-remove! state handle)
    (k)))

(define (-object-message handler-function message)
  (define k (handler-function message))
  (when k
    (k)))

(define-syntax (-object-clauses stx)
  (syntax-parse stx
    [(_ input [completed ...] [])
     #'(match input
         completed ...
         [_ #f])]

    [(_ input [completed ...] [ [#:spawn pat body ...] more ... ])
     #'(-object-clauses input
                        [completed ...]
                        [ [#:during pat (spawn/link body ...)] more ... ])]

    [(_ input [completed ...] [ [#:asserted pat body+ ... #:retracted body- ...] more ... ])
     #`(-object-clauses input
                        [ completed ... [(-object-pattern pat)
                                         body+ ...
                                         #,(if (null? (syntax->list #'(body- ...)))
                                               #`#f
                                               #`(lambda () body- ...))] ]
                        [more ...])]

    [(_ input [completed ...] [ [#:asserted pat body+ ...] more ... ])
     #'(-object-clauses input
                        [completed ...]
                        [ [#:asserted pat body+ ... #:retracted] more ... ])]

    [(_ input [completed ...] [ [pat body ...] more ... ])
     #'(-object-clauses input
                        [completed ...]
                        [ [#:asserted pat
                           (define f (react (facet-prevent-inert-check! this-facet) body ...))
                           #:retracted
                           (stop-facet f)]
                          more ... ])]))

(define-match-expander -object-pattern
  (lambda (stx)
    (syntax-case stx ()
      [(_ pat-stx)
       (analyse-match-pattern #'pat-stx)])))

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

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

(define-syntax-rule (react/suspend (resume-parent) setup-expr ...)
  (suspend-turn (lambda (resume-parent) (react setup-expr ...))))

(define-syntax-rule (until ds event body ...)
  (react/suspend (continue)
    (at ds (stop-when event (continue (void))))
    body ...))

(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 (spawn/link stx)
  (syntax-parse stx
    [(_ name-stx:<name> daemon:<daemon?> setup-expr ...)
     #`(begin
         (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 () setup-expr ...)
                      (hasheq monitor-handle #t)))]))

(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)
                                          (spawn/link #:name name-stx.N #:daemon? daemon.D expr ...))))))])))

(define (during* f #:name [name '?])
  (define assertion-map (make-hash))
  (entity #:name name
          #:assert
          (lambda (value handle)
            (hash-set! assertion-map
                       handle
                       (react (facet-prevent-inert-check! this-facet)
                              (f value))))
          #:retract
          (lambda (handle)
            (match (hash-ref assertion-map handle #f)
              [#f (void)]
              [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 'object 'racket-indent-function 0)
;;; 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: