214 lines
9.3 KiB
Racket
214 lines
9.3 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/cmdline
|
|
racket/contract/base
|
|
racket/contract/region
|
|
racket/format
|
|
racket/match
|
|
racket/runtime-path
|
|
racket/pretty
|
|
"channel.rkt"
|
|
"cmds.rkt"
|
|
"error.rkt"
|
|
"gui.rkt"
|
|
"instrument.rkt"
|
|
"logger.rkt"
|
|
"mod.rkt"
|
|
"namespace.rkt"
|
|
"util.rkt")
|
|
|
|
(module+ main
|
|
(match (current-command-line-arguments)
|
|
[(vector port) (start-command-server (string->number port))
|
|
(start-logger-server (add1 (string->number port)))]
|
|
[v (displayln "Expected exactly one argument: command port")
|
|
(exit)])
|
|
;; Emacs on Windows comint-mode needs buffering disabled.
|
|
(when (eq? (system-type 'os) 'windows)
|
|
(file-stream-buffer-mode (current-output-port) 'none))
|
|
(display (banner))
|
|
(flush-output)
|
|
(parameterize ([error-display-handler our-error-display-handler])
|
|
(run rerun-default)))
|
|
|
|
(define (run rr) ;rerun? -> void?
|
|
(match-define (rerun maybe-mod
|
|
mem-limit
|
|
pretty-print?
|
|
context-level
|
|
cmd-line-args) rr)
|
|
(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 (if (instrument-level? context-level)
|
|
(make-instrumented-eval-handler (current-eval))
|
|
(current-eval))]
|
|
[instrumenting-enabled (instrument-level? context-level)]
|
|
[profiling-enabled (eq? context-level 'profile)]
|
|
[test-coverage-enabled (eq? context-level 'coverage)]
|
|
;; 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 be called from another thread -- either a plain
|
|
;; thread when racket/gui/base is not (yet) instantiated, or, from
|
|
;; (eventspace-handler-thread (current-eventspace)).
|
|
(define (repl-thunk)
|
|
;; 0. Command line arguments
|
|
(current-command-line-arguments cmd-line-args)
|
|
;; 1. Set current-print and pretty-print hooks.
|
|
(current-print (make-print-handler pretty-print?))
|
|
(pretty-print-print-hook (make-pretty-print-print-hook))
|
|
(pretty-print-size-hook (make-pretty-print-size-hook))
|
|
;; 2. If module, require and enter its namespace, etc.
|
|
(when (and maybe-mod mod-path)
|
|
(parameterize ([current-module-name-resolver repl-module-name-resolver])
|
|
;; When exn:fail? during module load, re-run with "empty"
|
|
;; module. Note: Unlikely now that we're using
|
|
;; dynamic-require/some-namespace.
|
|
(with-handlers ([exn? (λ (x)
|
|
(display-exn x)
|
|
(put/stop (struct-copy rerun rr [maybe-mod #f])))])
|
|
(maybe-load-language-info mod-path) ;FIRST: see #281
|
|
(current-namespace (dynamic-require/some-namespace maybe-mod))
|
|
(maybe-warn-about-submodules mod-path context-level)
|
|
(check-top-interaction))))
|
|
;; 3. Tell command server to use our namespace and module.
|
|
(attach-command-server (current-namespace) maybe-mod)
|
|
;; 4. read-eval-print-loop
|
|
(parameterize ([current-prompt-read (make-prompt-read maybe-mod)]
|
|
[current-module-name-resolver repl-module-name-resolver])
|
|
;; 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 msg
|
|
(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 main-channel))))
|
|
(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 msg
|
|
[(? rerun? x) (run x)]
|
|
[(? load-gui?) (require-gui) (run rr)]))
|
|
|
|
(define (maybe-load-language-info path)
|
|
;; Load language-info (if any) and do configure-runtime.
|
|
;; Important for langs like Typed Racket.
|
|
(with-handlers ([exn:fail? void])
|
|
(define info (module->language-info path #t))
|
|
(when info
|
|
(define get-info ((dynamic-require (vector-ref info 0)
|
|
(vector-ref info 1))
|
|
(vector-ref info 2)))
|
|
(define configs (get-info 'configure-runtime '()))
|
|
(for ([config (in-list configs)])
|
|
((dynamic-require (vector-ref config 0)
|
|
(vector-ref config 1))
|
|
(vector-ref config 2))))
|
|
(define cr-submod `(submod ,@(match path
|
|
[(list 'submod sub-paths ...) sub-paths]
|
|
[_ (list 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 repl-module-name-resolver
|
|
(let ([orig-resolver (current-module-name-resolver)])
|
|
(case-lambda
|
|
[(rmp ns)
|
|
(orig-resolver rmp ns)]
|
|
[(mp rmp stx)
|
|
(repl-module-name-resolver mp rmp stx #t)]
|
|
[(mp rmp stx load?)
|
|
(when (and load? (memq mp '(racket/gui/base
|
|
racket/gui/dynamic
|
|
scheme/gui/base)))
|
|
(unless (gui-required?)
|
|
(put/stop (load-gui))))
|
|
(orig-resolver mp rmp stx load?)])))
|
|
|
|
;; Note: The `dynamic-require`s seem to be necessary otherwise
|
|
;; file/convertible's convertible? always returns #f. Which seeems to
|
|
;; be a namespace issue that I don't understand.
|
|
(define-runtime-path image.rkt "image.rkt")
|
|
|
|
(define (make-print-handler pretty-print?)
|
|
(cond [pretty-print? pretty-print-handler]
|
|
[else (make-plain-print-handler)]))
|
|
|
|
(define (make-plain-print-handler)
|
|
(let ([convert (dynamic-require image.rkt 'convert-image)])
|
|
(λ (v)
|
|
(void (unless (void? v)
|
|
(print (convert v))
|
|
(newline))))))
|
|
|
|
(define (make-pretty-print-size-hook [orig (pretty-print-size-hook)])
|
|
(let ([convert? (dynamic-require image.rkt 'convert-image?)]
|
|
[width (floor (/ (pretty-print-columns) 4))]) ;magic number? yep.
|
|
(λ (value display? port)
|
|
(cond [(convert? value) width]
|
|
[else (orig value display? port)]))))
|
|
|
|
(define (make-pretty-print-print-hook [orig (pretty-print-print-hook)])
|
|
(let ([convert? (dynamic-require image.rkt 'convert-image?)]
|
|
[convert (dynamic-require image.rkt 'convert-image)])
|
|
(λ (value display? port)
|
|
(cond [(convert? value) (print (convert value) port)]
|
|
[else (orig value display? port)]))))
|