b972a0940d
being edited in DrRacket (via places) Added an API to let tools have access to that information (and compute more stuff) Used that to make an online version of Check Syntax which led to a separately callable Check Syntax API.
2027 lines
85 KiB
Racket
2027 lines
85 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"
|
|
|
|
;; 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))
|
|
|
|
|
|
;; run a thunk, and if an exception is raised, make it possible to cut the
|
|
;; stack so that the surrounding context is hidden
|
|
(define checkpoints (make-weak-hasheq))
|
|
(define (call-with-stack-checkpoint thunk)
|
|
(define checkpoint #f)
|
|
(call-with-exception-handler
|
|
(λ (exn)
|
|
(when (and checkpoint ; just in case there's an exception before it's set
|
|
(not (hash-has-key? checkpoints exn)))
|
|
(hash-set! checkpoints exn checkpoint))
|
|
exn)
|
|
(lambda ()
|
|
(set! checkpoint (current-continuation-marks))
|
|
(thunk))))
|
|
;; returns the stack of the input exception, cutting off any tail that was
|
|
;; registered as a checkpoint
|
|
(define (cut-stack-at-checkpoint exn)
|
|
(define stack (continuation-mark-set->context (exn-continuation-marks exn)))
|
|
(define checkpoint
|
|
(cond [(hash-ref checkpoints exn #f) => continuation-mark-set->context]
|
|
[else #f]))
|
|
(if (not checkpoint)
|
|
stack
|
|
(let loop ([st stack]
|
|
[sl (length stack)]
|
|
[cp checkpoint]
|
|
[cl (length checkpoint)])
|
|
(cond [(sl . > . cl) (cons (car st) (loop (cdr st) (sub1 sl) cp cl))]
|
|
[(sl . < . cl) (loop st sl (cdr cp) (sub1 cl))]
|
|
[(equal? st cp) '()]
|
|
[else (loop st sl (cdr cp) (sub1 cl))]))))
|
|
|
|
(define-syntax-rule (with-stack-checkpoint expr)
|
|
(call-with-stack-checkpoint (lambda () expr)))
|
|
|
|
(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<%>
|
|
scheme: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
|
|
|
|
reset-pretty-print-width
|
|
|
|
|
|
|
|
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)
|
|
(let* ([cut-stack (if (and (exn? exn)
|
|
(main-user-eventspace-thread?))
|
|
(cut-stack-at-checkpoint exn)
|
|
'())]
|
|
[srclocs-stack (filter values (map cdr cut-stack))]
|
|
[stack
|
|
(filter
|
|
values
|
|
(map (λ (srcloc)
|
|
(let ([source (srcloc-source srcloc)]
|
|
[pos (srcloc-position srcloc)]
|
|
[span (srcloc-span srcloc)])
|
|
(and source pos span
|
|
srcloc)))
|
|
srclocs-stack))]
|
|
[src-locs (if (exn:srclocs? exn)
|
|
((exn:srclocs-accessor exn) exn)
|
|
(if (null? stack)
|
|
'()
|
|
(list (car srclocs-stack))))])
|
|
|
|
;; for use in debugging the stack trace stuff
|
|
#;
|
|
(when (exn? exn)
|
|
(parameterize ([print-struct #t])
|
|
(for-each
|
|
(λ (frame) (printf " ~s\n" frame))
|
|
(continuation-mark-set->context (exn-continuation-marks exn)))
|
|
(printf "\n")))
|
|
|
|
(drracket:debug:error-display-handler/stacktrace msg exn stack)))
|
|
|
|
(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)))))))))
|
|
(add-drs-function "execute" (λ (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))))
|
|
|
|
(send drs-bindings-keymap map-function "f5" "execute")
|
|
(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")
|
|
|
|
(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-instantiate ())))
|
|
|
|
;; 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/stnip 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)
|
|
(let ([before (send text last-position)])
|
|
(send text insert s before before #f)
|
|
(let ([after (send text last-position)])
|
|
(for-each (λ (delta)
|
|
(when (is-a? delta style-delta%)
|
|
(send text change-style delta before after)))
|
|
deltas)
|
|
(values before after))))
|
|
|
|
(define log-max-size 1000)
|
|
(define log-entry-max-size 1000)
|
|
|
|
(define text-mixin
|
|
(mixin ((class->interface text%)
|
|
text:ports<%>
|
|
editor:file<%>
|
|
scheme: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
|
|
invalidate-bitmap-cache
|
|
is-frozen?
|
|
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 (list file number number) (listof (list file number number))))
|
|
(define error-ranges #f)
|
|
(define/public (get-error-ranges) error-ranges)
|
|
(define internal-reset-callback void)
|
|
(define internal-reset-error-arrows-callback void)
|
|
(define/public (reset-error-ranges)
|
|
(internal-reset-callback)
|
|
(internal-reset-error-arrows-callback))
|
|
|
|
;; 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])
|
|
(let* ([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))))]
|
|
[locs (cleanup-locs raw-locs)]
|
|
[error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows))])
|
|
|
|
(reset-highlighting)
|
|
|
|
(set! error-ranges locs)
|
|
|
|
(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! internal-reset-callback
|
|
(λ ()
|
|
(set! error-ranges #f)
|
|
(when definitions-text
|
|
(send definitions-text set-error-arrows #f))
|
|
(set! internal-reset-callback 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)))))
|
|
|
|
(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 (cons start len) had-an-insert))]
|
|
[else (update-after-insert start len)]))
|
|
|
|
;; private field
|
|
(define had-an-insert '())
|
|
|
|
(define/augment (after-edit-sequence)
|
|
(inner (void) after-edit-sequence)
|
|
(let ([to-clean had-an-insert])
|
|
(set! had-an-insert '())
|
|
(for-each
|
|
(lambda (pr)
|
|
(update-after-insert (car pr) (cdr pr)))
|
|
to-clean)))
|
|
|
|
(define/private (update-after-insert start len)
|
|
(unless inserting-prompt?
|
|
(reset-highlighting))
|
|
(when (and prompt-position (< start prompt-position))
|
|
|
|
;; trim extra space, according to preferences
|
|
#;
|
|
(let* ([start (get-repl-header-end)]
|
|
[end (get-insertion-point)]
|
|
[space (- end start)]
|
|
[pref (preferences:get 'drracket:repl-buffer-size)])
|
|
(when (car pref)
|
|
(let ([max-space (* 1000 (cdr pref))])
|
|
(when (space . > . max-space)
|
|
(let ([to-delete-end (+ start (- space max-space))])
|
|
(delete/io start to-delete-end))))))
|
|
|
|
(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 (integer-in 0 255))
|
|
;; #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?)
|
|
(let* ([new-limit (and custodian-limit (+ custodian-limit custodian-limit))]
|
|
[ans (message-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 ok)
|
|
#f
|
|
(and memory-killed?
|
|
new-limit
|
|
(format "Increase memory limit to ~a megabytes"
|
|
(floor (/ new-limit 1024 1024))))
|
|
frame
|
|
'(default=1 stop)
|
|
)])
|
|
(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)
|
|
|
|
(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.)
|
|
|
|
(call-with-continuation-prompt
|
|
(λ ()
|
|
(call-with-break-parameterization
|
|
user-break-parameterization
|
|
(λ ()
|
|
(let loop ()
|
|
(let ([sexp/syntax/eof (with-stack-checkpoint (get-sexp/syntax/eof))])
|
|
(unless (eof-object? sexp/syntax/eof)
|
|
(call-with-values
|
|
(λ ()
|
|
(call-with-continuation-prompt
|
|
(λ () (with-stack-checkpoint (eval-syntax sexp/syntax/eof)))
|
|
(default-continuation-prompt-tag)
|
|
(and complete-program?
|
|
(λ args
|
|
(abort-current-continuation
|
|
(default-continuation-prompt-tag))))))
|
|
(λ x (for-each (λ (x) ((current-print) x)) x)))
|
|
(loop)))))))
|
|
(default-continuation-prompt-tag)
|
|
(λ args (void)))
|
|
|
|
(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))))
|
|
|
|
(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 "Execute".
|
|
; 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
|
|
(λ ()
|
|
;; 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)
|
|
(log-message user-logger
|
|
(vector-ref logged 0)
|
|
(vector-ref logged 1)
|
|
(vector-ref logged 2))
|
|
(loop)))
|
|
(handle-evt
|
|
user-evt
|
|
(λ (vec)
|
|
(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?
|
|
(fprintf
|
|
(current-error-port)
|
|
"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)
|
|
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)
|
|
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)
|
|
(thaw-colorer)
|
|
(send context disable-evaluation)
|
|
(reset-console)
|
|
(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)))))
|
|
|
|
(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/public (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)
|
|
(pretty-print-columns 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%
|
|
(drs-bindings-keymap-mixin
|
|
(text-mixin
|
|
(text:ports-mixin
|
|
(scheme: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%))))))))))))))
|