#lang racket/base

;; TODO: syntax-id-rules: raise-syntax-error on set!, pointing users
;; to the #:update pseudo-action.

;; TODO: enforce presence of #:arguments, and enforce that it declares
;; all the free variables in the actor.

(provide actor
	 observe-gestalt
	 observe-subscribers
	 observe-advertisers
	 advertise
	 subscribe
	 for/advertise
	 for/subscribe
	 define-transition
	 begin-transition
	 noop-transition)

;; (require (for-syntax racket/pretty))
;; (require (for-syntax racket/trace))

(require racket/set)
(require racket/match)

(require (for-syntax racket/match))
(require (for-syntax racket/list))
(require (for-syntax racket/base))
(require (for-syntax syntax/stx))

(require racket/stxparam)
(require racket/splicing)

(require "core.rkt")
(require "gestalt.rkt")

(define-syntax (actor stx)
  (syntax-case stx ()
    [(_ forms ...)
     (analyze-actor #'(forms ...))]))

(define-syntax (observe-gestalt stx) (raise-syntax-error #f "Use of observe-gestalt outside actor form" stx))
(define-syntax (observe-subscribers stx) (raise-syntax-error #f "Use of observe-subscribers outside actor form" stx))
(define-syntax (observe-advertisers stx) (raise-syntax-error #f "Use of observe-advertisers outside actor form" stx))
(define-syntax (advertise stx) (raise-syntax-error #f "Use of advertise outside actor form" stx))
(define-syntax (subscribe stx) (raise-syntax-error #f "Use of subscribe outside actor form" stx))
(define-syntax (for/advertise stx) (raise-syntax-error #f "Use of for/advertise outside actor form" stx))
(define-syntax (for/subscribe stx) (raise-syntax-error #f "Use of for/subscribe outside actor form" stx))

(define-syntax-parameter update-state-struct #f)
(define-syntax-parameter match-state #f)
(define-syntax-parameter update-gestalt #f)

(define-syntax-rule (define-transition head tail ...)
  (define head (begin-transition tail ...)))

(define-syntax (begin-transition stx)
  (syntax-case stx ()
    [(_ forms ...)
     (let ()
       (define result (accumulate-actions (gensym 'begin-transition) '() '() #'(forms ...)))
       ;; (pretty-print `(result ,(syntax->datum result)))
       result)]))

(define (noop-transition state)
  (transition state '()))

(begin-for-syntax

 (define-syntax-rule (define-temporaries [tempvar basestx] ...)
   (match-define (list tempvar ...) (generate-temporaries (list basestx ...))))

 (define (identifier-append ctxt . pieces)
   (and ctxt (datum->syntax ctxt
			    (string->symbol
			     (apply string-append
				    (for/list [(piece pieces)]
				      (symbol->string (if (syntax? piece) (syntax->datum piece) piece))))))))

 (define (analyze-pattern pat-stx)
   (syntax-case pat-stx ($ quasiquote unquote quote)
     ;; Extremely limited support for quasiquoting and quoting
     [(quasiquote (unquote p)) (analyze-pattern #'p)]
     [(quasiquote (p ...)) (analyze-pattern #'(list (quasiquote p) ...))]
     [(quasiquote p) (values #''p #''p #''p '())]
     [(quote p) (values #''p #''p #''p '())]

     [($ v)
      (values #'(?!)
	      #'?
	      #'v
	      (list #'v))]
     [($ v p)
      (let ()
	(define-values (pr g m bs) (analyze-pattern #'p))
	(when (not (null? bs))
	  (raise-syntax-error #f "nested bindings not supported" pat-stx))
	(values #`(?! #,pr)
		g
		#`(and v #,m)
		(list #'v)))]
     [(ctor p ...)
      (let ()
	(define parts (if (identifier? #'ctor) #'(p ...) #'(ctor p ...)))
	(define-values (pr g m bs)
	  (for/fold [(pr '()) (g '()) (m '()) (bs '())] [(p (syntax->list parts))]
	    (define-values (pr1 g1 m1 bs1) (analyze-pattern p))
	    (values (cons pr1 pr)
		    (cons g1 g)
		    (cons m1 m)
		    (append bs1 bs))))
	(if (identifier? #'ctor)
	    (values (cons #'ctor (reverse pr))
		    (cons #'ctor (reverse g))
		    (cons #'ctor (reverse m))
		    bs)
	    (values (reverse pr)
		    (reverse g)
		    (reverse m)
		    bs)))]
     [non-pair
      (if (and (identifier? #'non-pair)
	       (free-identifier=? #'non-pair #'?))
	  (values #'?
		  #'?
		  #'_
		  '())
	  (values #'non-pair
		  #'non-pair
		  #'(== non-pair)
		  '()))]))

 (struct observer
	 (condition level meta-level presence-name set-name set-exp added-name removed-name)
	 #:transparent)

 (struct participator (condition meta-level) #:transparent)

 (define (analyze-actor forms-stx)
   (define actor-name #f)

   ;; (Listof Identifier)
   ;; Names for actor state values. User-supplied identifiers.
   (define statevars '())

   ;; (Listof Identifier)
   ;; Temporaries usable for internal bindings of state values. Computed, fresh identifiers.
   (define statetemps '())

   ;; (Listof Syntax)
   ;; Fragments computing gestalt of the actor. Each is in transition context.
   ;; State bindings and body definitions are in scope.
   (define gestalt-updaters '())

   ;; (Listof Syntax)
   ;; Fragments used to assemble gestalt of the actor. Each is in expression context.
   ;; State bindings and body definitions are in scope.
   (define gestalt-fragments '())

   ;; (Listof (Syntax -> Syntax))
   ;; Sequence of functions generating expressions yielding
   ;; transition-functions for responding to events.
   ;; State bindings and body definitions are in scope.
   (define event-handlers '())

   ;; (Listof Identifier)
   ;; Names for body-definitions representing actions to take on actor bootup.
   (define action-ids '())

   ;; (Listof Syntax)
   ;; Body definition forms.
   (define body-forms '())

   (define-syntax-rule (push! var val) (set! var (cons val var)))
   (define-syntax-rule (push-many! var vals ...) (set! var (append vals ... var)))

   (define (push-statevar! statevar-stx statetemp-stx stateexp-stx)
     (push! statevars statevar-stx)
     (push! statetemps statetemp-stx)
     (push! body-forms #`(define #,statetemp-stx #,stateexp-stx)))

   (define (walk-forms forms-stx)
     (syntax-case forms-stx (observe-gestalt
			     observe-subscribers
			     observe-advertisers
			     advertise
			     subscribe
			     for/advertise
			     for/subscribe)
       [() (build-result)]

       [(#:name name rest ...) ;; TODO: named processes
	(begin (when actor-name (raise-syntax-error #f "duplicate actor #:name" forms-stx))
	       (unless (identifier? #'name)
		 (raise-syntax-error #f "actor #:name must be an identifier" #'name))
	       (set! actor-name #'name)
	       (walk-forms #'(rest ...)))]

       [(#:arguments [arg ...] rest ...) ;; TODO arguments
	(walk-forms #'(rest ...))]

       [(#:state [statevar stateexp] rest ...)
	(begin (define-temporaries [statetemp #'statevar])
	       (push-statevar! #'statevar statetemp #'stateexp)
	       (walk-forms #'(rest ...)))]

       [((observe-gestalt g [pattern body ...] ...) rest ...)
	(begin (analyze-general-observer! #'g #'([pattern (begin-transition body ...)] ...))
	       (walk-forms #'(rest ...)))]

       [((observe-subscribers pat body ...) rest ...)
	(begin (analyze-observation! #'pat #'(body ...) #t)
	       (walk-forms #'(rest ...)))]

       [((observe-advertisers pat body ...) rest ...)
	(begin (analyze-observation! #'pat #'(body ...) #f)
	       (walk-forms #'(rest ...)))]

       [((advertise pat body ...) rest ...)
	(begin (analyze-participation! #'pat #'(body ...) #t)
	       (walk-forms #'(rest ...)))]

       [((subscribe pat body ...) rest ...)
	(begin (analyze-participation! #'pat #'(body ...) #f)
	       (walk-forms #'(rest ...)))]

       [((for/advertise [loopspec ...] pat body ...) rest ...)
	(begin (analyze-group-participation! #'(loopspec ...) #'pat #'(body ...) #t)
	       (walk-forms #'(rest ...)))]

       [((for/subscribe [loopspec ...] pat body ...) rest ...)
	(begin (analyze-group-participation! #'(loopspec ...) #'pat #'(body ...) #f)
	       (walk-forms #'(rest ...)))]

       [(expr rest ...)
	(syntax-case (expand-in-context (gensym 'actor-initialization) #'expr) ()
	  [(head inner-rest ...)
	   (if (or (free-identifier=? #'head #'begin)
		   (free-identifier=? #'head #'begin-transition))
	       (walk-forms #'(inner-rest ... rest ...))
	       (if (ormap (lambda (i) (free-identifier=? #'head i))
			  (syntax->list #'(define-values define-syntaxes begin-for-syntax
					    module module*
					    #%module-begin
					    #%require #%provide)))
		   (begin (push! body-forms #'expr)
			  (walk-forms #'(rest ...)))
		   (begin (push-action! #'expr)
			  (walk-forms #'(rest ...)))))]
	  [non-pair-syntax
	   (begin (push-action! #'expr)
		  (walk-forms #'(rest ...)))])]))

   (define (defbinding name-stx init-name-stx init-exp)
     (list #`(define #,init-name-stx #,init-exp)))

   (define-syntax-rule (analyze-body* self body-stx struct-type o [keyword accessor fieldname] ...)
     (syntax-case body-stx ()
       [(keyword v rest (... ...))
	(if (accessor o)
	    (raise-syntax-error #f (format "duplicate ~a clause" 'keyword) body-stx)
	    (self #'(rest (... ...)) (struct-copy struct-type o [fieldname #'v])))]
       ...
       [other (values o #'other)]))

   (define (analyze-observer-body body-stx o)
     (analyze-body* analyze-observer-body body-stx observer o
		    [#:when observer-condition condition]
		    [#:level observer-level level]
		    [#:meta-level observer-meta-level meta-level]
		    [#:presence observer-presence-name presence-name]
		    [#:name observer-set-name set-name]
		    [#:set observer-set-exp set-exp]
		    [#:added observer-added-name added-name]
		    [#:removed observer-removed-name removed-name]))

   (define (analyze-participator-body body-stx p)
     (analyze-body* analyze-participator-body body-stx participator p
		    [#:when participator-condition condition]
		    [#:meta-level participator-meta-level meta-level]))

   (define (analyze-general-observer! gestalt-stx event-handler-clauses-stx)
     (define-temporaries
       [gestalt-name0 #'general]
       [gestalt-init gestalt-stx])
     (define gestalt-name (identifier-append gestalt-stx 'gestalt: gestalt-name0))
     (push-statevar! gestalt-name gestalt-init #'#f)

     (push! gestalt-updaters
	    #`(begin
		(define #,gestalt-init #,gestalt-stx)
		#:update [#,gestalt-name #,gestalt-init]))

     (push! gestalt-fragments gestalt-name)

     (push! event-handlers
	    (lambda (e-stx)
	      #`(match-state state
			     (let ((filtered-event (filter-event #,e-stx #,gestalt-name)))
			       (if (not filtered-event)
				   #f
				   ((match filtered-event
				      #,@event-handler-clauses-stx
				      [_ #f])
				    state)))))))

   (define (analyze-observation! pat-stx body-stx pub?)
     (define-values (o remaining-stx)
       (analyze-observer-body body-stx (observer #f #f #f #f #f #f #f #f)))
     (match-define
       (observer condition level meta-level presence-name set-name set-exp added-name removed-name)
       o)
     (when (and (not set-name) (or set-exp added-name removed-name))
       (define stx (or set-exp added-name removed-name))
       (raise-syntax-error #f "#:name is required when using #:set, #:added and/or #:removed" stx))
     (define base-temp-name (or set-name presence-name))
     (define-temporaries
       [presence-init presence-name]
       [set-init set-name]
       [set-temp set-name]
       [projector-init base-temp-name]
       [gestalt-init base-temp-name])
     (define projector-name (identifier-append set-name 'projector: set-name))
     (define gestalt-name (identifier-append base-temp-name 'gestalt: base-temp-name))
     (define-values (projector-stx gestalt-stx matcher-stx binders) (analyze-pattern pat-stx))

     (define using-presence? (if presence-name #t #f))
     (define using-set? (if (or set-name added-name removed-name) #t #f))

     (when using-presence?
       (push-statevar! presence-name presence-init #'#f))
     (when using-set?
       (push-statevar! set-name set-init #'(set))
       (push-statevar! projector-name projector-init #'#f))

     (define gestalt-name-available? (or using-presence? using-set?))
     (when gestalt-name-available?
       (push-statevar! gestalt-name gestalt-init #'#f))

     (push! event-handlers
	    (lambda (e-stx)
	      #`(match #,e-stx
		  [(routing-update g)
		   (begin-transition
		     #,@(if using-presence?
			    #`(#:update [#,presence-name
					 (not (gestalt-empty?
					       (gestalt-filter g #,gestalt-name)))])
			    #'())
		     #,@(if using-set?
			    #`((define #,set-temp
				 #,(if set-exp
				       #`(for/set [(e (in-set
						       (gestalt-project/keys g
									     #,projector-name)))]
					   (match-define (list #,@binders) e)
					   #,set-exp)
				       #`(gestalt-project/keys g #,projector-name)))
			       #,@(if added-name
				      #`((define #,added-name (set-subtract #,set-temp
									    #,set-name)))
				      #'())
			       #,@(if removed-name
				      #`((define #,removed-name (set-subtract #,set-name
									      #,set-temp)))
				      #'())
			       #,@(if set-name
				      #`(#:update [#,set-name #,set-temp])
				      #'()))
			    #'())
		     #,@remaining-stx)]
		  [_ noop-transition])))

     (when gestalt-name-available?
       (push! gestalt-updaters
	      #`(begin
		  (define #,projector-init
		    (#,(if pub? #'project-subs #'project-pubs) #,projector-stx
		     #:level #,(or level 0) #:meta-level #,(or meta-level 0)))
		  (define #,gestalt-init (projection->gestalt #,projector-init))
		  #,@(if using-set?
			 #`(#:update [#,projector-name #,projector-init])
			 #'())
		  #,@(if gestalt-name-available?
			 #`(#:update [#,gestalt-name #,gestalt-init])
			 #'()))))

     (push! gestalt-fragments
	    (let ((g (if gestalt-name-available?
			 gestalt-name
			 #`(#,(if pub? #'pub #'sub) #,gestalt-stx
			    #:level #,(+ 1 (or level 0)) #:meta-level #,(or meta-level 0)))))
	      (if condition
		  #`(if #,condition #,g (gestalt-empty))
		  g))))

   (define (analyze-participation! pat-stx body-stx pub?)
     (define-values (p remaining-stx) (analyze-participator-body body-stx (participator #f #f)))
     (match-define (participator condition meta-level) p)
     (define-temporaries [gestalt-name pat-stx])
     (define-values (projector-stx gestalt-stx matcher-stx binders) (analyze-pattern pat-stx))

     (push! gestalt-updaters
	    #`(define #,gestalt-name (#,(if pub? #'pub #'sub) #,gestalt-stx
				      #:meta-level #,(or meta-level 0))))

     (push! gestalt-fragments
	    (if condition
		#`(if #,condition #,gestalt-name (gestalt-empty))
		gestalt-name))

     (when (not (stx-null? remaining-stx))
       (push! event-handlers
	      (lambda (e-stx)
		#`(match #,e-stx
		    [(message #,matcher-stx (== #,(or meta-level 0)) #,pub?)
		     (begin-transition #,@remaining-stx)]
		    [_ noop-transition])))))

   (define (analyze-group-participation! loopspecs-stx pat-stx body-stx pub?)
     (define-values (p remaining-stx) (analyze-participator-body body-stx (participator #f #f)))
     (match-define (participator condition meta-level) p)
     (define-temporaries
       [projector-name pat-stx]
       [gestalt-name pat-stx])
     (define-values (projector-stx gestalt-stx matcher-stx binders) (analyze-pattern pat-stx))
     (unless (stx-null? remaining-stx)
       (raise-syntax-error #f
			   "for/advertise, and for/subscribe cannot install message handlers"
			   remaining-stx))

     (push! gestalt-fragments
	    #`(gestalt-union* (for/list #,loopspecs-stx
				#,@(if condition
				       #`(#:when #,condition)
				       #'())
				(#,(if pub? #'pub #'sub) #,gestalt-stx
				 #:meta-level #,meta-level)))))

   (define (push-action! action-stx)
     (define-temporaries [temp action-stx])
     (push! action-ids temp)
     (push! body-forms #`(define #,temp #,action-stx)))

   (define (build-result)
     (let ((actor-name (or actor-name #'anonymous-actor)))
       (define state-struct-name
	 (datum->syntax actor-name (string->symbol (format "~a-state" (syntax->datum actor-name)))))
       (define-temporaries
	 [e-stx #'event]
	 [state-stx #'state]
	 [update-gestalt-stx #'update-gestalt])
       (define result
	 #`(let ()
	     (struct #,state-struct-name (#,@statevars) #:prefab)
	     (let ()
	       #,@(for/list [(sv statevars)] #`(define-syntax-parameter #,sv #f))
	       (syntax-parameterize
		((update-state-struct
		  (syntax-rules () [(_ v [n e] (... ...))
				    (struct-copy #,state-struct-name v [n e] (... ...))]))
		 (match-state
		  (syntax-rules () [(_ id body (... ...))
				    (match-lambda
				     [(and id (struct #,state-struct-name (#,@statetemps)))
				      (syntax-parameterize
				       (#,@(for/list ([sv statevars] [si statetemps])
					     #`(#,sv (syntax-id-rules () [_ #,si]))))
				       body (... ...))])])))
		(splicing-syntax-parameterize
		 ((update-gestalt (syntax-id-rules () [_ #,update-gestalt-stx]))
		  #,@(for/list ([sv statevars] [si statetemps])
		       #`(#,sv (syntax-id-rules () [_ #,si]))))
		 #,@(reverse body-forms)
		 (define #,update-gestalt-stx
		   (begin-transition
		     #,@gestalt-updaters
		     (routing-update (gestalt-union #,@gestalt-fragments))))
		 (match (#,update-gestalt-stx (#,state-struct-name #,@statevars))
		   [(transition #,state-stx initial-gestalt-actions)
		    (match-define (list (routing-update initial-gestalt))
		      (clean-actions initial-gestalt-actions))
		    (spawn #:boot (begin-transition #,@(reverse action-ids))
			   (procedure-rename
			    (lambda (#,e-stx #,state-stx)
			      (and #,e-stx
				   (sequence-transitions (transition #,state-stx '())
							 #,@(map (lambda (p) (p e-stx))
								 (reverse event-handlers)))))
			    '#,actor-name)
			   #,state-stx
			   initial-gestalt)]))))))
       ;; (pretty-print `(result ,(syntax->datum result)))
       result))

   (walk-forms forms-stx))

 (define (expand-in-context context-id stx)
   (local-expand stx
		 (list context-id)
		 (syntax->list #'(quote quote-syntax lambda case-lambda let-values letrec-values
				  begin begin0 set! with-continuation-mark if #%app #%expression
				  define-values define-syntaxes begin-for-syntax #%require #%provide
				  #%variable-reference))))

 (define (accumulate-actions context-id action-ids final-forms forms)
   (syntax-case forms ()
     [()
      #`(match-state state
	  #,@(reverse final-forms)
	  (transition state (list #,@(reverse action-ids))))]

     [(#:run-transition exp rest ...)
      #`(match-state state
	  #,@(reverse final-forms)
	  (sequence-transitions (transition state (list #,@(reverse action-ids)))
				exp
				(begin-transition rest ...)))]

     [(#:update [statevar stateval] rest ...)
      #`(match-state state
	  #,@(reverse final-forms)
	  (sequence-transitions (transition (update-state-struct state [statevar stateval])
					    (list #,@(reverse action-ids)))
				(begin-transition rest ...)))]

     [(#:update-routes rest ...)
      #`(match-state state
	  #,@(reverse final-forms)
	  (sequence-transitions (transition state (list #,@(reverse action-ids)))
				update-gestalt
				(begin-transition rest ...)))]

     [(expr rest ...)
      (syntax-case (expand-in-context context-id #'expr) ()
	[(head inner-rest ...)
	 (if (or (free-identifier=? #'head #'begin)
		 (free-identifier=? #'head #'begin-transition))
	     (accumulate-actions context-id
				 action-ids
				 final-forms
				 (append (syntax->list #'(inner-rest ...)) #'(rest ...)))
	     (if (ormap (lambda (i) (free-identifier=? #'head i))
			(syntax->list #'(define-values define-syntaxes begin-for-syntax
					  module module*
					  #%module-begin
					  #%require #%provide)))
		 (accumulate-actions context-id
				     action-ids
				     (cons #'expr final-forms)
				     #'(rest ...))
		 (accumulate-action #'expr
				    context-id
				    action-ids
				    final-forms
				    #'(rest ...))))]
	[non-pair-syntax
	 (accumulate-action #'expr
			    context-id
			    action-ids
			    final-forms
			    #'(rest ...))])]))

 (define (accumulate-action action-stx context-id action-ids final-forms remaining-forms)
   (define-temporaries [temp action-stx])
   (accumulate-actions context-id
		       (cons temp action-ids)
		       (cons #`(define #,temp #,action-stx) final-forms)
		       remaining-forms)))

;;; Local Variables:
;;; eval: (put 'begin-transition 'scheme-indent-function 0)
;;; eval: (put 'observe-gestalt 'scheme-indent-function 1)
;;; eval: (put 'observe-subscribers 'scheme-indent-function 1)
;;; eval: (put 'observe-advertisers 'scheme-indent-function 1)
;;; eval: (put 'subscribe 'scheme-indent-function 1)
;;; eval: (put 'advertise 'scheme-indent-function 1)
;;; End: