#lang racket/base ;; Do NOT use `at-exp` in this file! See issue #290. (require racket/contract racket/match racket/set racket/tcp (only-in "debug.rkt" make-debug-eval-handler next-break) "elisp.rkt" "error.rkt" "gui.rkt" "instrument.rkt" "interactions.rkt" "mod.rkt" "print.rkt" (only-in "syntax.rkt" with-expanded-syntax-caching-evaluator) "util.rkt") (provide start-repl-session-server run call-with-session-context exit-repl-session current-session-id current-session-maybe-mod current-session-submit-pred) ;;; REPL session "housekeeping" (define next-session-number 0) (define drracket:submit-predicate/c (-> input-port? boolean? boolean?)) (define-struct/contract session ([thread thread?] ;the repl manager thread [repl-msg-chan channel?] ;see repl-message structs [interaction-chan channel?] [ns namespace?] [maybe-mod (or/c #f mod?)] [submit-pred (or/c #f drracket:submit-predicate/c)]) #:transparent) (define sessions (make-hash)) (define current-session-id (make-parameter #f)) (define current-repl-msg-chan (make-parameter #f)) ;current-interaction-chan defined in "interactions.rkt" (define current-session-maybe-mod (make-parameter #f)) (define current-session-submit-pred (make-parameter #f)) ;;; Messages to each repl manager thread ;; Definitions for context-level member of run-config struct (define profile/coverage-levels ;; "sibling" levels that need instrument plus... '(profile ;profiling-enabled coverage)) ;execute-counts-enabled (define instrument-levels `(high ;compile-context-preservation-enabled #t + instrument ,@profile/coverage-levels)) (define context-levels `(low ;compile-context-preservation-enabled #f medium ;compile-context-preservation-enabled #t ,@instrument-levels debug)) (define (context-level? v) (memq? v context-levels)) (define (instrument-level? v) (memq? v instrument-levels)) (define (profile/coverage-level? v) (memq? v profile/coverage-levels)) (define (debug-level? v) (eq? v 'debug)) ;; The message structs (define-struct/contract repl-manager-thread-message ()) (define-struct/contract (load-gui repl-manager-thread-message) ([in-repl? boolean?])) (define-struct/contract (run-config repl-manager-thread-message) ([maybe-mod (or/c #f mod?)] [memory-limit exact-nonnegative-integer?] ;0 = no limit [pretty-print? boolean?] [context-level context-level?] [cmd-line-args (vectorof string?)] [debug-files (set/c path?)] [ready-thunk (-> any/c)])) (define (initial-run-config ready-thunk) (run-config #f ;maybe-mod 0 ;memory-limit #f ;pretty-print? 'low ;context-level #() ;cmd-line-args (set) ;debug-files ready-thunk)) ;;; Functionality provided for commands ;; A way to parameterize commands that need to work with a specific ;; REPL session. Called from command-server thread. (define (call-with-session-context sid proc . args) (match (hash-ref sessions sid #f) [(and (session _thd msg-ch int-ch ns maybe-mod submit-pred) s) (log-racket-mode-debug "call-with-session-context: ~v => ~v" sid s) (parameterize ([current-repl-msg-chan msg-ch] [current-interaction-chan int-ch] [current-namespace ns] [current-session-id sid] [current-session-maybe-mod maybe-mod] [current-session-submit-pred submit-pred]) (apply proc args))] [_ (if (equal? sid '()) (log-racket-mode-debug "call-with-session-context: no specific session") (log-racket-mode-warning "call-with-session-context: ~v not found in ~v" sid sessions)) (apply proc args)])) ;; Command. Called from command-server thread (define (exit-repl-session sid) (match (hash-ref sessions sid #f) [(struct* session ([thread t])) (log-racket-mode-debug "exit-repl: break-thread for ~v" sid) (break-thread t 'terminate)] [_ (log-racket-mode-error "exit-repl: ~v not in `sessions`" sid)])) ;; Command. Called from command-server thread (define/contract (run what mem pp ctx args dbgs) (-> list? number? elisp-bool/c context-level? list? (listof path-string?) list?) (define ready-channel (make-channel)) (channel-put (current-repl-msg-chan) (run-config (->mod/existing what) mem (as-racket-bool pp) ctx (list->vector args) (list->set (map string->path dbgs)) (λ () (channel-put ready-channel what)))) ;; Waiting for this allows the command response to be used as the ;; all-clear for additional commands that need the module load to be ;; done and entering a REPL for that module. For example, to compose ;; run with get-profile or get-uncovered. (sync ready-channel)) ;;; REPL session server (define (start-repl-session-server port launch-token) (thread (listener-thread-thunk port launch-token))) (define ((listener-thread-thunk port launch-token)) (define listener (tcp-listen port 4 #t "127.0.0.1")) (let accept-a-connection () (define custodian (make-custodian)) (parameterize ([current-custodian custodian]) ;; `exit` in a REPL should terminate that REPL session -- not ;; the entire back end server. Also, this is opportunity to ;; remove the session from `sessions` hash table. (define (our-exit-handler code) (log-racket-mode-info "(our-exit-handler ~v) ~v" code (current-session-id)) (when (current-session-id) ;might exit before session created (hash-remove! sessions (current-session-id)) (log-racket-mode-debug "sessions: ~v" sessions)) (custodian-shutdown-all custodian)) (parameterize ([exit-handler our-exit-handler]) (define-values (in out) (tcp-accept listener)) (parameterize ([current-input-port in] [current-output-port out] [current-error-port out]) (for ([p (in-list (list in out))]) (file-stream-buffer-mode p 'none)) ;would 'line be sufficient? ;; Immediately after connecting, the client must send us ;; exactly the same launch token value that it gave us as a ;; command line argument when it started us. Else we close ;; the connection. See issue #327. (define supplied-token (elisp-read in)) (unless (equal? launch-token supplied-token) (log-racket-mode-fatal "Authorization failed: ~v" supplied-token) (exit 'racket-mode-repl-auth-failure)) (thread repl-manager-thread-thunk)))) (accept-a-connection))) (define (repl-manager-thread-thunk) (define session-id (format "repl-session-~a" (begin0 next-session-number (inc! next-session-number)))) (log-racket-mode-info "start ~v" session-id) (parameterize* ([error-display-handler our-error-display-handler] [current-session-id session-id] ;before make-get-interaction [current-repl-msg-chan (make-channel)] [current-interaction-chan (make-get-interaction)]) (do-run (initial-run-config (λ () ;; Write a sexpr containing the session-id, which the client ;; can use in certain commands that need to run in the context ;; of a specific REPL. We wait to do so until this ready-thunk ;; to ensure the `sessions` hash table has this session before ;; any subsequent commands use call-with-session-context. (elisp-writeln `(ok ,session-id) (current-output-port)) (flush-output) (display-commented (string-append "\n" (banner)))))))) (define (do-run cfg) ;run-config? -> void? (match-define (run-config maybe-mod mem-limit pretty-print? context-level cmd-line-args debug-files ready-thunk) cfg) (define-values (dir file mod-path) (maybe-mod->dir/file/rmp maybe-mod)) ;; Always set current-directory and current-load-relative-directory ;; to match the source file. (current-directory dir) (current-load-relative-directory dir) ;; Make src-loc->string provide full pathnames (show-full-path-in-errors) ;; Custodian for the REPL. (define repl-cust (make-custodian)) (when (< 0 mem-limit) (custodian-limit-memory repl-cust (inexact->exact (round (* 1024 1024 mem-limit))) repl-cust)) ;; If racket/gui/base isn't loaded, the current-eventspace parameter ;; doesn't exist, so make a "dummy" parameter of that name. (define current-eventspace (txt/gui (make-parameter #f) current-eventspace)) ;; Create REPL thread (define repl-thread (parameterize* ;; Use `parameterize*` because the order matters. (;; FIRST: current-custodian and current-namespace, so in ;; effect for later parameterizations. [current-custodian repl-cust] [current-namespace (if mod-path ((txt/gui make-base-empty-namespace make-gui-empty-namespace)) ((txt/gui make-base-namespace make-gui-namespace)))] ;; OTHERS: [compile-enforce-module-constants #f] [compile-context-preservation-enabled (not (eq? context-level 'low))] [current-eval (cond [(debug-level? context-level) (make-debug-eval-handler debug-files)] [(instrument-level? context-level)(make-instrumented-eval-handler)] [else (current-eval)])] [instrumenting-enabled (instrument-level? context-level)] [profiling-enabled (eq? context-level 'profile)] [test-coverage-enabled (eq? context-level 'coverage)] [current-sync/yield (txt/gui sync yield)] ;; LAST: `current-eventspace` because `make-eventspace` ;; creates an event handler thread -- now. We want that ;; thread to inherit the parameterizations above. (Otherwise ;; in the non-gui case, we call `thread` below in the body of ;; the parameterize* form, so that's fine.) [current-eventspace ((txt/gui void make-eventspace))]) ;; repl-thunk will either be used as the thunk for a thread we ;; make directly -- or, when racket/gui/base is instantiated, ;; installed as the current eventspace's event queue via ;; queue-callback, running under (eventspace-handler-thread ;; (current-eventspace)). (define (repl-thunk) ;; 0. Command line arguments (current-command-line-arguments cmd-line-args) ;; 1. Set print hooks and output handlers (set-print-parameters pretty-print?) (set-output-handlers) ;; 2. If module, require and enter its namespace, etc. (with-expanded-syntax-caching-evaluator maybe-mod (when (and maybe-mod mod-path) (parameterize ([current-module-name-resolver module-name-resolver-for-run]) ;; When exn:fail during module load, re-run. (define (load-exn-handler exn) (define new-mod (match mod-path [`(submod ,(== file) main) (log-racket-mode-debug "~v not found, retry as ~v" mod-path (build-path dir file)) (->mod/existing (build-path dir file))] ;; Else display exn and retry as "empty" REPL. [_ (display-exn exn) #f])) (channel-put (current-repl-msg-chan) (struct-copy run-config cfg [maybe-mod new-mod])) (sync never-evt)) ;manager thread will shutdown custodian (with-handlers ([exn? load-exn-handler]) (maybe-configure-runtime mod-path) ;FIRST: see #281 (current-namespace (parameterize ([current-load-relative-directory dir] [current-directory dir]) (dynamic-require mod-path #f) (module->namespace mod-path))) (maybe-warn-about-submodules mod-path context-level) (check-#%top-interaction))))) ;; 3. Record information about our session (hash-set! sessions (current-session-id) (session (current-thread) (current-repl-msg-chan) (current-interaction-chan) (current-namespace) maybe-mod (get-repl-submit-predicate maybe-mod))) (log-racket-mode-debug "sessions: ~v" sessions) ;; 4. Now that the program has run, and `sessions` is updated, ;; call the ready-thunk. On REPL startup this lets us wait ;; sending the repl-session-id until `sessions` is updated. ;; And for subsequent run commands, this lets us it wait to ;; send a response. (ready-thunk) ;; 5. read-eval-print-loop (parameterize ([current-prompt-read (make-prompt-read maybe-mod)] [current-module-name-resolver module-name-resolver-for-repl]) ;; Note that read-eval-print-loop catches all non-break ;; exceptions. (read-eval-print-loop))) ;; Main thread: Run repl-thunk on a plain thread, or, on the ;; eventspace thread via queue-callback. Return the thread. (define t/v ((txt/gui thread queue-callback ) repl-thunk)) (define thd ((txt/gui (λ _ t/v) eventspace-handler-thread) (current-eventspace))) thd)) ;; Main thread: Wait for message from REPL thread on channel. Also ;; catch breaks, in which case we (a) break the REPL thread so ;; display-exn runs there, and (b) continue from the break instead ;; of re-running so that the REPL environment is maintained. (define message (call-with-exception-handler (match-lambda [(and (or (? exn:break:terminate?) (? exn:break:hang-up?)) e) e] [(exn:break _msg _marks continue) (break-thread repl-thread) (continue)] [e e]) (λ () (sync (current-repl-msg-chan))))) (match context-level ['profile (clear-profile-info!)] ['coverage (clear-test-coverage-info!)] [_ (void)]) (custodian-shutdown-all repl-cust) (newline) ;; FIXME: Move this to racket-mode.el instead? (match message [(? run-config? new-cfg) (do-run new-cfg)] [(load-gui repl?) (require-gui repl?) (do-run cfg)])) (define/contract ((make-prompt-read m)) (-> (or/c #f mod?) (-> any)) (begin0 (get-interaction (maybe-mod->prompt-string m)) ;; let debug-instrumented code break again (next-break 'all))) ;; (define/contract (get-repl-submit-predicate m) (-> (or/c #f mod?) (or/c #f drracket:submit-predicate/c)) (define-values (dir file rmp) (maybe-mod->dir/file/rmp m)) (define path (and dir file (build-path dir file))) (and path rmp (or (with-handlers ([exn:fail? (λ _ #f)]) (match (with-input-from-file (build-path dir file) read-language) [(? procedure? get-info) (match (get-info 'drracket:submit-predicate #f) [#f #f] [v v])] [_ #f])) (with-handlers ([exn:fail? (λ _ #f)]) (match (module->language-info rmp #t) [(vector mp name val) (define get-info ((dynamic-require mp name) val)) (get-info 'drracket:submit-predicate #f)] [_ #f]))))) (define (maybe-configure-runtime mod-path) ;; Do configure-runtime when available. ;; Important for langs like Typed Racket. (with-handlers ([exn:fail? void]) (match (module->language-info mod-path #t) [(vector mp name val) (define get-info ((dynamic-require mp name) val)) (define configs (get-info 'configure-runtime '())) (for ([config (in-list configs)]) (match-let ([(vector mp name val) config]) ((dynamic-require mp name) val)))] [_ (void)]) (define cr-submod `(submod ,@(match mod-path [(list 'submod sub-paths ...) sub-paths] [_ (list mod-path)]) configure-runtime)) (when (module-declared? cr-submod) (dynamic-require cr-submod #f)))) (define (check-#%top-interaction) ;; Check that the lang defines #%top-interaction (unless (memq '#%top-interaction (namespace-mapped-symbols)) (display-commented "Because the language used by this module provides no #%top-interaction\n you will be unable to evaluate expressions here in the REPL."))) ;; Catch attempt to load racket/gui/base for the first time. (define (make-module-name-resolver repl?) (let ([orig-resolver (current-module-name-resolver)]) (define (resolve mp rmp stx load?) (when (and load? (memq mp '(racket/gui/base racket/gui/dynamic scheme/gui/base))) (unless (gui-required?) (channel-put (current-repl-msg-chan) (load-gui repl?)) (sync never-evt))) (orig-resolver mp rmp stx load?)) (case-lambda [(rmp ns) (orig-resolver rmp ns)] [(mp rmp stx) (resolve mp rmp stx #t)] [(mp rmp stx load?) (resolve mp rmp stx load?)]))) (define module-name-resolver-for-run (make-module-name-resolver #f)) (define module-name-resolver-for-repl (make-module-name-resolver #t)) ;;; Output handlers; see issues #381 #397 ;; These are plain procedures not parameters. Therefore to reset them ;; for each user program run, we must call them each time with the ;; original value. What original value? It suffices to use the value ;; in effect when this back end starts, i.e. the default ;; port-xxx-handler. (define the-default-output-handlers (for/hash ([get/set (in-list (list port-write-handler port-display-handler port-print-handler))]) (values get/set (get/set (current-output-port))))) (define (set-output-handlers) (for ([(get/set v) (in-hash the-default-output-handlers)]) (get/set (current-output-port) v)))