#lang syndicate
;; Crude steps toward reloadable Syndicate modules

(provide (except-out (struct-out reload-pending) reload-pending)
         (rename-out [reload-pending <reload-pending>])
         (rename-out [make-reload-pending reload-pending])

         stop-when-reloaded
         spawn-reloader
         spawn-reloader*
         reloader-mixin
         reloader-mixin*)

(define-logger syndicate/reload)

(require file/sha1)
(require (for-syntax racket/base))
(require racket/rerequire)

(require/activate syndicate/supervise)
(require/activate syndicate/drivers/filesystem)

(assertion-struct reloader (pathstr))
(assertion-struct reload-pending (filename))

(define-syntax (make-reload-pending stx)
  (syntax-case stx ()
    [(SELF)
     (quasisyntax/loc stx
       (reload-pending '#,(path->string (syntax-source #'SELF))))]))

(define-syntax (stop-when-reloaded stx)
  (syntax-case stx ()
    [(_ body ...)
     (quasisyntax/loc stx
       (stop-when (asserted (reload-pending '#,(path->string (syntax-source stx))))
                  body ...))]))

(define-syntax (spawn-reloader stx)
  (syntax-case stx ()
    [(_ module-path)
     (quasisyntax/loc stx
       (spawn-reloader* 'module-path '#,(path->string (syntax-source stx))))]))

(define (spawn-reloader* module-path loading-module-pathstr)
  (match (module-path->path-string module-path)
    [#f #f]
    [pathstr
     (supervise #:name (reloader pathstr)
                (stop-when (asserted (reload-pending loading-module-pathstr)))
                (reloader-mixin** module-path pathstr))
     #t]))

(define-syntax-rule (reloader-mixin module-path)
  (reloader-mixin* 'module-path))

(define (reloader-mixin* module-path)
  (define pathstr (module-path->path-string module-path))
  (when (not pathstr)
    (error 'reloader-mixin "Cannot deduce source path from module-path ~v" module-path))
  (reloader-mixin** module-path pathstr))

(define (module-path->path-string module-path)
  (define mpi (module-path-index-join module-path #f))
  (define rpath (module-path-index-resolve mpi))
  (define path (let ((p (resolved-module-path-name rpath)))
                 (if (pair? p) (car p) p)))
  (if (path? path)
      (path->string path)
      (begin (log-syndicate/reload-error "Could not process module-path ~v" module-path)
             #f)))

(define (file->sha1 p)
  (call-with-input-file p sha1))

(define (reloader-mixin** module-path pathstr)
  (field [reloading? #f])
  (define (reload!)
    (when (not (reloading?))
      (reloading? #t)
      (react (field [obstacles-cleared? #f] [obstacles-existed? #f])
             (define/query-value obstacles-exist? #f (observe (reload-pending pathstr)) #t
               #:on-add (begin (log-syndicate/reload-info "waiting to reload ~v" pathstr)
                               (obstacles-existed? #t))
               #:on-remove (obstacles-cleared? #t))
             (assert #:when (obstacles-exist?) (reload-pending pathstr))
             (on-start (flush!)
                       (obstacles-cleared? (not (obstacles-exist?))))
             (stop-when-true (obstacles-cleared?)
               (flush!) ;; Wait one turn for effects of newly-cleared obstacles
               (log-syndicate/reload-info "(re)loading ~v" pathstr)
               (dynamic-rerequire module-path)
               (let ((force-reactivation? (obstacles-existed?)))
                 (when force-reactivation?
                   (log-syndicate/reload-info "forcing reactivation of ~v" pathstr))
                 (spawn* #:name module-path
                         ((dynamic-require `(submod ,module-path syndicate-main)
                                           (if force-reactivation? 'activate!* 'activate!)))))
               (reloading? #f)))))

  (on-start (log-syndicate/reload-debug "reloader ~v starting" pathstr))
  (on-stop (log-syndicate/reload-debug "reloader ~v stopping" pathstr))

  (field [previous-version 'unknown])
  (define/query-value latest-version 'unknown (file-content pathstr file->sha1 $p) p)
  (begin/dataflow
    (when (and (not (eq? (latest-version) 'unknown))
               (not (equal? (latest-version) (previous-version))))
      (if (latest-version)
          (reload!)
          (log-syndicate/reload-warning "Module ~v does not exist" pathstr))
      (previous-version (latest-version)))))

(module+ main
  (require racket/cmdline)
  (extend-ground-boot! (lambda ()
                         (define module-path (command-line #:args (module-path) module-path))
                         (spawn-reloader* module-path "<main>"))))