breezewiki/src/reloadable.rkt

151 lines
5.3 KiB
Racket
Raw Normal View History

#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
(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 ()
(let ([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)))