122 lines
4.6 KiB
Racket
122 lines
4.6 KiB
Racket
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
#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>"))))
|