mprodrigues/emacs.d
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Update packages

Browse Source
This commit is contained in:
Mateus Pinto Rodrigues
2018-10-04 13:56:56 -03:00
parent 5d03e5e124
commit d272c43bcd
785 changed files with 367265 additions and 25 deletions
Download Patch File Download Diff File Expand all files Collapse all files

273
elpa/racket-mode-20181004.309/racket/run.rkt Normal file
View File

@@ -0,0 +1,273 @@
#lang racket/base
(require racket/cmdline
racket/contract/base
racket/contract/region
racket/format
racket/match
racket/pretty
racket/runtime-path
racket/set
racket/string
"channel.rkt"
"command-server.rkt"
(only-in "debug.rkt" make-debug-eval-handler)
"elisp.rkt"
"error.rkt"
"gui.rkt"
"instrument.rkt"
"interactions.rkt"
"logger.rkt"
"mod.rkt"
"namespace.rkt"
(prefix-in stx-cache: "syntax.rkt")
"util.rkt")
;; Main moving parts:
;;
;; 1. This main thread, which receives a couple messages on a channel
;; (see channel.rkt). One message is a `rerun` struct with info
;; about a new file/module to run. The main thread loops forever
;; (the `rerun` function tail calls itself forever). The special
;; case of racket/gui/base is handled with a custom module names
;; resolver and another message.
;;
;; 2. A thread created for each run; loads a module and goes into
;; a read-eval-print-loop.
;;
;; 3. A thread for a command server that listens on a TCP port (see
;; command-server.rkt). One of the commands is a `run` command.
(module+ main
(define-values (command-port launch-token run-info)
(match (current-command-line-arguments)
[(vector port)
(values (string->number port)
#f
rerun-default)]
[(vector port launch-token run-command)
(values (string->number port)
(elisp-read (open-input-string launch-token))
(match (elisp-read (open-input-string run-command))
[(list 'run what mem pp ctx args dbgs)
(rerun (->mod/existing what)
mem
(as-racket-bool pp)
ctx
(list->vector args)
(list->set (map string->path dbgs))
void)]
[v (eprintf "Bad arguments: ~v => ~v\n" run-command v)
(exit)]))]
[v
(eprintf "Bad arguments: ~v\n" v)
(exit)]))
(start-command-server command-port launch-token)
(start-logger-server (add1 command-port) launch-token)
;; 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 run-info)))
(define (run rr) ;rerun? -> void?
(match-define (rerun maybe-mod
mem-limit
pretty-print?
context-level
cmd-line-args
debug-files
ready-thunk) 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
(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 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))
(print-syntax-width +inf.0)
;; 2. If module, require and enter its namespace, etc.
(stx-cache:before-run maybe-mod)
(when (and maybe-mod mod-path)
(parameterize ([current-module-name-resolver module-name-resolver-for-run]
[current-eval (stx-cache:make-eval-handler maybe-mod)])
;; When exn:fail? during module load, re-run with "empty"
;; module. Note: Unlikely now that we're using
;; dynamic-require/some-namespace.
(define (load-exn-handler exn)
(display-exn exn)
(channel-put message-to-main-thread-channel
(struct-copy rerun rr [maybe-mod #f]))
(sync never-evt))
(with-handlers ([exn? load-exn-handler])
(maybe-configure-runtime mod-path) ;FIRST: see #281
(current-namespace (dynamic-require/some-namespace maybe-mod))
(maybe-warn-about-submodules mod-path context-level)
(check-top-interaction))))
(stx-cache:after-run maybe-mod)
;; 3. Tell command server to use our namespace and module.
(attach-command-server (current-namespace) maybe-mod)
;; 3b. And call the ready-thunk command-server gave us from a
;; run command, so that it can send a response for the run
;; command. Because the command server runs on a different
;; thread, it is probably waiting with (sync some-channel) and
;; the thunk will simply channel-put.
(ready-thunk)
;; 4. 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 message-to-main-thread-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 message
[(? rerun? new-rr) (run new-rr)]
[(load-gui repl?) (require-gui repl?) (run rr)]))
(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 message-to-main-thread-channel
(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))
(define (make-print-handler pretty-print?)
(cond [pretty-print? pretty-print-handler]
[else (make-plain-print-handler)]))
;; 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-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)]))))