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

         ref
         react
         let-event
         define-field
         stop-actor-system
         stop-facet
         stop-current-facet
         on-start
         on-stop
         sync!
         send!
         spawn
         spawn/link

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

         this-target
         at
         assert
         once
         stop-on
         on
         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 "entity-ref.rkt")

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

(define-logger syndicate/object) ;; used by the (object) macro

(define-syntax this-turn
  (make-set!-transformer
   (lambda (stx)
     (syntax-case stx ()
       [id
        (identifier? #'id)
        #'(this-turn*)]))))

(define (this-turn*)
  (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 ...)
     #'(make-actor-system #:name name.N (lambda () expr ...))]))

(define-syntax (actor-group stx)
  (syntax-parse stx
    [(_ name:<name> link:<link?> group-boot-expr ...)
     #'(make-actor-group #:name name.N
                         #:link? link.L
                         (lambda () group-boot-expr ...))]))

(define-syntax (object stx)
  (syntax-parse stx
    [(_ name-stx:<name> handler ...)
     #`(let ((state (make-hash)))
         (define name name-stx.N)
         (define (handler-function assertion is-message?)
           (-object-clauses name assertion is-message?  [] [handler ...]))
         (ref (entity #:name name
                      #: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 #f))
  (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 #t))
  (when k
    (k)))

(define-syntax (-object-clauses stx)
  (syntax-parse stx
    [(_ name input is-message? [completed ...]
        [])
     #'(match input
         completed ...
         [_
          (log-syndicate/object-debug "Unhandled ~a ~v in ~v"
                                      (if is-message? "message" "assertion")
                                      input name)
          #f])]

    [(_ name input is-message? [completed ...]
        [ [#:message pat body+ ...] more ... ])
     #'(-object-clauses name
                        input
                        is-message?
                        [ completed ... [(-object-pattern pat) #:when is-message?
                                         body+ ... #f] ]
                        [more ...])]

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

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

    [(_ name input is-message? [completed ...]
        [ [pat body ...] more ... ])
     #'(-object-clauses name
                        input
                        is-message?
                        [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! (lambda () setup-expr ...)))

(define-syntax (let-event stx)
  (syntax-parse stx
    [(_ [] body ...)
     #'(begin body ...)]
    [(_ [#:do expr e ...] body ...)
     #'(begin expr (let-event [e ...] body ...))]
    [(_ [e0 e ...] body ...)
     #'(react (stop-on e0 (let-event [e ...] body ...)))]))

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

(define (stop-actor-system)
  (turn-stop-actor-system! this-turn))

(define-syntax stop-facet
  (syntax-rules ()
    [(_ f) (turn-stop! f)]
    [(_ f expr ...) (turn-stop! 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 (sync! stx)
  (syntax-parse stx
    [(_ peer expr ...)
     (syntax/loc stx (turn-sync! this-turn peer (lambda (_reply) expr ...)))]))

(define-for-syntax (with-valid-this-target orig-stx result-stx)
  ;; Invoke this-target transformer for its side effect: when it's
  ;; illegal to use it, it will signal an error.
  (let ((v (syntax-parameter-value #'this-target)))
    (when (procedure? v)
      (v orig-stx)))
  result-stx)

(define-syntax (send! stx)
  (syntax-parse stx
    [(_ peer assertion)
     (syntax/loc stx (turn-message! this-turn peer (->preserve assertion)))]
    [(_ assertion)
     (with-valid-this-target stx
       (syntax/loc stx (send! this-target assertion)))]))

(define-syntax (spawn stx)
  (syntax-parse stx
    [(_ matches:<matches> condition:<when> name:<name> daemon:<daemon?>)
     (raise-syntax-error #f "Need body in spawn")]
    [(_ matches:<matches> condition:<when> name:<name> daemon:<daemon?> setup-expr ...)
     #'(nested-matches
        [[matches.pattern-pieces ... matches.discriminant] ...]
        (when condition.E
          (turn-spawn! #:name name.N
                       #:daemon? daemon.D
                       this-turn
                       (lambda ()
                         (syntax-parameterize ([this-target illegal-use-of-this-target])
                           setup-expr ...)))))]))

(define-syntax (spawn/link stx)
  (syntax-parse stx
    [(_ matches:<matches> condition:<when> name-stx:<name> daemon:<daemon?> setup-expr ...)
     #`(nested-matches
        [[matches.pattern-pieces ... matches.discriminant] ...]
        (when condition.E
          (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 ()
                         (syntax-parameterize ([this-target illegal-use-of-this-target])
                           setup-expr ...))
                       (hasheq monitor-handle #t))))]))

(define-syntax nested-matches
  (syntax-rules ()
    [(_ [] body ...)
     (begin body ...)]
    [(_ [[p ... e] more ...] body ...)
     (match e [p ... (nested-matches [more ...] body ...)] [_ (void)])]))

(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-on-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-for-syntax illegal-use-of-this-target
  (lambda (stx)
    (raise-syntax-error 'this-target "Illegal use outside an `at` expression" stx)))

(define-syntax-parameter this-target illegal-use-of-this-target)

(define-syntax (at stx)
  (syntax-case stx ()
    [(_ target-expr items ...)
     #`(let ((target target-expr))
         (syntax-parameterize ([this-target (make-rename-transformer #'target)])
           items ...))]))

(define-syntax assert
  (lambda (stx)
    (syntax-parse stx
      [(_ condition:<when> expr)
       (with-valid-this-target stx
         (quasisyntax/loc stx
           (turn-assert/dataflow! this-turn
                                  this-target
                                  #,(quasisyntax/loc #'expr
                                      (lambda () (if condition.E
                                                     (->preserve expr)
                                                     (void)))))))])))

(define-syntax-rule (once [event expr ...] ...)
  (react (stop-on event expr ...) ...))

(define-syntax-rule (stop-on event expr ...)
  (on event (stop-current-facet expr ...)))

(require "schemas/dataspace.rkt")

(define-syntax on
  (lambda (stx)
    (define disarmed-stx (syntax-disarm stx orig-insp))
    (syntax-parse disarmed-stx
      [(_ ((~datum message) condition:<when> pat) expr ...)
       (quasisyntax/loc stx
         (assert #:when condition.E
                 #,(quasisyntax/loc #'pat
                     (Observe (:pattern pat)
                              (ref (entity #:message
                                           (lambda (bindings)
                                             (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
                                             expr ...)))))))]
      [(_ ((~datum asserted) condition:<when> pat) expr ...)
       (quasisyntax/loc stx
         (assert #:when condition.E
                 (Observe (:pattern pat)
                          (ref (entity #:assert
                                       (lambda (bindings _handle)
                                         (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
                                         expr ...))))))]
      [(_ ((~datum retracted) condition:<when> pat) expr ...)
       (quasisyntax/loc stx
         (assert #:when condition.E
                 (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 ...)))))))]
      [(_ (expander args ...) body ...) #:when (event-expander-id? #'expander)
       (event-expander-transform #'(expander [args ...] body ...) (lambda (r) (syntax-rearm r stx)))]
      [_
       (raise-syntax-error #f "Invalid event pattern")])))

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

(define-syntax during/spawn
  (lambda (stx)
    (syntax-parse stx
      [(_ pat expr ...)
       (quasisyntax/loc stx
         (assert (Observe (:pattern pat)
                          (ref (during* (lambda (bindings)
                                          (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
                                          (spawn/link 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-group 'racket-indent-function 0)
;;; 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 'on 'racket-indent-function 1)
;;; eval: (put 'react 'racket-indent-function 0)
;;; eval: (put 'send! 'racket-indent-function 1)
;;; eval: (put 'spawn 'racket-indent-function 0)
;;; eval: (put 'stop-on 'racket-indent-function 1)
;;; eval: (put 'stop-on-true 'racket-indent-function 1)
;;; eval: (put 'sync! 'racket-indent-function 1)
;;; End: