syndicate-2017/racket/syndicate/lang.rkt

#lang racket/base

(require (for-syntax racket/base syntax/kerncase))

(require racket/match)
(require "main.rkt")
(require (submod "actor.rkt" for-module-begin))

(provide (rename-out [module-begin #%module-begin])
         activate
         require/activate
	 (except-out (all-from-out racket/base) #%module-begin)
	 (all-from-out racket/match)
	 (all-from-out "main.rkt")
	 (for-syntax (all-from-out racket/base)))

(define-syntax (activate stx)
  (syntax-case stx ()
    [(_ module-path ...)
     #'(begin
         (let ()
           (local-require (submod module-path syndicate-main))
           (activate!))
         ...)]))

(define-syntax (require/activate stx)
  (syntax-case stx ()
    [(_ module-path ...)
     #'(begin
         (require module-path ...)
         (activate module-path ...))]))

(define-syntax (module-begin stx)
  (unless (eq? (syntax-local-context) 'module-begin)
    (raise-syntax-error #f "allowed only around a module body" stx))
  (syntax-case stx ()
    [(_ forms ...)
     (let ()
       (define (accumulate-actions action-ids final-forms forms)
	 (if (null? forms)
	     (let ((final-stx
		    #`(#%module-begin #,@(reverse final-forms)
                                      (module+ syndicate-main
                                        (provide boot-actions activate!)
                                        (define activated? #f)
                                        (define boot-actions (list #,@(reverse action-ids)))
                                        (define (activate!)
                                          (when (not activated?)
                                            (set! activated? #t)
                                            boot-actions)))
                                      (module+ main
                                        (require (submod ".." syndicate-main))
                                        (run-ground (activate!))))))
	       ;;(pretty-print (syntax->datum final-stx))
	       final-stx)
	     (syntax-case (local-expand (car forms)
					'module
                                        (kernel-form-identifier-list)) ()
	       [(head rest ...)
		(if (free-identifier=? #'head #'begin)
		    (accumulate-actions action-ids
					final-forms
					(append (syntax->list #'(rest ...)) (cdr forms)))
		    (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 action-ids
					    (cons (car forms) final-forms)
					    (cdr forms))
			(accumulate-action (car forms) action-ids final-forms (cdr forms))))]
	       [non-pair-syntax
		(accumulate-action (car forms) action-ids final-forms (cdr forms))])))
       (define (accumulate-action action action-ids final-forms remaining-forms)
	 (define temp (car (generate-temporaries (list action))))
	 (accumulate-actions (cons temp action-ids)
			     (cons #`(define #,temp (capture-actor-actions (lambda () #,action)))
                                   final-forms)
			     remaining-forms))
       (accumulate-actions '() '() (syntax->list #'(forms ...))))]))

(define (capture-actor-actions thunk)
  (call-with-syndicate-effects
   (lambda ()
     (parameterize ((current-pending-actions '())
                    (current-pending-patch patch-empty))
       (define result (thunk))
       (flush-pending-patch!)
       (cons result (current-pending-actions))))))