672910f27b
I started from tabs that are not on the beginning of lines, and in several places I did further cleanings. If you're worried about knowing who wrote some code, for example, if you get to this commit in "git blame", then note that you can use the "-w" flag in many git commands to ignore whitespaces. For example, to see per-line authors, use "git blame -w <file>". Another example: to see the (*much* smaller) non-whitespace changes in this (or any other) commit, use "git log -p -w -1 <sha1>".
2090 lines
90 KiB
Racket
2090 lines
90 KiB
Racket
#lang racket/base
|
|
|
|
#|
|
|
|
|
TODO
|
|
- should a GC should happen on each execution? (or perhaps better, each kill?)
|
|
- front-end methods have new signature
|
|
|
|
|
|
|#
|
|
; =Kernel= means in DrRacket's thread and parameterization
|
|
;
|
|
; =User= means the user's thread and parameterization
|
|
;
|
|
; =Handler= means in the handler thread of some eventspace; it must
|
|
; be combined with either =Kernel= or =User=
|
|
|
|
(require racket/class
|
|
racket/path
|
|
racket/pretty
|
|
racket/unit
|
|
racket/list
|
|
racket/port
|
|
|
|
string-constants
|
|
setup/xref
|
|
racket/gui/base
|
|
framework
|
|
browser/external
|
|
"drsig.rkt"
|
|
"local-member-names.rkt"
|
|
"stack-checkpoint.rkt"
|
|
|
|
;; the dynamic-require below loads this module,
|
|
;; so we make the dependency explicit here, even
|
|
;; tho nothing is used from this module.
|
|
planet/terse-info)
|
|
|
|
(provide rep@ with-stack-checkpoint)
|
|
|
|
(define orig-output-port (current-output-port))
|
|
(define (oprintf . args) (apply fprintf orig-output-port args))
|
|
|
|
(define no-breaks-break-parameterization
|
|
(parameterize-break #f (current-break-parameterization)))
|
|
|
|
(define-unit rep@
|
|
(import [prefix drracket:init: drracket:init^]
|
|
[prefix drracket:language-configuration: drracket:language-configuration/internal^]
|
|
[prefix drracket:language: drracket:language^]
|
|
[prefix drracket:app: drracket:app^]
|
|
[prefix drracket:frame: drracket:frame^]
|
|
[prefix drracket:unit: drracket:unit^]
|
|
[prefix drracket:text: drracket:text^]
|
|
[prefix drracket:help-desk: drracket:help-desk^]
|
|
[prefix drracket:debug: drracket:debug^]
|
|
[prefix drracket:eval: drracket:eval^]
|
|
[prefix drracket:module-language: drracket:module-language/int^]
|
|
[prefix drracket: drracket:interface^])
|
|
(export (rename drracket:rep^
|
|
[-text% text%]
|
|
[-text<%> text<%>]))
|
|
|
|
(define -text<%>
|
|
(interface ((class->interface text%)
|
|
text:ports<%>
|
|
editor:file<%>
|
|
racket:text<%>
|
|
color:text<%>)
|
|
reset-highlighting
|
|
highlight-errors
|
|
highlight-errors/exn
|
|
|
|
get-user-custodian
|
|
get-user-eventspace
|
|
get-user-thread
|
|
get-user-namespace
|
|
|
|
get-definitions-text
|
|
|
|
kill-evaluation
|
|
|
|
display-results
|
|
|
|
run-in-evaluation-thread
|
|
after-many-evals
|
|
on-execute
|
|
|
|
shutdown
|
|
|
|
get-error-ranges
|
|
reset-error-ranges
|
|
|
|
reset-console
|
|
|
|
copy-prev-previous-expr
|
|
copy-next-previous-expr
|
|
copy-previous-expr
|
|
|
|
|
|
initialize-console
|
|
|
|
get-prompt
|
|
insert-prompt
|
|
get-context))
|
|
|
|
(define sized-snip<%>
|
|
(interface ((class->interface snip%))
|
|
;; get-character-width : -> number
|
|
;; returns the number of characters wide the snip is,
|
|
;; for use in pretty printing the snip.
|
|
get-character-width))
|
|
|
|
;; current-language-settings : (parameter language-setting)
|
|
;; set to the current language and its setting on the user's thread.
|
|
(define current-language-settings (make-parameter #f))
|
|
|
|
;; current-rep : (parameter (union #f (instanceof rep:text%)))
|
|
;; the repl that controls the evaluation in this thread.
|
|
(define current-rep (make-parameter #f))
|
|
|
|
;; a port that accepts values for printing in the repl
|
|
(define current-value-port (make-parameter #f))
|
|
|
|
;; drracket-error-display-handler : (string (union #f exn) -> void
|
|
;; =User=
|
|
;; the timing is a little tricky here.
|
|
;; the file icon must appear before the error message in the text, so that happens first.
|
|
;; the highlight must be set after the error message, because inserting into the text resets
|
|
;; the highlighting.
|
|
(define (drracket-error-display-handler msg exn)
|
|
(drracket:debug:error-display-handler/stacktrace msg exn))
|
|
|
|
(define (main-user-eventspace-thread?)
|
|
(let ([rep (current-rep)])
|
|
(and rep
|
|
(eq? (eventspace-handler-thread (send rep get-user-eventspace))
|
|
(current-thread)))))
|
|
|
|
(define drs-bindings-keymap (make-object keymap:aug-keymap%))
|
|
|
|
(let* ([get-frame
|
|
(λ (obj)
|
|
(and (is-a? obj editor<%>)
|
|
(let ([canvas (send obj get-canvas)])
|
|
(and canvas
|
|
(let ([frame (send canvas get-top-level-window)])
|
|
(and (is-a? frame drracket:unit:frame%)
|
|
frame))))))]
|
|
[add-drs-function
|
|
(λ (name f)
|
|
(send drs-bindings-keymap add-function name
|
|
(λ (obj evt) (cond [(get-frame obj) => f]))))]
|
|
[show-tab
|
|
(λ (i)
|
|
(λ (obj evt)
|
|
(let ([fr (get-frame obj)])
|
|
(and fr
|
|
(is-a? fr drracket:unit:frame<%>)
|
|
(< i (send fr get-tab-count))
|
|
(begin (send fr change-to-nth-tab i)
|
|
#t)))))])
|
|
(for ([i (in-range 1 10)])
|
|
(send drs-bindings-keymap add-function (format "show-tab-~a" i) (show-tab (- i 1))))
|
|
(send drs-bindings-keymap add-function "search-help-desk"
|
|
(λ (obj evt)
|
|
(if (not (and (is-a? obj text%) (get-frame obj))) ; is `get-frame' needed?
|
|
(drracket:help-desk:help-desk)
|
|
(let* ([start (send obj get-start-position)]
|
|
[end (send obj get-end-position)]
|
|
[str (if (= start end)
|
|
(drracket:unit:find-symbol obj start)
|
|
(send obj get-text start end))])
|
|
(if (or (not str) (equal? "" str))
|
|
(drracket:help-desk:help-desk)
|
|
(let* ([l (send obj get-canvas)]
|
|
[l (and l (send l get-top-level-window))]
|
|
[l (and l (is-a? l drracket:unit:frame<%>) (send l get-definitions-text))]
|
|
[l (and l (send l get-next-settings))]
|
|
[l (and l (drracket:language-configuration:language-settings-language l))]
|
|
[ctxt (and l (send l capability-value 'drscheme:help-context-term))]
|
|
[name (and l (send l get-language-name))])
|
|
(drracket:help-desk:help-desk
|
|
str (and ctxt (list ctxt name)))))))))
|
|
|
|
;; keep this in case people use it in their keymaps
|
|
(add-drs-function "execute" (λ (frame) (send frame execute-callback)))
|
|
|
|
(add-drs-function "run" (λ (frame) (send frame execute-callback)))
|
|
(add-drs-function "next-tab" (λ (frame) (send frame next-tab)))
|
|
(add-drs-function "prev-tab" (λ (frame) (send frame prev-tab)))
|
|
(add-drs-function "collapse" (λ (frame) (send frame collapse)))
|
|
(add-drs-function "split" (λ (frame) (send frame split)))
|
|
|
|
(add-drs-function "jump-to-previous-error-loc"
|
|
(λ (frame) (send frame jump-to-previous-error-loc)))
|
|
(add-drs-function "jump-to-next-error-loc"
|
|
(λ (frame) (send frame jump-to-next-error-loc)))
|
|
|
|
(add-drs-function "send-toplevel-form-to-repl" (λ (frame) (send frame send-toplevel-form-to-repl #f)))
|
|
(add-drs-function "send-selection-to-repl" (λ (frame) (send frame send-selection-to-repl #f)))
|
|
(add-drs-function "send-toplevel-form-to-repl-and-go" (λ (frame) (send frame send-toplevel-form-to-repl #t)))
|
|
(add-drs-function "send-selection-to-repl-and-go" (λ (frame) (send frame send-selection-to-repl #t)))
|
|
(add-drs-function "move-to-interactions" (λ (frame) (send frame move-to-interactions))))
|
|
|
|
(send drs-bindings-keymap map-function "m:p" "jump-to-previous-error-loc")
|
|
(send drs-bindings-keymap map-function "m:n" "jump-to-next-error-loc")
|
|
(send drs-bindings-keymap map-function "esc;p" "jump-to-previous-error-loc")
|
|
(send drs-bindings-keymap map-function "esc;n" "jump-to-next-error-loc")
|
|
(send drs-bindings-keymap map-function "c:x;`" "jump-to-next-error-loc")
|
|
|
|
(send drs-bindings-keymap map-function "f5" "run")
|
|
(send drs-bindings-keymap map-function "f1" "search-help-desk")
|
|
(send drs-bindings-keymap map-function "c:tab" "next-tab")
|
|
(send drs-bindings-keymap map-function "c:s:tab" "prev-tab")
|
|
(send drs-bindings-keymap map-function "c:pagedown" "next-tab")
|
|
(send drs-bindings-keymap map-function "c:pageup" "prev-tab")
|
|
|
|
(send drs-bindings-keymap map-function "c:x;0" "collapse")
|
|
(send drs-bindings-keymap map-function "c:x;2" "split")
|
|
|
|
(send drs-bindings-keymap map-function "c:c;c:z" "move-to-interactions")
|
|
|
|
(for ([i (in-range 1 10)])
|
|
(send drs-bindings-keymap map-function
|
|
(format "a:~a" i)
|
|
(format "show-tab-~a" i))
|
|
(send drs-bindings-keymap map-function
|
|
(format "m:~a" i)
|
|
(format "show-tab-~a" i)))
|
|
|
|
(define (get-drs-bindings-keymap) drs-bindings-keymap)
|
|
|
|
;; drs-bindings-keymap-mixin :
|
|
;; ((implements editor:keymap<%>) -> (implements editor:keymap<%>))
|
|
;; for any x that is an instance of the resulting class,
|
|
;; (is-a? (send (send x get-canvas) get-top-level-frame) drracket:unit:frame%)
|
|
(define drs-bindings-keymap-mixin
|
|
(mixin (editor:keymap<%>) (editor:keymap<%>)
|
|
(define/override (get-keymaps)
|
|
(editor:add-after-user-keymap drs-bindings-keymap (super get-keymaps)))
|
|
(super-new)))
|
|
|
|
;; Max length of output queue (user's thread blocks if the
|
|
;; queue is full):
|
|
(define output-limit-size 2000)
|
|
|
|
(define setup-scheme-interaction-mode-keymap
|
|
(λ (keymap)
|
|
(send keymap add-function "put-previous-sexp"
|
|
(λ (text event)
|
|
(send text copy-prev-previous-expr)))
|
|
(send keymap add-function "put-next-sexp"
|
|
(λ (text event)
|
|
(send text copy-next-previous-expr)))
|
|
|
|
(keymap:send-map-function-meta keymap "p" "put-previous-sexp")
|
|
(keymap:send-map-function-meta keymap "n" "put-next-sexp")
|
|
(send keymap map-function "c:up" "put-previous-sexp")
|
|
(send keymap map-function "c:down" "put-next-sexp")))
|
|
|
|
(define scheme-interaction-mode-keymap (make-object keymap:aug-keymap%))
|
|
(setup-scheme-interaction-mode-keymap scheme-interaction-mode-keymap)
|
|
|
|
(define drs-font-delta (make-object style-delta% 'change-family 'decorative))
|
|
|
|
(define output-delta (make-object style-delta%)) ; used to be 'change-weight 'bold
|
|
(define result-delta (make-object style-delta%)) ; used to be 'change-weight 'bold
|
|
(define error-delta (make-object style-delta%
|
|
'change-style
|
|
'italic))
|
|
(send error-delta set-delta-foreground (make-object color% 255 0 0))
|
|
(send result-delta set-delta-foreground (make-object color% 0 0 175))
|
|
(send output-delta set-delta-foreground (make-object color% 150 0 150))
|
|
|
|
(define error-text-style-delta (make-object style-delta%))
|
|
(send error-text-style-delta set-delta-foreground (make-object color% 200 0 0))
|
|
|
|
(define grey-delta (make-object style-delta%))
|
|
(send grey-delta set-delta-foreground "GREY")
|
|
|
|
(define welcome-delta (make-object style-delta% 'change-family 'decorative))
|
|
(define click-delta (gui-utils:get-clickback-delta))
|
|
(define red-delta (make-object style-delta%))
|
|
(define dark-green-delta (make-object style-delta%))
|
|
(send* red-delta
|
|
(copy welcome-delta)
|
|
(set-delta-foreground "RED"))
|
|
(send* dark-green-delta
|
|
(copy welcome-delta)
|
|
(set-delta-foreground "dark green"))
|
|
(define warning-style-delta (make-object style-delta% 'change-bold))
|
|
(send* warning-style-delta
|
|
(set-delta-foreground "BLACK")
|
|
(set-delta-background "YELLOW"))
|
|
(define (get-welcome-delta) welcome-delta)
|
|
(define (get-dark-green-delta) dark-green-delta)
|
|
|
|
;; is-default-settings? : language-settings -> boolean
|
|
;; determines if the settings in `language-settings'
|
|
;; correspond to the default settings of the language.
|
|
(define (is-default-settings? language-settings)
|
|
(send (drracket:language-configuration:language-settings-language language-settings)
|
|
default-settings?
|
|
(drracket:language-configuration:language-settings-settings language-settings)))
|
|
|
|
(define (extract-language-name language-settings defs-text)
|
|
(cond
|
|
[(is-a? (drracket:language-configuration:language-settings-language language-settings)
|
|
drracket:module-language:module-language<%>)
|
|
(send (drracket:language-configuration:language-settings-language language-settings)
|
|
get-users-language-name defs-text)]
|
|
[else
|
|
(send (drracket:language-configuration:language-settings-language language-settings)
|
|
get-language-name)]))
|
|
(define (extract-language-style-delta language-settings)
|
|
(send (drracket:language-configuration:language-settings-language language-settings)
|
|
get-style-delta))
|
|
(define (extract-language-url language-settings)
|
|
(send (drracket:language-configuration:language-settings-language language-settings)
|
|
get-language-url))
|
|
|
|
(define-struct sexp (left right prompt))
|
|
|
|
(let* ([list-of? (λ (p?)
|
|
(λ (l)
|
|
(and (list? l)
|
|
(andmap p? l))))]
|
|
[snip/string? (λ (s) (or (is-a? s snip%) (string? s)))]
|
|
[list-of-snip/strings? (list-of? snip/string?)]
|
|
[list-of-lists-of-snip/strings? (list-of? list-of-snip/strings?)])
|
|
(preferences:set-default
|
|
'drracket:console-previous-exprs
|
|
null
|
|
list-of-lists-of-snip/strings?))
|
|
(define (marshall-previous-exprs lls)
|
|
(map (λ (ls)
|
|
(list
|
|
(apply
|
|
string-append
|
|
(reverse
|
|
(map (λ (s)
|
|
(cond
|
|
[(is-a? s string-snip%)
|
|
(send s get-text 0 (send s get-count))]
|
|
[(string? s) s]
|
|
[else "'non-string-snip"]))
|
|
ls)))))
|
|
lls))
|
|
(let ([unmarshall (λ (x) x)])
|
|
(preferences:set-un/marshall
|
|
'drracket:console-previous-exprs
|
|
marshall-previous-exprs unmarshall))
|
|
|
|
(define color? ((get-display-depth) . > . 8))
|
|
|
|
;; instances of this interface provide a context for a rep:text%
|
|
;; its connection to its graphical environment (ie frame) for
|
|
;; error display and status infromation is all mediated
|
|
;; through an instance of this interface.
|
|
|
|
(define file-icon
|
|
(let ([bitmap
|
|
(make-object bitmap%
|
|
(collection-file-path "file.gif" "icons"))])
|
|
(if (send bitmap ok?)
|
|
(make-object image-snip% bitmap)
|
|
(make-object string-snip% "[open file]"))))
|
|
|
|
|
|
;; insert/delta : (instanceof text%) (union snip string) (listof style-delta%) *-> (values number number)
|
|
;; inserts the string/snip into the text at the end and changes the
|
|
;; style of the newly inserted text based on the style deltas.
|
|
(define (insert/delta text s . deltas)
|
|
(define before (send text last-position))
|
|
(send text insert s before before #f)
|
|
(define after (send text last-position))
|
|
(for ([delta (in-list deltas)])
|
|
(when (is-a? delta style-delta%)
|
|
(send text change-style delta before after)))
|
|
(values before after))
|
|
|
|
(define log-max-size 1000)
|
|
(define log-entry-max-size 1000)
|
|
|
|
(define after-expression (make-parameter #f))
|
|
|
|
(define text-mixin
|
|
(mixin ((class->interface text%)
|
|
text:ports<%>
|
|
editor:file<%>
|
|
racket:text<%>
|
|
color:text<%>
|
|
text:ports<%>)
|
|
(-text<%>)
|
|
(init-field context)
|
|
(inherit auto-wrap
|
|
begin-edit-sequence
|
|
change-style
|
|
clear-box-input-port
|
|
clear-undos
|
|
clear-input-port
|
|
clear-output-ports
|
|
delete
|
|
delete/io
|
|
end-edit-sequence
|
|
erase
|
|
find-snip
|
|
find-string
|
|
freeze-colorer
|
|
get-active-canvas
|
|
get-admin
|
|
get-can-close-parent
|
|
get-canvases
|
|
get-character
|
|
get-end-position
|
|
get-err-port
|
|
get-extent
|
|
get-focus-snip
|
|
get-in-port
|
|
get-in-box-port
|
|
get-insertion-point
|
|
get-out-port
|
|
get-regions
|
|
get-snip-position
|
|
get-start-position
|
|
get-styles-fixed
|
|
get-style-list
|
|
get-text
|
|
get-top-level-window
|
|
get-unread-start-point
|
|
get-value-port
|
|
in-edit-sequence?
|
|
insert
|
|
insert-before
|
|
insert-between
|
|
is-locked?
|
|
last-position
|
|
line-location
|
|
lock
|
|
paragraph-start-position
|
|
position-line
|
|
position-paragraph
|
|
port-name-matches?
|
|
release-snip
|
|
reset-input-box
|
|
reset-regions
|
|
run-after-edit-sequence
|
|
scroll-to-position
|
|
send-eof-to-in-port
|
|
set-allow-edits
|
|
set-caret-owner
|
|
set-clickback
|
|
set-insertion-point
|
|
set-position
|
|
set-styles-sticky
|
|
set-styles-fixed
|
|
set-unread-start-point
|
|
split-snip
|
|
thaw-colorer)
|
|
|
|
(define definitions-text 'not-yet-set-definitions-text)
|
|
(define/public (set-definitions-text dt) (set! definitions-text dt))
|
|
(define/public (get-definitions-text) definitions-text)
|
|
|
|
(unless (is-a? context drracket:rep:context<%>)
|
|
(error 'drracket:rep:text%
|
|
"expected an object that implements drracket:rep:context<%> as initialization argument, got: ~e"
|
|
context))
|
|
|
|
(define/public (get-context) context)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; ;;;
|
|
;;; User -> Kernel ;;;
|
|
;;; ;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; =User= (probably doesn't matter)
|
|
(define/private queue-system-callback
|
|
(λ (ut thunk [always? #f])
|
|
(parameterize ([current-eventspace drracket:init:system-eventspace])
|
|
(queue-callback
|
|
(λ ()
|
|
(when (or always? (eq? ut (get-user-thread)))
|
|
(thunk)))
|
|
#f))))
|
|
|
|
;; =User=
|
|
(define/private queue-system-callback/sync
|
|
(λ (ut thunk)
|
|
(let ([s (make-semaphore 0)])
|
|
(queue-system-callback
|
|
ut
|
|
(λ ()
|
|
(when (eq? ut (get-user-thread))
|
|
(thunk))
|
|
(semaphore-post s))
|
|
#t)
|
|
(semaphore-wait s))))
|
|
|
|
;; display-results : (listof TST) -> void
|
|
;; prints each element of anss that is not void as values in the REPL.
|
|
(define/public (display-results anss) ; =User=, =Handler=, =Breaks=
|
|
(display-results/void (filter (λ (x) (not (void? x))) anss)))
|
|
|
|
;; display-results : (listof TST) -> void
|
|
;; prints each element of anss in the REPL.
|
|
(define/public (display-results/void anss) ; =User=, =Handler=, =Breaks=
|
|
(for-each
|
|
(λ (v)
|
|
(let* ([ls (current-language-settings)]
|
|
[lang (drracket:language-configuration:language-settings-language ls)]
|
|
[settings (drracket:language-configuration:language-settings-settings ls)])
|
|
(send lang render-value/format
|
|
v
|
|
settings
|
|
(get-value-port)
|
|
(get-repl-char-width))))
|
|
anss))
|
|
|
|
;; get-repl-char-width : -> (and/c exact? integer?)
|
|
;; returns the width of the repl in characters, or 80 if the
|
|
;; answer cannot be found.
|
|
(define/private (get-repl-char-width)
|
|
(let ([admin (get-admin)]
|
|
[standard (send (get-style-list) find-named-style "Standard")])
|
|
(if (and admin standard)
|
|
(let ([bw (box 0)])
|
|
(send admin get-view #f #f bw #f)
|
|
(let* ([dc (send admin get-dc)]
|
|
[standard-font (send standard get-font)]
|
|
[old-font (send dc get-font)])
|
|
(send dc set-font standard-font)
|
|
(let* ([char-width (send dc get-char-width)]
|
|
[answer (inexact->exact (floor (/ (unbox bw) char-width)))])
|
|
(send dc set-font old-font)
|
|
answer)))
|
|
80)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; ;;;
|
|
;;; Error Highlighting ;;;
|
|
;;; ;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; error-ranges : (union false? (cons srcloc (listof srcloc)))
|
|
(define error-ranges #f)
|
|
(define/public (get-error-ranges) error-ranges)
|
|
(define/public (set-error-ranges ranges)
|
|
(set! error-ranges (and ranges
|
|
(not (null? ranges))
|
|
(cleanup-locs ranges))))
|
|
(define clear-error-highlighting void)
|
|
(define/public (reset-error-ranges)
|
|
(set-error-ranges #f)
|
|
(when definitions-text (send definitions-text set-error-arrows #f))
|
|
(clear-error-highlighting))
|
|
|
|
;; highlight-error : file number number -> void
|
|
(define/public (highlight-error file start end)
|
|
(highlight-errors (list (make-srcloc file #f #f start (- end start))) #f))
|
|
|
|
;; highlight-errors/exn : exn -> void
|
|
;; highlights all of the errors associated with the exn (incl. arrows)
|
|
(define/public (highlight-errors/exn exn)
|
|
(let ([locs (cond
|
|
[(exn:srclocs? exn)
|
|
((exn:srclocs-accessor exn) exn)]
|
|
[else '()])])
|
|
(highlight-errors locs #f)))
|
|
|
|
;; =Kernel= =handler=
|
|
;; highlight-errors : (listof srcloc)
|
|
;; (union #f (listof srcloc))
|
|
;; -> (void)
|
|
(define/public (highlight-errors raw-locs [raw-error-arrows #f])
|
|
(clear-error-highlighting)
|
|
(when definitions-text (send definitions-text set-error-arrows #f))
|
|
(set-error-ranges raw-locs)
|
|
(define locs (or (get-error-ranges) '())) ;; calling set-error-range cleans up the locs
|
|
(define error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows)))
|
|
|
|
(for-each (λ (loc) (send (srcloc-source loc) begin-edit-sequence)) locs)
|
|
|
|
(when color?
|
|
(let ([resets
|
|
(map (λ (loc)
|
|
(let* ([file (srcloc-source loc)]
|
|
[start (- (srcloc-position loc) 1)]
|
|
[span (srcloc-span loc)]
|
|
[finish (+ start span)])
|
|
(send file highlight-range start finish (drracket:debug:get-error-color) #f 'high)))
|
|
locs)])
|
|
(when (and definitions-text error-arrows)
|
|
(let ([filtered-arrows
|
|
(remove-duplicate-error-arrows
|
|
(filter
|
|
(λ (arr) (embedded-in? (srcloc-source arr) definitions-text))
|
|
error-arrows))])
|
|
(send definitions-text set-error-arrows filtered-arrows)))
|
|
|
|
(set! clear-error-highlighting
|
|
(λ ()
|
|
(set! clear-error-highlighting void)
|
|
(for-each (λ (x) (x)) resets)))))
|
|
|
|
(let* ([first-loc (and (pair? locs) (car locs))]
|
|
[first-file (and first-loc (srcloc-source first-loc))]
|
|
[first-start (and first-loc (- (srcloc-position first-loc) 1))]
|
|
[first-span (and first-loc (srcloc-span first-loc))])
|
|
|
|
(when (and first-loc first-start first-span)
|
|
(let ([first-finish (+ first-start first-span)])
|
|
(when (eq? first-file definitions-text) ;; only move set the cursor in the defs window
|
|
(send first-file set-position first-start first-start))
|
|
(send first-file scroll-to-position first-start #f first-finish)))
|
|
|
|
(for-each (λ (loc) (send (srcloc-source loc) end-edit-sequence)) locs)
|
|
|
|
(when first-loc
|
|
|
|
(when (eq? first-file definitions-text)
|
|
;; when we're highlighting something in the defs window,
|
|
;; make sure it is visible
|
|
(let ([tlw (send first-file get-top-level-window)])
|
|
(when (is-a? tlw drracket:unit:frame<%>)
|
|
(send tlw ensure-defs-shown))))
|
|
|
|
(send first-file set-caret-owner (get-focus-snip) 'global))))
|
|
|
|
;; unlike highlight-error just above, this function does not change
|
|
;; what the currently noted errors locations are, it just highlights
|
|
;; one of them.
|
|
(define/public (highlight-a-single-error raw-loc)
|
|
(define loc (car (cleanup-locs (list raw-loc))))
|
|
(define source (srcloc-source loc))
|
|
(when (and (is-a? source text%)
|
|
(srcloc-position loc)
|
|
(srcloc-span loc))
|
|
(send source begin-edit-sequence)
|
|
|
|
(clear-error-highlighting) ;; clear the 'highlight-range' from previous errors
|
|
|
|
(define start (- (srcloc-position loc) 1))
|
|
(define span (srcloc-span loc))
|
|
(define finish (+ start span))
|
|
|
|
(let ([reset (send source highlight-range start finish (drracket:debug:get-error-color) #f 'high)])
|
|
(set! clear-error-highlighting
|
|
(λ ()
|
|
(set! clear-error-highlighting void)
|
|
(reset))))
|
|
|
|
(when (and start span)
|
|
(let ([finish (+ start span)])
|
|
(when (eq? source definitions-text) ;; only move set the cursor in the defs window
|
|
(send source set-position start span))
|
|
(send source scroll-to-position start #f finish)))
|
|
|
|
(send source end-edit-sequence)
|
|
|
|
(when (eq? source definitions-text)
|
|
;; when we're highlighting something in the defs window,
|
|
;; make sure it is visible
|
|
(let ([tlw (send source get-top-level-window)])
|
|
(when (is-a? tlw drracket:unit:frame<%>)
|
|
(send tlw ensure-defs-shown))))
|
|
|
|
(send source set-caret-owner (get-focus-snip) 'global)))
|
|
|
|
(define/private (cleanup-locs locs)
|
|
(let ([ht (make-hasheq)])
|
|
(filter (λ (loc) (and (is-a? (srcloc-source loc) text:basic<%>)
|
|
(number? (srcloc-position loc))
|
|
(number? (srcloc-span loc))))
|
|
(map (λ (srcloc)
|
|
(cond
|
|
[(hash-ref ht (srcloc-source srcloc) #f)
|
|
=>
|
|
(λ (e)
|
|
(make-srcloc e
|
|
(srcloc-line srcloc)
|
|
(srcloc-column srcloc)
|
|
(srcloc-position srcloc)
|
|
(srcloc-span srcloc)))]
|
|
[(send definitions-text port-name-matches? (srcloc-source srcloc))
|
|
(hash-set! ht (srcloc-source srcloc) definitions-text)
|
|
(make-srcloc definitions-text
|
|
(srcloc-line srcloc)
|
|
(srcloc-column srcloc)
|
|
(srcloc-position srcloc)
|
|
(srcloc-span srcloc))]
|
|
[(port-name-matches? (srcloc-source srcloc))
|
|
(hash-set! ht (srcloc-source srcloc) this)
|
|
(make-srcloc this
|
|
(srcloc-line srcloc)
|
|
(srcloc-column srcloc)
|
|
(srcloc-position srcloc)
|
|
(srcloc-span srcloc))]
|
|
[(and (symbol? (srcloc-source srcloc))
|
|
(text:lookup-port-name (srcloc-source srcloc)))
|
|
=>
|
|
(lambda (editor)
|
|
(make-srcloc editor
|
|
(srcloc-line srcloc)
|
|
(srcloc-column srcloc)
|
|
(srcloc-position srcloc)
|
|
(srcloc-span srcloc)))]
|
|
[else srcloc]))
|
|
locs))))
|
|
|
|
(define highlights-can-be-reset (make-parameter #t))
|
|
(define/public (reset-highlighting)
|
|
(when (highlights-can-be-reset) (reset-error-ranges)))
|
|
(define/public (call-without-reset-highlighting thunk)
|
|
(parameterize ([highlights-can-be-reset #f])
|
|
(thunk)))
|
|
|
|
;; remove-duplicate-error-arrows : (listof X) -> (listof X)
|
|
;; duplicate arrows point from and to the same place -- only
|
|
;; need one arrow for each pair of locations they point to.
|
|
(define/private (remove-duplicate-error-arrows error-arrows)
|
|
(let ([ht (make-hash)])
|
|
(let loop ([arrs error-arrows]
|
|
[n 0])
|
|
(unless (null? arrs)
|
|
(hash-set! ht (car arrs) n)
|
|
(loop (cdr arrs) (+ n 1))))
|
|
(let* ([unsorted (hash-map ht list)]
|
|
[sorted (sort unsorted (λ (x y) (<= (cadr x) (cadr y))))]
|
|
[arrs (map car sorted)])
|
|
arrs)))
|
|
|
|
(define/private (embedded-in? txt-inner txt-outer)
|
|
(let loop ([txt-inner txt-inner])
|
|
(cond
|
|
[(eq? txt-inner txt-outer) #t]
|
|
[else (let ([admin (send txt-inner get-admin)])
|
|
(and (is-a? admin editor-snip-editor-admin<%>)
|
|
(loop (send (send (send admin get-snip) get-admin) get-editor))))])))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; specialization
|
|
;;
|
|
|
|
(define/override (after-io-insertion)
|
|
(super after-io-insertion)
|
|
(let ([frame (get-frame)])
|
|
(when frame
|
|
(let ([tab (send definitions-text get-tab)])
|
|
(when (eq? (send frame get-current-tab) tab)
|
|
(send context ensure-rep-shown this))))))
|
|
|
|
(define/augment (after-insert start len)
|
|
(inner (void) after-insert start len)
|
|
(cond
|
|
[(in-edit-sequence?)
|
|
(set! had-an-insert (cons start had-an-insert))]
|
|
[else (update-after-inserts (list start))]))
|
|
|
|
;; private field
|
|
(define had-an-insert '())
|
|
|
|
(define/augment (after-edit-sequence)
|
|
(inner (void) after-edit-sequence)
|
|
(unless (null? had-an-insert)
|
|
(let ([to-clean had-an-insert])
|
|
(set! had-an-insert '())
|
|
(update-after-inserts to-clean))))
|
|
|
|
(define/private (update-after-inserts starts)
|
|
(unless inserting-prompt?
|
|
(reset-highlighting))
|
|
(when (and prompt-position
|
|
(ormap (λ (start) (< start prompt-position))
|
|
starts))
|
|
(set! prompt-position (get-unread-start-point))
|
|
(reset-regions (append (all-but-last (get-regions))
|
|
(list (list prompt-position 'end))))))
|
|
|
|
(define/augment (after-delete x y)
|
|
(unless inserting-prompt?
|
|
(reset-highlighting))
|
|
(inner (void) after-delete x y))
|
|
|
|
(define/override (get-keymaps)
|
|
(editor:add-after-user-keymap scheme-interaction-mode-keymap
|
|
(super get-keymaps)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; ;;;
|
|
;;; Evaluation ;;;
|
|
;;; ;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define/public (eval-busy?)
|
|
(not (and (get-user-thread)
|
|
(thread-running? (get-user-thread)))))
|
|
|
|
(field (user-language-settings #f)
|
|
(user-custodian-parent #f)
|
|
(memory-killed-cust-box #f)
|
|
(user-custodian #f)
|
|
(custodian-limit (and (custodian-memory-accounting-available?)
|
|
(preferences:get 'drracket:child-only-memory-limit)))
|
|
(user-eventspace-box (make-weak-box #f))
|
|
(user-namespace-box (make-weak-box #f))
|
|
(user-eventspace-main-thread #f)
|
|
(user-break-parameterization #f)
|
|
(user-logger (make-logger))
|
|
|
|
;; user-exit-code (union #f byte?)
|
|
;; #f indicates that exit wasn't called. Integer indicates exit code
|
|
(user-exit-code #f))
|
|
|
|
(define/public (get-user-language-settings) user-language-settings)
|
|
(define/public (get-user-custodian) user-custodian)
|
|
(define/public (get-user-eventspace) (weak-box-value user-eventspace-box))
|
|
(define/public (get-user-thread) user-eventspace-main-thread)
|
|
(define/public (get-user-namespace) (weak-box-value user-namespace-box))
|
|
(define/pubment (get-user-break-parameterization) user-break-parameterization) ;; final method
|
|
(define/pubment (get-custodian-limit) custodian-limit)
|
|
(define/pubment (set-custodian-limit c) (set! custodian-limit c))
|
|
(field (in-evaluation? #f)
|
|
(ask-about-kill? #f))
|
|
(define/public (get-in-evaluation?) in-evaluation?)
|
|
|
|
(define/public-final (insert-warning message)
|
|
(let ([locked? (is-locked?)])
|
|
(when locked? (lock #f))
|
|
(begin-edit-sequence)
|
|
(let ([start (get-unread-start-point)])
|
|
(insert-before message)
|
|
(let ([end (get-unread-start-point)])
|
|
(change-style warning-style-delta start end)
|
|
(insert-before "\n")))
|
|
(end-edit-sequence)
|
|
(when locked? (lock #t))))
|
|
|
|
(field (show-no-user-evaluation-message? #t))
|
|
|
|
;; use this to be able to kill the evaluator without the popup dialog
|
|
(define/public (set-show-no-user-evaluation-message? b)
|
|
(set! show-no-user-evaluation-message? b))
|
|
|
|
(define/private (cleanup)
|
|
(set! in-evaluation? #f)
|
|
(update-running #f)
|
|
(unless (and (get-user-thread) (thread-running? (get-user-thread)))
|
|
(lock #t)
|
|
(when (and show-no-user-evaluation-message? (not shutting-down?))
|
|
(no-user-evaluation-message
|
|
(get-frame)
|
|
user-exit-code
|
|
(not (custodian-box-value memory-killed-cust-box))))
|
|
(set! show-no-user-evaluation-message? #t)))
|
|
|
|
(field (need-interaction-cleanup? #f))
|
|
|
|
(define/private (no-user-evaluation-message frame exit-code memory-killed?)
|
|
(define new-limit (and custodian-limit (+ custodian-limit custodian-limit)))
|
|
(define-values (ans checked?)
|
|
(if (preferences:get 'drracket:show-killed-dialog)
|
|
(message+check-box/custom
|
|
(string-constant evaluation-terminated)
|
|
(string-append
|
|
(string-constant evaluation-terminated-explanation)
|
|
(if exit-code
|
|
(string-append
|
|
"\n\n"
|
|
(if (zero? exit-code)
|
|
(string-constant exited-successfully)
|
|
(format (string-constant exited-with-error-code) exit-code)))
|
|
"")
|
|
(if memory-killed?
|
|
(string-append
|
|
"\n\n"
|
|
(string-constant program-ran-out-of-memory))
|
|
""))
|
|
(string-constant evaluation-terminated-ask)
|
|
(string-constant ok)
|
|
#f
|
|
(and memory-killed?
|
|
new-limit
|
|
(format "Increase memory limit to ~a megabytes"
|
|
(floor (/ new-limit 1024 1024))))
|
|
frame
|
|
'(default=1 stop checked)
|
|
#:dialog-mixin frame:focus-table-mixin)
|
|
(values 1 #t)))
|
|
(unless checked?
|
|
(preferences:set 'drracket:show-killed-dialog #f))
|
|
(when (equal? ans 3)
|
|
(set-custodian-limit new-limit)
|
|
(preferences:set 'drracket:child-only-memory-limit new-limit))
|
|
(set-insertion-point (last-position))
|
|
(insert-warning "\nInteractions disabled"))
|
|
|
|
(define/private (cleanup-interaction) ; =Kernel=, =Handler=
|
|
(set! need-interaction-cleanup? #f)
|
|
(begin-edit-sequence)
|
|
(set-caret-owner #f 'display)
|
|
(cleanup)
|
|
(end-edit-sequence)
|
|
(send context set-breakables #f #f)
|
|
(send context enable-evaluation))
|
|
|
|
(define/augment (submit-to-port? key)
|
|
(or (eq? (send key get-key-code) 'numpad-enter)
|
|
(send key get-control-down)
|
|
(send key get-alt-down)
|
|
(and prompt-position
|
|
(let ([lang (drracket:language-configuration:language-settings-language user-language-settings)])
|
|
(cond
|
|
[(is-a? lang drracket:module-language:module-language<%>)
|
|
(let ([pred
|
|
(send lang get-language-info
|
|
'drracket:submit-predicate
|
|
(λ (port only-whitespace-afterwards?)
|
|
(and only-whitespace-afterwards?
|
|
(submit-predicate this prompt-position))))])
|
|
(pred
|
|
;; no good! giving away the farm here. need to hand
|
|
;; over a proxy that is limited to just read access
|
|
(open-input-text-editor this prompt-position)
|
|
(only-whitespace-after-insertion-point)))]
|
|
[else
|
|
(and (only-whitespace-after-insertion-point)
|
|
(submit-predicate this prompt-position))])))))
|
|
|
|
(define/private (only-whitespace-after-insertion-point)
|
|
(let ([start (get-start-position)]
|
|
[end (get-end-position)])
|
|
(and (= start end)
|
|
(let loop ([pos start])
|
|
(cond
|
|
[(= pos (last-position)) #t]
|
|
[else (and (char-whitespace? (get-character pos))
|
|
(loop (+ pos 1)))])))))
|
|
|
|
(define/augment (on-submit)
|
|
(inner (void) on-submit)
|
|
(when (and (get-user-thread)
|
|
(thread-running? (get-user-thread)))
|
|
;; the -2 drops the last newline from history (why -2 and not -1?!)
|
|
(save-interaction-in-history prompt-position (- (last-position) 2))
|
|
|
|
(let* ([old-regions (get-regions)]
|
|
[abl (all-but-last old-regions)]
|
|
[lst (last old-regions)])
|
|
(reset-regions (append abl (list (list (list-ref lst 0) (last-position))))))
|
|
|
|
(send context repl-submit-happened)
|
|
|
|
;; lets us know we are done with this one interaction
|
|
;; (since there may be multiple expressions at the prompt)
|
|
(send-eof-to-in-port)
|
|
|
|
(set! prompt-position #f)
|
|
(evaluate-from-port
|
|
(get-in-port)
|
|
#f
|
|
(λ ()
|
|
;; clear out the eof object if it wasn't consumed
|
|
(clear-input-port)))))
|
|
|
|
(inherit get-backward-sexp)
|
|
(define/override (on-local-char key)
|
|
(let ([start (get-start-position)]
|
|
[end (get-end-position)]
|
|
[code (send key get-key-code)])
|
|
(cond
|
|
[(not (or (eq? code 'numpad-enter)
|
|
(equal? code #\return)
|
|
(equal? code #\newline)))
|
|
(super on-local-char key)]
|
|
[(not prompt-position)
|
|
;; evaluating? just drop the keypress
|
|
(void)]
|
|
[(and (< end prompt-position)
|
|
(= start end)
|
|
(get-backward-sexp end))
|
|
=>
|
|
(λ (sexp-start)
|
|
(copy-down sexp-start end))]
|
|
[(and (< end prompt-position)
|
|
(not (= start end)))
|
|
(copy-down start end)]
|
|
[else
|
|
(super on-local-char key)])))
|
|
|
|
(define/private (copy-down start end)
|
|
(begin-edit-sequence)
|
|
(split-snip start)
|
|
(split-snip end)
|
|
(let loop ([snip (find-snip start 'after-or-none)])
|
|
(when snip
|
|
(let ([pos (+ (get-snip-position snip)
|
|
(send snip get-count))])
|
|
(when (<= pos end)
|
|
(insert (send snip copy) (last-position) (last-position))
|
|
(loop (send snip next))))))
|
|
(set-position (last-position) (last-position))
|
|
(end-edit-sequence))
|
|
|
|
;; prompt-position : (union #f integer)
|
|
;; the position just after the last prompt
|
|
(field (prompt-position #f))
|
|
(define inserting-prompt? #f)
|
|
(define/public (get-prompt) "> ")
|
|
(define/public (insert-prompt)
|
|
(set! inserting-prompt? #t)
|
|
(begin-edit-sequence)
|
|
(reset-input-box)
|
|
(let* ([pmt (get-prompt)]
|
|
[prompt-space (string-length pmt)])
|
|
|
|
;; insert the prompt, possibly inserting a newline first
|
|
(let* ([usp (get-unread-start-point)]
|
|
[usp-para (position-paragraph usp)]
|
|
[usp-para-start (paragraph-start-position usp-para)])
|
|
(unless (equal? usp usp-para-start)
|
|
(insert-between "\n")
|
|
(set! prompt-space (+ prompt-space 1)))
|
|
(insert-between pmt))
|
|
|
|
(let ([sp (get-unread-start-point)])
|
|
(set! prompt-position sp)
|
|
(reset-regions (append (get-regions) (list (list sp 'end))))))
|
|
(end-edit-sequence)
|
|
(set! inserting-prompt? #f))
|
|
|
|
(field [submit-predicate (λ (text prompt-position) #t)])
|
|
(define/public (set-submit-predicate p)
|
|
(set! submit-predicate p))
|
|
|
|
(define/public (evaluate-from-port port complete-program? cleanup) ; =Kernel=, =Handler=
|
|
(send context disable-evaluation)
|
|
(send context reset-offer-kill)
|
|
(send context set-breakables (get-user-thread) (get-user-custodian))
|
|
(reset-pretty-print-width)
|
|
(set! in-evaluation? #t)
|
|
(update-running #t)
|
|
(set! need-interaction-cleanup? #t)
|
|
(define the-after-expression (after-expression))
|
|
|
|
(run-in-evaluation-thread
|
|
(λ () ; =User=, =Handler=, =No-Breaks=
|
|
(let* ([settings (current-language-settings)]
|
|
[lang (drracket:language-configuration:language-settings-language settings)]
|
|
[settings (drracket:language-configuration:language-settings-settings settings)]
|
|
[dummy-value (box #f)]
|
|
[get-sexp/syntax/eof
|
|
(if complete-program?
|
|
(send lang front-end/complete-program port settings)
|
|
(send lang front-end/interaction port settings))])
|
|
|
|
; Evaluate the user's expression. We're careful to turn on
|
|
; breaks as we go in and turn them off as we go out.
|
|
; (Actually, we adjust breaks however the user wanted it.)
|
|
|
|
|
|
;; this binding of last-results is to catch the results
|
|
;; that come from throwing to the prompt instead of
|
|
;; a normal exit
|
|
(define last-results
|
|
(call-with-values
|
|
(λ ()
|
|
(call-with-continuation-prompt
|
|
(λ ()
|
|
(call-with-break-parameterization
|
|
user-break-parameterization
|
|
(λ ()
|
|
(let loop ()
|
|
(define sexp/syntax/eof (with-stack-checkpoint (get-sexp/syntax/eof)))
|
|
(cond
|
|
[(eof-object? sexp/syntax/eof) (abort-current-continuation
|
|
(default-continuation-prompt-tag)
|
|
(λ () (values)))]
|
|
[else
|
|
(define results
|
|
(call-with-values
|
|
(λ ()
|
|
;; we duplicate the 'expand-syntax-to-top-form' dance that eval-syntax
|
|
;; does here, so that we can put 'with-stack-checkpoint's in to limit
|
|
;; the amount of DrRacket code we see in stacktraces
|
|
(let loop ([stx sexp/syntax/eof])
|
|
(define top-expanded (with-stack-checkpoint (expand-syntax-to-top-form stx)))
|
|
(syntax-case top-expanded (begin)
|
|
[(begin a1 . args)
|
|
(let lloop ([args (syntax->list #'(a1 . args))])
|
|
(cond
|
|
[(null? (cdr args))
|
|
(loop (car args))]
|
|
[else
|
|
(loop (car args))
|
|
(lloop (cdr args))]))]
|
|
[_
|
|
(let ([expanded (with-stack-checkpoint (expand-syntax top-expanded))])
|
|
(call-with-continuation-prompt
|
|
(λ ()
|
|
(with-stack-checkpoint (eval-syntax expanded)))
|
|
(default-continuation-prompt-tag)
|
|
(λ args
|
|
(apply
|
|
abort-current-continuation
|
|
(default-continuation-prompt-tag)
|
|
args))))])))
|
|
list))
|
|
(parameterize ([pretty-print-columns pretty-print-width])
|
|
(for ([x (in-list results)])
|
|
((current-print) x)))
|
|
(loop)])))))
|
|
(default-continuation-prompt-tag)
|
|
(letrec ([me
|
|
(λ args
|
|
(cond
|
|
[(and (pair? args)
|
|
(null? (cdr args))
|
|
(procedure? (car args))
|
|
(procedure-arity-includes? (car args) 0))
|
|
(call-with-continuation-prompt (car args)
|
|
(default-continuation-prompt-tag)
|
|
me)]
|
|
[else
|
|
(call-with-continuation-prompt
|
|
(λ ()
|
|
(call-with-continuation-prompt
|
|
(λ ()
|
|
(apply
|
|
abort-current-continuation
|
|
(default-continuation-prompt-tag)
|
|
args)))))]))])
|
|
me)))
|
|
list))
|
|
(parameterize ([pretty-print-columns pretty-print-width])
|
|
(for ([x (in-list last-results)])
|
|
((current-print) x)))
|
|
|
|
(when complete-program?
|
|
(call-with-continuation-prompt
|
|
(λ ()
|
|
(call-with-break-parameterization
|
|
user-break-parameterization
|
|
(λ ()
|
|
(send lang front-end/finished-complete-program settings))))
|
|
(default-continuation-prompt-tag)
|
|
(λ args (void))))
|
|
|
|
(when the-after-expression
|
|
(call-with-continuation-prompt
|
|
(λ ()
|
|
(the-after-expression))))
|
|
|
|
(set! in-evaluation? #f)
|
|
(update-running #f)
|
|
(cleanup)
|
|
(flush-output (get-value-port))
|
|
(queue-system-callback/sync
|
|
(get-user-thread)
|
|
(λ () ; =Kernel=, =Handler=
|
|
(after-many-evals)
|
|
(cleanup-interaction)
|
|
(insert-prompt)))))))
|
|
|
|
;; =User=, =Handler=
|
|
(define/pubment (on-execute rout) (inner (void) on-execute rout))
|
|
|
|
;; =Kernel=, =Handler=
|
|
(define/pubment (after-many-evals) (inner (void) after-many-evals))
|
|
|
|
(define/private shutdown-user-custodian ; =Kernel=, =Handler=
|
|
; Use this procedure to shutdown when in the middle of other cleanup
|
|
; operations, such as when the user clicks "Run".
|
|
; Don't use it to kill a thread where other, external cleanup
|
|
; actions must occur (e.g., the exit handler for the user's
|
|
; thread). In that case, shut down user-custodian directly.
|
|
(λ ()
|
|
(when user-custodian
|
|
(custodian-shutdown-all user-custodian))
|
|
(set! user-custodian #f)
|
|
(set! user-eventspace-main-thread #f)))
|
|
|
|
(define/public (kill-evaluation) ; =Kernel=, =Handler=
|
|
(when user-custodian
|
|
(custodian-shutdown-all user-custodian))
|
|
(set! user-custodian #f))
|
|
|
|
(field (eval-thread-thunks null)
|
|
(eval-thread-state-sema 'not-yet-state-sema)
|
|
(eval-thread-queue-sema 'not-yet-thread-sema)
|
|
|
|
(cleanup-sucessful 'not-yet-cleanup-sucessful)
|
|
(cleanup-semaphore 'not-yet-cleanup-semaphore)
|
|
(thread-killed 'not-yet-thread-killed))
|
|
(define/private (initialize-killed-thread) ; =Kernel=
|
|
(when (thread? thread-killed)
|
|
(kill-thread thread-killed))
|
|
(set! thread-killed
|
|
(thread
|
|
(λ () ; =Kernel=
|
|
(let ([ut (get-user-thread)])
|
|
(thread-wait ut)
|
|
(queue-system-callback
|
|
ut
|
|
(λ () ; =Kernel=, =Handler=
|
|
(if need-interaction-cleanup?
|
|
(cleanup-interaction)
|
|
(cleanup))
|
|
;; HACK: lock the interactions now; the reason for this
|
|
;; is that `cleanup-interaction' invokes
|
|
;; `enable-evaluation', and in "unit.rkt" this is defined
|
|
;; to unlock the interactions which might make sense in
|
|
;; that context.
|
|
(lock #t))))))))
|
|
|
|
(define/public (run-in-evaluation-thread thunk) ; =Kernel=
|
|
(semaphore-wait eval-thread-state-sema)
|
|
(set! eval-thread-thunks (append eval-thread-thunks (list thunk)))
|
|
(semaphore-post eval-thread-state-sema)
|
|
(semaphore-post eval-thread-queue-sema))
|
|
|
|
(define/private (init-evaluation-thread) ; =Kernel=
|
|
(set! user-language-settings (send definitions-text get-next-settings))
|
|
|
|
(set! user-custodian-parent (make-custodian))
|
|
(set! user-custodian (parameterize ([current-custodian user-custodian-parent])
|
|
(make-custodian)))
|
|
(set! memory-killed-cust-box (make-custodian-box user-custodian-parent #t))
|
|
(when custodian-limit
|
|
(custodian-limit-memory user-custodian-parent
|
|
custodian-limit
|
|
user-custodian-parent))
|
|
(let ([user-eventspace (parameterize ([current-custodian user-custodian])
|
|
(make-eventspace))])
|
|
(set! user-eventspace-box (make-weak-box user-eventspace))
|
|
(set! user-break-parameterization (parameterize-break
|
|
#t
|
|
(current-break-parameterization)))
|
|
(set! eval-thread-thunks null)
|
|
(set! eval-thread-state-sema (make-semaphore 1))
|
|
(set! eval-thread-queue-sema (make-semaphore 0))
|
|
(set! user-exit-code #f)
|
|
|
|
(reset-logger-messages)
|
|
|
|
(let* ([init-thread-complete (make-semaphore 0)]
|
|
[goahead (make-semaphore)])
|
|
|
|
; setup standard parameters
|
|
(let ([snip-classes
|
|
; the snip-classes in the DrRacket eventspace's snip-class-list
|
|
(drracket:eval:get-snip-classes)]
|
|
[drs-eventspace (current-eventspace)])
|
|
(queue-user/wait
|
|
(λ () ; =User=, =No-Breaks=
|
|
; No user code has been evaluated yet, so we're in the clear...
|
|
(break-enabled #f)
|
|
(set! user-eventspace-main-thread (current-thread))
|
|
|
|
(current-logger user-logger)
|
|
|
|
(thread
|
|
(λ ()
|
|
(struct gui-event (start? msec name) #:prefab)
|
|
;; forward system events the user's logger, and record any
|
|
;; events that happen on the user's logger to show in the GUI
|
|
(let ([sys-evt (make-log-receiver drracket:init:system-logger 'debug)]
|
|
[user-evt (make-log-receiver user-logger 'debug)])
|
|
(let loop ()
|
|
(sync
|
|
(handle-evt
|
|
sys-evt
|
|
(λ (logged)
|
|
(unless (gui-event? (vector-ref logged 2))
|
|
(log-message user-logger
|
|
(vector-ref logged 0)
|
|
(vector-ref logged 1)
|
|
(vector-ref logged 2)))
|
|
(loop)))
|
|
(handle-evt
|
|
user-evt
|
|
(λ (vec)
|
|
(unless (gui-event? (vector-ref vec 2))
|
|
(parameterize ([current-eventspace drracket:init:system-eventspace])
|
|
(queue-callback (λ () (new-log-message vec)))))
|
|
(loop))))))))
|
|
|
|
(initialize-parameters snip-classes)
|
|
(let ([drracket-exit-handler
|
|
(λ (x)
|
|
(parameterize-break
|
|
#f
|
|
(let ([s (make-semaphore)])
|
|
(parameterize ([current-eventspace drs-eventspace])
|
|
(queue-callback
|
|
(λ ()
|
|
(set! user-exit-code
|
|
(if (exact-integer? x)
|
|
(modulo x 256)
|
|
0))
|
|
(semaphore-post s))))
|
|
(semaphore-wait s)
|
|
(custodian-shutdown-all user-custodian))))])
|
|
(exit-handler drracket-exit-handler)))))
|
|
|
|
|
|
(queue-user/wait
|
|
(λ ()
|
|
;; register drscheme with the planet-terse-register for the user's namespace
|
|
;; must be called after 'initialize-parameters' is called (since it initializes
|
|
;; the user's namespace)
|
|
(planet-terse-set-key (namespace-module-registry (current-namespace)))
|
|
(planet-terse-register
|
|
(lambda (tag package)
|
|
(parameterize ([current-eventspace drracket:init:system-eventspace])
|
|
(queue-callback (λ () (new-planet-info tag package))))))))
|
|
|
|
;; disable breaks until an evaluation actually occurs
|
|
(send context set-breakables #f #f)
|
|
|
|
;; initialize the language
|
|
(send (drracket:language-configuration:language-settings-language user-language-settings)
|
|
on-execute
|
|
(drracket:language-configuration:language-settings-settings user-language-settings)
|
|
(let ([run-on-user-thread (lambda (t)
|
|
(queue-user/wait
|
|
(λ ()
|
|
(with-handlers ((exn? (λ (x) (oprintf "~s\n" (exn-message x)))))
|
|
(t)))))])
|
|
run-on-user-thread))
|
|
|
|
;; setup the special repl values
|
|
(let ([raised-exn? #f]
|
|
[exn #f])
|
|
(queue-user/wait
|
|
(λ () ; =User=, =No-Breaks=
|
|
(with-handlers ((void (λ (x)
|
|
(set! exn x)
|
|
(set! raised-exn? #t))))
|
|
(drracket:language:setup-setup-values))))
|
|
(when raised-exn?
|
|
(eprintf
|
|
(string-append
|
|
"copied exn raised when setting up snip values"
|
|
" (thunk passed as third argume to drracket:language:add-snip-value)\n"))
|
|
(raise exn)))
|
|
|
|
;; allow extensions to this class to do some setup work
|
|
(on-execute
|
|
(let ([run-on-user-thread (lambda (t) (queue-user/wait t))])
|
|
run-on-user-thread))
|
|
|
|
(parameterize ([current-eventspace user-eventspace])
|
|
(queue-callback
|
|
(λ ()
|
|
(set! in-evaluation? #f)
|
|
(update-running #f)
|
|
(send context set-breakables #f #f)
|
|
|
|
;; after this returns, future event dispatches
|
|
;; will use the user's break parameterization
|
|
(initialize-dispatch-handler)
|
|
|
|
;; let init-thread procedure return,
|
|
;; now that parameters are set
|
|
(semaphore-post init-thread-complete)
|
|
|
|
; We're about to start running user code.
|
|
|
|
; Pause to let killed-thread get initialized
|
|
(semaphore-wait goahead)
|
|
|
|
(let loop () ; =User=, =Handler=, =No-Breaks=
|
|
; Wait for something to do
|
|
(unless (semaphore-try-wait? eval-thread-queue-sema)
|
|
; User event callbacks run here; we turn on
|
|
; breaks in the dispatch handler.
|
|
(yield eval-thread-queue-sema))
|
|
; About to eval something
|
|
(semaphore-wait eval-thread-state-sema)
|
|
(let ([thunk (car eval-thread-thunks)])
|
|
(set! eval-thread-thunks (cdr eval-thread-thunks))
|
|
(semaphore-post eval-thread-state-sema)
|
|
; This thunk evals the user's expressions with appropriate
|
|
; protections.
|
|
(thunk))
|
|
(loop)))))
|
|
(semaphore-wait init-thread-complete)
|
|
; Start killed-thread
|
|
(initialize-killed-thread)
|
|
; Let user expressions go...
|
|
(semaphore-post goahead))))
|
|
|
|
(define/private (queue-user/wait thnk)
|
|
(let ([wait (make-semaphore 0)])
|
|
(parameterize ([current-eventspace (get-user-eventspace)])
|
|
(queue-callback
|
|
(λ ()
|
|
(thnk)
|
|
(semaphore-post wait))))
|
|
(semaphore-wait wait)))
|
|
|
|
(field (shutting-down? #f))
|
|
|
|
(define/override (allow-close-with-no-filename?) #t)
|
|
(define/augment (can-close?)
|
|
(and (cond
|
|
[in-evaluation?
|
|
(equal? (message-box/custom
|
|
(string-constant drscheme)
|
|
(string-constant program-is-still-running)
|
|
(string-constant close-anyway)
|
|
(string-constant cancel)
|
|
#f
|
|
(or (get-top-level-window) (get-can-close-parent))
|
|
'(default=1 caution)
|
|
2
|
|
#:dialog-mixin frame:focus-table-mixin)
|
|
1)]
|
|
[(let ([user-eventspace (get-user-eventspace)])
|
|
(and user-eventspace
|
|
(parameterize ([current-eventspace user-eventspace])
|
|
(not (null? (get-top-level-windows))))))
|
|
(equal? (message-box/custom
|
|
(string-constant drscheme)
|
|
(string-constant program-has-open-windows)
|
|
(string-constant close-anyway)
|
|
(string-constant cancel)
|
|
#f
|
|
(or (get-top-level-window) (get-can-close-parent))
|
|
'(default=1 caution)
|
|
2
|
|
#:dialog-mixin frame:focus-table-mixin)
|
|
1)]
|
|
[else #t])
|
|
(inner #t can-close?)))
|
|
|
|
(define/augment (on-close)
|
|
(shutdown)
|
|
(preferences:set 'drracket:console-previous-exprs
|
|
(trim-previous-exprs
|
|
(append
|
|
(preferences:get 'drracket:console-previous-exprs)
|
|
local-previous-exprs)))
|
|
(inner (void) on-close))
|
|
|
|
(define/public (shutdown) ; =Kernel=, =Handler=
|
|
(set! shutting-down? #t)
|
|
(when (thread? thread-killed)
|
|
(kill-thread thread-killed)
|
|
(set! thread-killed #f))
|
|
(shutdown-user-custodian))
|
|
|
|
(define/private update-running ; =User=, =Handler=, =No-Breaks=
|
|
(λ (bool)
|
|
(queue-system-callback
|
|
(get-user-thread)
|
|
(λ ()
|
|
(send context update-running bool)))))
|
|
|
|
(define logger-editor #f)
|
|
(define logger-messages '())
|
|
(define/public (get-logger-messages) logger-messages)
|
|
(define/private (new-log-message vec)
|
|
(let* ([level (vector-ref vec 0)]
|
|
[str (cond
|
|
[(<= (string-length (vector-ref vec 1)) log-entry-max-size)
|
|
(vector-ref vec 1)]
|
|
[else
|
|
(substring (vector-ref vec 1) 0 log-entry-max-size)])]
|
|
[msg (vector level str)])
|
|
(cond
|
|
[(< (length logger-messages) log-max-size)
|
|
(set! logger-messages (cons msg logger-messages))
|
|
(update-logger-gui (cons 'add-line msg))]
|
|
[else
|
|
(set! logger-messages
|
|
(cons
|
|
msg
|
|
(let loop ([msgs logger-messages])
|
|
(cond
|
|
[(null? (cdr msgs)) null]
|
|
[else (cons (car msgs) (loop (cdr msgs)))]))))
|
|
(update-logger-gui (cons 'clear-last-line-and-add-line msg))])))
|
|
|
|
(define/private (reset-logger-messages)
|
|
(set! logger-messages '())
|
|
(update-logger-gui #f))
|
|
|
|
(define/private (update-logger-gui command)
|
|
(let ([tab (send definitions-text get-tab)])
|
|
(send tab update-logger-window command)))
|
|
|
|
(define/private (new-planet-info tag package)
|
|
(let ([frame (get-frame)])
|
|
(when frame
|
|
(send (send frame get-current-tab) new-planet-status tag package))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; ;;;
|
|
;;; Execution ;;;
|
|
;;; ;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; initialize-paramters : (listof snip-class%) -> void
|
|
(define/private (initialize-parameters snip-classes) ; =User=
|
|
|
|
(current-language-settings user-language-settings)
|
|
(error-print-source-location #f)
|
|
(error-display-handler drracket-error-display-handler)
|
|
(current-load-relative-directory #f)
|
|
(current-custodian user-custodian)
|
|
(current-load text-editor-load-handler)
|
|
|
|
(drracket:eval:set-basic-parameters snip-classes)
|
|
(current-rep this)
|
|
(let ([dir (or (send context get-directory)
|
|
drracket:init:first-dir)])
|
|
(current-directory dir))
|
|
|
|
(set! user-namespace-box (make-weak-box (current-namespace)))
|
|
|
|
(current-output-port (get-out-port))
|
|
(current-error-port (get-err-port))
|
|
(current-value-port (get-value-port))
|
|
(current-input-port (get-in-box-port))
|
|
|
|
(current-print (lambda (v) (display-results (list v)))))
|
|
|
|
(define/private (initialize-dispatch-handler) ;;; =User=
|
|
(let* ([primitive-dispatch-handler (event-dispatch-handler)])
|
|
(event-dispatch-handler
|
|
(letrec ([drscheme-event-dispatch-handler ; <= a name for #<...> printout
|
|
(λ (eventspace) ; =User=, =Handler=
|
|
; Breaking is enabled if the user turned on breaks and
|
|
; is in a `yield'. If we get a break, that's ok, because
|
|
; the kernel never queues an event in the user's eventspace.
|
|
(cond
|
|
[(eq? eventspace (get-user-eventspace))
|
|
; =User=, =Handler=
|
|
|
|
; We must distinguish between "top-level" events and
|
|
; those within `yield' in the user's program.
|
|
(cond
|
|
[(not in-evaluation?)
|
|
;; at this point, we must not be in a nested dispatch, so we can
|
|
;; just disable breaks and rely on call-with-break-parameterization
|
|
;; to restore them to the user's setting.
|
|
(call-with-break-parameterization
|
|
no-breaks-break-parameterization
|
|
(λ ()
|
|
; =No-Breaks=
|
|
(send context reset-offer-kill)
|
|
(send context set-breakables (get-user-thread) (get-user-custodian))
|
|
(call-with-continuation-prompt
|
|
(λ () ; =User=, =Handler=, =No-Breaks=
|
|
(call-with-break-parameterization
|
|
user-break-parameterization
|
|
(λ () (primitive-dispatch-handler eventspace)))))
|
|
|
|
;; in principle, the line below might cause
|
|
;; "race conditions" in the GUI. That is, there might
|
|
;; be many little events that the user won't quite
|
|
;; be able to break.
|
|
(send context set-breakables #f #f)))]
|
|
[else
|
|
; Nested dispatch; don't adjust interface
|
|
(primitive-dispatch-handler eventspace)])]
|
|
[else
|
|
; =User=, =Non-Handler=, =No-Breaks=
|
|
(primitive-dispatch-handler eventspace)]))])
|
|
drscheme-event-dispatch-handler))))
|
|
|
|
(define/public (reset-console)
|
|
(when (thread? thread-killed)
|
|
(kill-thread thread-killed))
|
|
(send context clear-annotations)
|
|
(drracket:debug:hide-backtrace-window)
|
|
(shutdown-user-custodian)
|
|
(clear-input-port)
|
|
(clear-box-input-port)
|
|
(clear-output-ports)
|
|
(set-allow-edits #t)
|
|
|
|
;; in case the last evaluation thread was killed, clean up some state.
|
|
(lock #f)
|
|
(set! in-evaluation? #f)
|
|
(update-running #f)
|
|
|
|
;; clear out repl first before doing any work.
|
|
(begin-edit-sequence)
|
|
(set! prompt-position #f)
|
|
(reset-input-box)
|
|
(delete (paragraph-start-position 1) (last-position))
|
|
(end-edit-sequence)
|
|
|
|
;; must init-evaluation-thread before determining
|
|
;; the language's name, since this updates user-language-settings
|
|
(init-evaluation-thread)
|
|
|
|
(begin-edit-sequence)
|
|
(set-position (last-position) (last-position))
|
|
|
|
(set! setting-up-repl? #t)
|
|
(insert/delta this (string-append (string-constant language) ": ") welcome-delta)
|
|
(let-values (((before after)
|
|
(insert/delta
|
|
this
|
|
(extract-language-name user-language-settings definitions-text)
|
|
dark-green-delta
|
|
(extract-language-style-delta user-language-settings)))
|
|
((url) (extract-language-url user-language-settings)))
|
|
(when url
|
|
(set-clickback before after (λ args (send-url url))
|
|
click-delta)))
|
|
(unless (is-default-settings? user-language-settings)
|
|
(insert/delta this (string-append " [" (string-constant custom) "]") dark-green-delta))
|
|
(when custodian-limit
|
|
(insert/delta this
|
|
"; memory limit: "
|
|
welcome-delta)
|
|
(insert/delta this
|
|
(format "~a MB" (floor (/ custodian-limit 1024 1024)))
|
|
dark-green-delta))
|
|
(insert/delta this ".\n" welcome-delta)
|
|
|
|
(let ([osf (get-styles-fixed)])
|
|
(set-styles-fixed #f)
|
|
(send (drracket:language-configuration:language-settings-language user-language-settings)
|
|
extra-repl-information
|
|
(drracket:language-configuration:language-settings-settings user-language-settings)
|
|
(open-output-text-editor this 'end))
|
|
(set-styles-fixed osf))
|
|
|
|
(set! setting-up-repl? #f)
|
|
|
|
(reset-regions (list (list (last-position) (last-position))))
|
|
(set-unread-start-point (last-position))
|
|
(set-insertion-point (last-position))
|
|
(set! indenting-limit (last-position))
|
|
(set-allow-edits #f)
|
|
(set! repl-header-end #f)
|
|
(end-edit-sequence))
|
|
|
|
(define/public (initialize-console)
|
|
(begin-edit-sequence)
|
|
(freeze-colorer)
|
|
(set! setting-up-repl? #t)
|
|
(insert/delta this (string-append (string-constant welcome-to) " ") welcome-delta)
|
|
(let-values ([(before after)
|
|
(insert/delta this
|
|
(string-constant drscheme)
|
|
click-delta
|
|
drs-font-delta)])
|
|
(insert/delta this (format (string-append ", " (string-constant version) " ~a [~a].\n")
|
|
(version:version) (system-type 'gc))
|
|
welcome-delta)
|
|
(set-clickback before after
|
|
(λ args (drracket:app:about-drscheme))
|
|
click-delta))
|
|
(set! setting-up-repl? #f)
|
|
(send context disable-evaluation)
|
|
(reset-console)
|
|
(thaw-colorer)
|
|
(insert-prompt)
|
|
|
|
;; call the first-opened method on the user's thread, but wait here for that to terminate
|
|
(let ([lang (drracket:language-configuration:language-settings-language user-language-settings)]
|
|
[drr-evtspace (current-eventspace)]
|
|
[s (make-semaphore 0)])
|
|
|
|
(define-values (sp-err-other-end sp-err) (make-pipe-with-specials))
|
|
(define-values (sp-out-other-end sp-out) (make-pipe-with-specials))
|
|
(define io-chan (make-channel))
|
|
|
|
;; collect the IO to replay later
|
|
(thread
|
|
(λ ()
|
|
(let loop ([ports (list sp-err-other-end sp-out-other-end)]
|
|
[io '()])
|
|
(cond
|
|
[(null? ports) (channel-put io-chan io)]
|
|
[else
|
|
(apply sync
|
|
(map (λ (port) (handle-evt
|
|
port
|
|
(λ (_)
|
|
(define byte/special (read-byte-or-special port))
|
|
(if (eof-object? byte/special)
|
|
(loop (remq port ports) io)
|
|
(loop ports (cons (cons port byte/special)
|
|
io))))))
|
|
ports))]))))
|
|
|
|
(run-in-evaluation-thread
|
|
(λ ()
|
|
(let/ec k
|
|
;; we set the io ports here to ones that just collect the data
|
|
;; since we're blocking the eventspace handler thread (and thus IO to
|
|
;; the user's ports can deadlock)
|
|
(parameterize ([error-escape-handler (λ () (k (void)))]
|
|
[current-output-port sp-out]
|
|
[current-error-port sp-err])
|
|
(cond
|
|
;; this is for backwards compatibility; drracket used to
|
|
;; expect this method to be a thunk (but that was a bad decision)
|
|
[(object-method-arity-includes? lang 'first-opened 1)
|
|
(send lang first-opened
|
|
(drracket:language-configuration:language-settings-settings user-language-settings))]
|
|
[else
|
|
;; this is the backwards compatible case.
|
|
(send lang first-opened)])))
|
|
(semaphore-post s)))
|
|
|
|
;; wait for the first-opened method to finish up
|
|
(semaphore-wait s)
|
|
|
|
;; close the output ports to get the above thread to terminate
|
|
(close-output-port sp-err)
|
|
(close-output-port sp-out)
|
|
|
|
;; duplicate it over to the user's ports, now that there is
|
|
;; no danger of deadlock
|
|
(for ([i (in-list (reverse (channel-get io-chan)))])
|
|
(define obj (cdr i))
|
|
|
|
((if (byte? obj) write-byte write-special)
|
|
obj
|
|
(if (eq? (car i) sp-err-other-end)
|
|
(get-err-port)
|
|
(get-out-port))))
|
|
(flush-output (get-err-port))
|
|
(flush-output (get-out-port)))
|
|
|
|
(send context enable-evaluation)
|
|
(end-edit-sequence)
|
|
(clear-undos))
|
|
|
|
(define indenting-limit 0)
|
|
(define/override (get-limit n)
|
|
(cond
|
|
[(< n indenting-limit) 0]
|
|
[else indenting-limit]))
|
|
|
|
;; avoid calling paragraph-start-position very often.
|
|
(define repl-header-end #f)
|
|
(define/private (get-repl-header-end)
|
|
(if repl-header-end
|
|
repl-header-end
|
|
(begin (set! repl-header-end (paragraph-start-position 2))
|
|
repl-header-end)))
|
|
|
|
(define setting-up-repl? #f)
|
|
(define/augment (can-change-style? start len)
|
|
(and (inner #t can-change-style? start len)
|
|
(or setting-up-repl?
|
|
(start . >= . (get-repl-header-end)))))
|
|
|
|
(define/private (last-str l)
|
|
(if (null? (cdr l))
|
|
(car l)
|
|
(last-str (cdr l))))
|
|
|
|
(field (previous-expr-pos -1))
|
|
|
|
(define/public (copy-previous-expr)
|
|
(when prompt-position
|
|
(let ([snip/strings (list-ref (get-previous-exprs) previous-expr-pos)])
|
|
(begin-edit-sequence)
|
|
(delete prompt-position (last-position) #f)
|
|
(for-each (λ (snip/string)
|
|
(insert (if (is-a? snip/string snip%)
|
|
(send snip/string copy)
|
|
snip/string)
|
|
prompt-position))
|
|
snip/strings)
|
|
(set-position (last-position))
|
|
(end-edit-sequence))))
|
|
|
|
(define/public (copy-next-previous-expr)
|
|
(let ([previous-exprs (get-previous-exprs)])
|
|
(unless (null? previous-exprs)
|
|
(set! previous-expr-pos
|
|
(if (< (add1 previous-expr-pos) (length previous-exprs))
|
|
(add1 previous-expr-pos)
|
|
0))
|
|
(copy-previous-expr))))
|
|
(define/public (copy-prev-previous-expr)
|
|
(let ([previous-exprs (get-previous-exprs)])
|
|
(unless (null? previous-exprs)
|
|
(set! previous-expr-pos
|
|
(if (previous-expr-pos . <= . 0)
|
|
(sub1 (length previous-exprs))
|
|
(sub1 previous-expr-pos)))
|
|
(copy-previous-expr))))
|
|
|
|
;; private fields
|
|
(define global-previous-exprs (preferences:get 'drracket:console-previous-exprs))
|
|
(define local-previous-exprs null)
|
|
(define/private (get-previous-exprs)
|
|
(append global-previous-exprs local-previous-exprs))
|
|
(define/private (add-to-previous-exprs snips)
|
|
(set! local-previous-exprs (append local-previous-exprs (list snips))))
|
|
|
|
; list-of-lists-of-snip/strings? -> list-of-lists-of-snip/strings?
|
|
(define/private (trim-previous-exprs lst)
|
|
(define max-size 10000)
|
|
(define (expr-size expr)
|
|
(for/fold ([s 0]) ([e expr]) (+ s (string-length e))))
|
|
(define within-bound
|
|
(let loop ([marshalled (reverse (marshall-previous-exprs lst))]
|
|
[keep 0]
|
|
[sum 0])
|
|
(if (empty? marshalled)
|
|
keep
|
|
(let* ([size (expr-size (first marshalled))]
|
|
[w/another (+ size sum)])
|
|
(if (> w/another max-size)
|
|
keep
|
|
(loop (rest marshalled) (add1 keep) w/another))))))
|
|
(take-right lst within-bound))
|
|
|
|
(define/private (save-interaction-in-history start end)
|
|
(split-snip start)
|
|
(split-snip end)
|
|
(let ([snips
|
|
(let loop ([snip (find-snip start 'after-or-none)]
|
|
[snips null])
|
|
(cond
|
|
[(not snip) snips]
|
|
[((get-snip-position snip) . <= . end)
|
|
(loop (send snip next)
|
|
(cons (send snip copy) snips))]
|
|
[else snips]))])
|
|
(set! previous-expr-pos -1)
|
|
(add-to-previous-exprs snips)))
|
|
|
|
(define pretty-print-width (pretty-print-columns))
|
|
(define/private (reset-pretty-print-width)
|
|
(let* ([standard (send (get-style-list) find-named-style "Standard")])
|
|
(when standard
|
|
(let* ([admin (get-admin)]
|
|
[width
|
|
(let ([bw (box 0)]
|
|
[b2 (box 0)])
|
|
(send admin get-view b2 b2 bw b2)
|
|
(unbox bw))]
|
|
[dc (send admin get-dc)]
|
|
[new-font (send standard get-font)]
|
|
[old-font (send dc get-font)])
|
|
(send dc set-font new-font)
|
|
(let* ([char-width (send dc get-char-width)]
|
|
[min-columns 50]
|
|
[new-columns (max min-columns
|
|
(floor (/ width char-width)))])
|
|
(send dc set-font old-font)
|
|
(set! pretty-print-width new-columns))))))
|
|
|
|
;; get-frame : -> (or/c #f (is-a?/c frame))
|
|
(define/private (get-frame)
|
|
(let ([c (get-any-canvas)])
|
|
(and c (send c get-top-level-window))))
|
|
|
|
|
|
;; returns the most recently active canvas or, if no canvas
|
|
;; has ever been active, it returns just any canvas
|
|
(define/private (get-any-canvas)
|
|
(or (get-active-canvas)
|
|
(let ([canvases (get-canvases)])
|
|
(and (not (null? canvases))
|
|
(car canvases)))))
|
|
|
|
(inherit paragraph-end-position)
|
|
(define/override (get-start-of-line pos)
|
|
(define para (position-paragraph pos))
|
|
(define para-start (paragraph-start-position para))
|
|
(define para-end (paragraph-end-position para))
|
|
(define after-prompt-start
|
|
(let* ([prompt (get-prompt)]
|
|
[para-start-text (get-text para-start (+ para-start (string-length prompt)))])
|
|
(cond
|
|
[(equal? prompt para-start-text)
|
|
(+ para-start (string-length prompt))]
|
|
[else
|
|
para-start])))
|
|
(define first-non-whitespace
|
|
(let loop ([i after-prompt-start])
|
|
(cond
|
|
[(= i para-end) #f]
|
|
[(char-whitespace? (get-character i))
|
|
(loop (+ i 1))]
|
|
[else i])))
|
|
(define new-pos
|
|
(cond
|
|
[(not first-non-whitespace) after-prompt-start]
|
|
[(< pos after-prompt-start) after-prompt-start]
|
|
[(= pos after-prompt-start) first-non-whitespace]
|
|
[(<= pos first-non-whitespace) after-prompt-start]
|
|
[else first-non-whitespace]))
|
|
new-pos)
|
|
|
|
(super-new)
|
|
(auto-wrap #t)
|
|
(set-styles-sticky #f)
|
|
|
|
(inherit set-max-undo-history)
|
|
(set-max-undo-history 'forever)))
|
|
|
|
(define (all-but-last lst)
|
|
(let loop ([o lst])
|
|
(cond
|
|
[(null? o) null]
|
|
[(null? (cdr o)) null]
|
|
[else (cons (car o) (loop (cdr o)))])))
|
|
|
|
(define input-delta (make-object style-delta%))
|
|
(send input-delta set-delta-foreground (make-object color% 0 150 0))
|
|
|
|
;; insert-error-in-text : (is-a?/c text%)
|
|
;; (union #f (is-a?/c drracket:rep:text<%>))
|
|
;; string?
|
|
;; exn?
|
|
;; (union false? (and/c string? directory-exists?))
|
|
;; ->
|
|
;; void?
|
|
(define (insert-error-in-text text interactions-text msg exn user-dir)
|
|
(insert-error-in-text/highlight-errors
|
|
text
|
|
(λ (l) (send interactions-text highlight-errors l))
|
|
msg
|
|
exn
|
|
user-dir))
|
|
|
|
;; insert-error-in-text/highlight-errors : (is-a?/c text%)
|
|
;; ((listof (list text% number number)) -> void)
|
|
;; string?
|
|
;; exn?
|
|
;; (union false? (and/c string? directory-exists?))
|
|
;; ->
|
|
;; void?
|
|
(define (insert-error-in-text/highlight-errors text highlight-errors msg exn user-dir)
|
|
(let ([locked? (send text is-locked?)]
|
|
[insert-file-name/icon
|
|
;; insert-file-name/icon : string number number number number -> void
|
|
(λ (source-name start span row col)
|
|
(let ([range-spec
|
|
(cond
|
|
[(and row col)
|
|
(format ":~a:~a" row col)]
|
|
[start
|
|
(format "::~a" start)]
|
|
[else ""])])
|
|
(cond
|
|
[(file-exists? source-name)
|
|
(let* ([normalized-name (normalize-path source-name)]
|
|
[short-name (if user-dir
|
|
(find-relative-path user-dir normalized-name)
|
|
source-name)])
|
|
(let-values ([(icon-start icon-end) (insert/delta text (send file-icon copy))]
|
|
[(space-start space-end) (insert/delta text " ")]
|
|
[(name-start name-end) (insert/delta text short-name)]
|
|
[(range-start range-end) (insert/delta text range-spec)]
|
|
[(colon-start colon-ent) (insert/delta text ": ")])
|
|
(when (number? start)
|
|
(send text set-clickback icon-start range-end
|
|
(λ (_1 _2 _3)
|
|
(open-file-and-highlight normalized-name
|
|
(- start 1)
|
|
(if span
|
|
(+ start -1 span)
|
|
start)))))))]
|
|
[else
|
|
(insert/delta text source-name)
|
|
(insert/delta text range-spec)
|
|
(insert/delta text ": ")])))])
|
|
(send text begin-edit-sequence)
|
|
(send text lock #f)
|
|
(cond
|
|
[(exn:fail:syntax? exn)
|
|
(for-each
|
|
(λ (expr)
|
|
(let ([src (and (syntax? expr) (syntax-source expr))]
|
|
[pos (and (syntax? expr) (syntax-position expr))]
|
|
[span (and (syntax? expr) (syntax-span expr))]
|
|
[col (and (syntax? expr) (syntax-column expr))]
|
|
[line (and (syntax? expr) (syntax-line expr))])
|
|
(when (and (string? src)
|
|
(number? pos)
|
|
(number? span)
|
|
(number? line)
|
|
(number? col))
|
|
(insert-file-name/icon src pos span line col))
|
|
(insert/delta text (format "~a" (exn-message exn)) error-delta)
|
|
(when (and (error-print-source-location)
|
|
(syntax? expr))
|
|
(insert/delta text " in: ")
|
|
(insert/delta text (format "~s" (syntax->datum expr)) error-text-style-delta))
|
|
(insert/delta text "\n")
|
|
(when (and (is-a? src text:basic<%>)
|
|
(number? pos)
|
|
(number? span))
|
|
(highlight-errors (list (list src (- pos 1) (+ pos -1 span)))))))
|
|
(exn:fail:syntax-exprs exn))]
|
|
[(exn:fail:read? exn)
|
|
'(let ([src (exn:read-source exn)]
|
|
[pos (exn:read-position exn)]
|
|
[span (exn:read-span exn)]
|
|
[line (exn:read-line exn)]
|
|
[col (exn:read-column exn)])
|
|
(when (and (string? src)
|
|
(number? pos)
|
|
(number? span)
|
|
(number? line)
|
|
(number? col))
|
|
(insert-file-name/icon src pos span line col))
|
|
(insert/delta text (format "~a" (exn-message exn)) error-delta)
|
|
(insert/delta text "\n")
|
|
(when (and (is-a? src text:basic<%>)
|
|
(number? pos)
|
|
(number? span))
|
|
(highlight-errors (list (list src (- pos 1) (+ pos -1 span))))))]
|
|
[(exn? exn)
|
|
(insert/delta text (format "~a" (exn-message exn)) error-delta)
|
|
(insert/delta text "\n")]
|
|
[else
|
|
(insert/delta text "uncaught exception: " error-delta)
|
|
(insert/delta text (format "~s" exn) error-delta)
|
|
(insert/delta text "\n")])
|
|
(send text lock locked?)
|
|
(send text end-edit-sequence)))
|
|
|
|
|
|
;; open-file-and-highlight : string (union number #f) (union number #f)
|
|
;; =Kernel, =Handler=
|
|
;; opens the file named by filename. If position is #f,
|
|
;; doesn't highlight anything. If position is a number and other-position
|
|
;; is #f, highlights the range from position to the end of sexp.
|
|
;; if other-position is a number, highlights from position to
|
|
;; other position.
|
|
(define (open-file-and-highlight filename position other-position)
|
|
(let ([file (handler:edit-file filename)])
|
|
(when (and (is-a? file drracket:unit:frame%)
|
|
position)
|
|
(if other-position
|
|
(send (send file get-interactions-text)
|
|
highlight-error
|
|
(send file get-definitions-text)
|
|
position
|
|
other-position)
|
|
(send (send file get-interactions-text)
|
|
highlight-error/forward-sexp
|
|
(send file get-definitions-text)
|
|
position)))))
|
|
|
|
(define drs-autocomplete-mixin
|
|
(λ (get-defs x)
|
|
(class (text:autocomplete-mixin x)
|
|
(define/override (get-all-words)
|
|
(let* ([definitions-text (get-defs this)]
|
|
[settings (send definitions-text get-next-settings)]
|
|
[language (drracket:language-configuration:language-settings-language settings)])
|
|
(send language capability-value 'drscheme:autocomplete-words)))
|
|
(super-new))))
|
|
|
|
(define -text%
|
|
(text-mixin
|
|
;; drs-bindings-keymap-mixin has to come
|
|
;; before text-mixin so that the keymaps
|
|
;; get added in the right order (specifically
|
|
;; so that esc;n and esc;p work right in the
|
|
;; repl (prev and next interaction) and in the defs
|
|
;; (previous and next error))
|
|
(drs-bindings-keymap-mixin
|
|
(text:ports-mixin
|
|
(racket:text-mixin
|
|
(color:text-mixin
|
|
(text:info-mixin
|
|
(editor:info-mixin
|
|
(text:searching-mixin
|
|
(mode:host-text-mixin
|
|
(drs-autocomplete-mixin
|
|
(λ (txt) (send txt get-definitions-text))
|
|
(text:foreground-color-mixin
|
|
(text:normalize-paste-mixin
|
|
text:clever-file-format%))))))))))))))
|