152 lines
5.4 KiB
Racket
152 lines
5.4 KiB
Racket
#lang racket/base
|
|
|
|
;;; Source: https://github.com/tonyg/racket-reloadable/blob/master/reloadable/main.rkt
|
|
;;; Source commit: cae2a14 from 24 May 2015
|
|
;;; Source license: LGPL 3 or later
|
|
;;; Further modifications by Cadence as seen in this repo's git history.
|
|
|
|
(provide (struct-out reloadable-entry-point)
|
|
reload-poll-interval
|
|
set-reload-poll-interval!
|
|
reload-failure-retry-delay
|
|
reload!
|
|
make-reloadable-entry-point
|
|
lookup-reloadable-entry-point
|
|
reloadable-entry-point->procedure
|
|
make-persistent-state)
|
|
|
|
(require racket/set)
|
|
(require racket/string)
|
|
(require racket/match)
|
|
(require racket/rerequire)
|
|
|
|
(define reload-poll-interval 0.5) ; seconds
|
|
(define reload-failure-retry-delay (make-parameter 5)) ; seconds
|
|
|
|
(struct reloadable-entry-point (name
|
|
module-path
|
|
identifier-symbol
|
|
on-absent
|
|
[value #:mutable])
|
|
#:prefab)
|
|
|
|
(define reloadable-entry-points (make-hash))
|
|
(define persistent-state (make-hash))
|
|
|
|
(define (set-reload-poll-interval! v)
|
|
(set! reload-poll-interval v))
|
|
|
|
(define (reloader-main)
|
|
(let loop ()
|
|
(match (sync (handle-evt (thread-receive-evt)
|
|
(lambda (_) (thread-receive)))
|
|
(if reload-poll-interval
|
|
(handle-evt (alarm-evt (+ (current-inexact-milliseconds)
|
|
(* reload-poll-interval 1000)))
|
|
(lambda (_) (list #f 'reload)))
|
|
never-evt))
|
|
[(list ch 'reload)
|
|
(define result (do-reload!))
|
|
(when (not result) (sleep (reload-failure-retry-delay)))
|
|
(when ch (channel-put ch result))])
|
|
(loop)))
|
|
|
|
(define reloader-thread (thread reloader-main))
|
|
|
|
(define (reloader-rpc . request)
|
|
(define ch (make-channel))
|
|
(thread-send reloader-thread (cons ch request))
|
|
(channel-get ch))
|
|
|
|
(define (reload!) (reloader-rpc 'reload))
|
|
|
|
(define first-load? #t)
|
|
(define (say-loading-once! port)
|
|
(when first-load?
|
|
(display "loading support files" port)
|
|
(set! first-load? #f)))
|
|
|
|
(define (handle-loader-output)
|
|
(define i (thread-receive))
|
|
(define real-error-port (thread-receive))
|
|
(say-loading-once! real-error-port)
|
|
(let loop ()
|
|
(define line (read-line i))
|
|
(cond
|
|
[(eof-object? line)
|
|
(void)]
|
|
[(string-contains? line "[load")
|
|
(display "." real-error-port)
|
|
(loop)]
|
|
[#t
|
|
(displayln line real-error-port)
|
|
(loop)])))
|
|
|
|
;; Only to be called from reloader-main
|
|
(define (do-reload!)
|
|
(define module-paths (for/set ((e (in-hash-values reloadable-entry-points)))
|
|
(reloadable-entry-point-module-path e)))
|
|
(with-handlers ((exn:fail?
|
|
(lambda (e)
|
|
(log-error "*** WHILE RELOADING CODE***\n~a"
|
|
(parameterize ([current-error-port (open-output-string)])
|
|
((error-display-handler) (exn-message e) e)
|
|
(get-output-string (current-error-port))))
|
|
#f)))
|
|
(for ((module-path (in-set module-paths)))
|
|
(let ([real-error-port (current-error-port)])
|
|
(define-values (i o) (make-pipe))
|
|
(parameterize ([current-error-port o])
|
|
(define new-thread (thread handle-loader-output))
|
|
(thread-send new-thread i)
|
|
(thread-send new-thread real-error-port)
|
|
(dynamic-rerequire module-path #:verbosity 'all))))
|
|
(for ((e (in-hash-values reloadable-entry-points)))
|
|
(match-define (reloadable-entry-point _ module-path identifier-symbol on-absent _) e)
|
|
(define new-value (if on-absent
|
|
(dynamic-require module-path identifier-symbol on-absent)
|
|
(dynamic-require module-path identifier-symbol)))
|
|
(set-reloadable-entry-point-value! e new-value))
|
|
#t))
|
|
|
|
(define (make-reloadable-entry-point name module-path [identifier-symbol name]
|
|
#:on-absent [on-absent #f])
|
|
(define key (list module-path name))
|
|
(hash-ref reloadable-entry-points
|
|
key
|
|
(lambda ()
|
|
(define e (reloadable-entry-point name module-path identifier-symbol on-absent #f))
|
|
(hash-set! reloadable-entry-points key e)
|
|
e)))
|
|
|
|
(define (lookup-reloadable-entry-point name module-path)
|
|
(hash-ref reloadable-entry-points
|
|
(list module-path name)
|
|
(lambda ()
|
|
(error 'lookup-reloadable-entry-point
|
|
"Reloadable-entry-point ~a not found in module ~a"
|
|
name
|
|
module-path))))
|
|
|
|
(define (reloadable-entry-point->procedure e)
|
|
(make-keyword-procedure
|
|
(lambda (keywords keyword-values . positionals)
|
|
(keyword-apply (reloadable-entry-point-value e)
|
|
keywords
|
|
keyword-values
|
|
positionals))))
|
|
|
|
(define (make-persistent-state name initial-value-thunk)
|
|
(hash-ref persistent-state
|
|
name
|
|
(lambda ()
|
|
(define value (initial-value-thunk))
|
|
(define handler
|
|
(case-lambda
|
|
[() value]
|
|
[(new-value)
|
|
(set! value new-value)
|
|
value]))
|
|
(hash-set! persistent-state name handler)
|
|
handler)))
|