1664 lines
74 KiB
Scheme
1664 lines
74 KiB
Scheme
#|
|
|
|
|
TODO
|
|
- should a GC should happen on each execution? (or perhaps better, each kill?)
|
|
- front-end methods have new signature
|
|
|
|
|
|
|#
|
|
; =Kernel= means in DrScheme'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=
|
|
|
|
;; WARNING: printf is rebound in this module to always use the
|
|
;; original stdin/stdout of drscheme, instead of the
|
|
;; user's io ports, to aid any debugging printouts.
|
|
;; (esp. useful when debugging the users's io)
|
|
(module rep mzscheme
|
|
(require (lib "unitsig.ss")
|
|
(lib "class.ss")
|
|
(lib "file.ss")
|
|
(lib "pretty.ss")
|
|
(lib "etc.ss")
|
|
(lib "list.ss")
|
|
(lib "port.ss")
|
|
"drsig.ss"
|
|
(lib "string-constant.ss" "string-constants")
|
|
(lib "mred.ss" "mred")
|
|
(lib "framework.ss" "framework")
|
|
(lib "external.ss" "browser")
|
|
(lib "default-lexer.ss" "syntax-color"))
|
|
|
|
(provide rep@)
|
|
|
|
(define rep@
|
|
(unit/sig drscheme:rep^
|
|
(import (drscheme:init : drscheme:init^)
|
|
(drscheme:language-configuration : drscheme:language-configuration/internal^)
|
|
(drscheme:language : drscheme:language^)
|
|
(drscheme:app : drscheme:app^)
|
|
(drscheme:frame : drscheme:frame^)
|
|
(drscheme:unit : drscheme:unit^)
|
|
(drscheme:text : drscheme:text^)
|
|
(drscheme:help-desk : drscheme:help-desk^)
|
|
(drscheme:teachpack : drscheme:teachpack^)
|
|
(drscheme:debug : drscheme:debug^)
|
|
[drscheme:eval : drscheme:eval^])
|
|
|
|
(rename [-text% text%]
|
|
[-text<%> text<%>])
|
|
|
|
(define -text<%>
|
|
(interface ((class->interface text%)
|
|
text:ports<%>
|
|
editor:file<%>
|
|
scheme:text<%>
|
|
color:text<%>
|
|
text:ports<%>)
|
|
reset-highlighting
|
|
highlight-errors
|
|
highlight-errors/exn
|
|
|
|
get-user-custodian
|
|
get-user-eventspace
|
|
get-user-thread
|
|
get-user-namespace
|
|
get-user-teachpack-cache
|
|
set-user-teachpack-cache
|
|
|
|
get-definitions-text
|
|
|
|
kill-evaluation
|
|
|
|
display-results
|
|
|
|
run-in-evaluation-thread
|
|
after-many-evals
|
|
|
|
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 context<%>
|
|
(interface ()
|
|
ensure-rep-shown ;; (interactions-text -> void)
|
|
;; make the rep visible in the frame
|
|
|
|
needs-execution? ;; (-> boolean)
|
|
;; ask if things have changed that would mean the repl is out
|
|
;; of sync with the program being executed in it.
|
|
|
|
enable-evaluation ;; (-> void)
|
|
;; make the context enable all methods of evaluation
|
|
;; (disable buttons, menus, etc)
|
|
|
|
disable-evaluation ;; (-> void)
|
|
;; make the context enable all methods of evaluation
|
|
;; (disable buttons, menus, etc)
|
|
|
|
set-breakables ;; (union thread #f) (union custodian #f) -> void
|
|
;; the context might initiate breaks or kills to
|
|
;; the thread passed to this function
|
|
|
|
get-breakables ;; -> (values (union thread #f) (union custodian #f))
|
|
;; returns the last values passed to set-breakables.
|
|
|
|
reset-offer-kill ;; (-> void)
|
|
;; the next time the break button is pushed, it will only
|
|
;; break. (if the break button is clicked twice without
|
|
;; this method being called in between, it will offer to
|
|
;; kill the user's program)
|
|
|
|
update-running ;; (boolean -> void)
|
|
;; a callback to indicate that the repl may have changed its running state
|
|
;; use the repls' get-in-evaluation? method to find out what the current state is.
|
|
|
|
clear-annotations ;; (-> void)
|
|
;; clear any error highlighting context
|
|
|
|
get-directory ;; (-> (union #f string[existing directory]))
|
|
;; returns the directory that should be the default for
|
|
;; the `current-directory' and `current-load-relative-directory'
|
|
;; parameters in the repl.
|
|
))
|
|
|
|
(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))
|
|
|
|
;; an error escape continuation that the user program can't
|
|
;; change; DrScheme sets it, we use a parameter instead of an
|
|
;; object field so that there's no non-weak pointer to the
|
|
;; continuation from DrScheme.
|
|
(define current-error-escape-k (make-parameter void))
|
|
|
|
;; drscheme-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 (drscheme-error-display-handler msg exn)
|
|
(let ([src-locs (if (exn:srclocs? exn)
|
|
((exn:srclocs-accessor exn) exn)
|
|
'())])
|
|
(for-each drscheme:debug:display-srcloc-in-error src-locs)
|
|
(display msg (current-error-port))
|
|
(when (exn:fail:syntax? exn)
|
|
(drscheme:debug:show-syntax-error-context (current-error-port) exn))
|
|
(newline (current-error-port))
|
|
(flush-output (current-error-port))
|
|
(let ([rep (current-rep)])
|
|
(when (and (is-a? rep -text<%>)
|
|
(eq? (current-error-port) (send rep get-err-port)))
|
|
(parameterize ([current-eventspace drscheme:init:system-eventspace])
|
|
(queue-callback
|
|
(λ ()
|
|
(send rep highlight-errors/exn exn))))))))
|
|
|
|
;; drscheme-error-value->string-handler : TST number -> string
|
|
(define (drscheme-error-value->string-handler x n)
|
|
(let ([port (open-output-string)])
|
|
|
|
;; using a string port here means no snips allowed,
|
|
;; even though this string may eventually end up
|
|
;; displayed in a place where snips are allowed.
|
|
(print x port)
|
|
|
|
(let* ([long-string (get-output-string port)])
|
|
(close-output-port port)
|
|
(if (<= (string-length long-string) n)
|
|
long-string
|
|
(let ([short-string (substring long-string 0 n)]
|
|
[trim 3])
|
|
(unless (n . <= . trim)
|
|
(let loop ([i trim])
|
|
(unless (i . <= . 0)
|
|
(string-set! short-string (- n i) #\.)
|
|
(loop (sub1 i)))))
|
|
short-string)))))
|
|
|
|
(define drs-bindings-keymap (make-object keymap:aug-keymap%))
|
|
|
|
(send drs-bindings-keymap add-function
|
|
"search-help-desk"
|
|
(λ (obj evt)
|
|
(cond
|
|
[(is-a? obj text%)
|
|
(let* ([start (send obj get-start-position)]
|
|
[end (send obj get-end-position)]
|
|
[str (if (= start end)
|
|
(drscheme:unit:find-symbol obj start)
|
|
(send obj get-text start end))])
|
|
(if (equal? "" str)
|
|
(drscheme:help-desk:help-desk)
|
|
(let ([language (let ([canvas (send obj get-canvas)])
|
|
(and canvas
|
|
(let ([tlw (send canvas get-top-level-window)])
|
|
(and (is-a? tlw drscheme:unit:frame<%>)
|
|
(send (send tlw get-definitions-text)
|
|
get-next-settings)))))])
|
|
(drscheme:help-desk:help-desk str #f 'keyword+index 'contains language))))]
|
|
[else
|
|
(drscheme:help-desk:help-desk)])))
|
|
(let ([with-drs-frame
|
|
(λ (obj f)
|
|
(when (is-a? obj editor<%>)
|
|
(let ([canvas (send obj get-canvas)])
|
|
(when canvas
|
|
(let ([frame (send canvas get-top-level-window)])
|
|
(when (is-a? frame drscheme:unit:frame%)
|
|
(f frame)))))))])
|
|
|
|
(send drs-bindings-keymap add-function
|
|
"execute"
|
|
(λ (obj evt)
|
|
(with-drs-frame
|
|
obj
|
|
(λ (frame)
|
|
(send frame execute-callback)))))
|
|
|
|
(send drs-bindings-keymap add-function
|
|
"toggle-focus-between-definitions-and-interactions"
|
|
(λ (obj evt)
|
|
(with-drs-frame
|
|
obj
|
|
(λ (frame)
|
|
(cond
|
|
[(send (send frame get-definitions-canvas) has-focus?)
|
|
(send (send frame get-interactions-canvas) focus)]
|
|
[else
|
|
(send (send frame get-definitions-canvas) focus)])))))
|
|
(send drs-bindings-keymap add-function
|
|
"next-tab"
|
|
(λ (obj evt)
|
|
(with-drs-frame
|
|
obj
|
|
(λ (frame) (send frame next-tab)))))
|
|
(send drs-bindings-keymap add-function
|
|
"prev-tab"
|
|
(λ (obj evt)
|
|
(with-drs-frame
|
|
obj
|
|
(λ (frame) (send frame prev-tab))))))
|
|
|
|
(send drs-bindings-keymap map-function "c:x;o" "toggle-focus-between-definitions-and-interactions")
|
|
(send drs-bindings-keymap map-function "c:tab" "toggle-focus-between-definitions-and-interactions")
|
|
(send drs-bindings-keymap map-function "c:shift:tab" "toggle-focus-between-definitions-and-interactions")
|
|
(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 "d:s:right" "next-tab")
|
|
(send drs-bindings-keymap map-function "d:s:left" "prev-tab")
|
|
(send drs-bindings-keymap map-function "c:pagedown" "next-tab")
|
|
(send drs-bindings-keymap map-function "c:pageup" "prev-tab")
|
|
|
|
(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) drscheme:unit:frame%)
|
|
(define drs-bindings-keymap-mixin
|
|
(mixin (editor:keymap<%>) (editor:keymap<%>)
|
|
(define/override (get-keymaps)
|
|
(cons 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 (printf . args) (apply fprintf drscheme:init:original-output-port args))
|
|
|
|
(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")))
|
|
|
|
(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
|
|
'slant))
|
|
(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"))
|
|
|
|
;; 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 (drscheme:language-configuration:language-settings-language language-settings)
|
|
default-settings?
|
|
(drscheme:language-configuration:language-settings-settings language-settings)))
|
|
|
|
(define (extract-language-name language-settings)
|
|
(send (drscheme:language-configuration:language-settings-language language-settings)
|
|
get-language-name))
|
|
(define (extract-language-style-delta language-settings)
|
|
(send (drscheme:language-configuration:language-settings-language language-settings)
|
|
get-style-delta))
|
|
(define (extract-language-url language-settings)
|
|
(send (drscheme:language-configuration:language-settings-language language-settings)
|
|
get-language-url))
|
|
|
|
(define-struct sexp (left right prompt))
|
|
|
|
(define console-max-save-previous-exprs 30)
|
|
(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
|
|
'drscheme:console-previous-exprs
|
|
null
|
|
list-of-lists-of-snip/strings?))
|
|
(let ([marshall
|
|
(λ (lls)
|
|
(map (λ (ls)
|
|
(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))]
|
|
[unmarshall (λ (x) x)])
|
|
(preferences:set-un/marshall
|
|
'drscheme:console-previous-exprs
|
|
marshall unmarshall))
|
|
|
|
(define error-color (make-object color% "PINK"))
|
|
(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%
|
|
(build-path (collection-path "icons") "file.gif"))])
|
|
(if (send bitmap ok?)
|
|
(make-object image-snip% bitmap)
|
|
(make-object string-snip% "[open file]"))))
|
|
(define docs-icon
|
|
(let ([bitmap
|
|
(make-object bitmap%
|
|
(build-path (collection-path "icons") "book.gif"))])
|
|
(if (send bitmap ok?)
|
|
(make-object image-snip% bitmap)
|
|
(make-object string-snip% "[open file]"))))
|
|
(define mf-icon
|
|
(let ([bitmap
|
|
(make-object bitmap%
|
|
(build-path (collection-path "icons") "mf.gif"))])
|
|
(if (send bitmap ok?)
|
|
(make-object image-snip% bitmap)
|
|
(make-object string-snip% "[mf]"))))
|
|
(define bug-icon
|
|
(let ([bitmap
|
|
(make-object bitmap%
|
|
(build-path (collection-path "icons") "bug09.gif"))])
|
|
(if (send bitmap ok?)
|
|
(make-object image-snip% bitmap)
|
|
(make-object string-snip% "[err]"))))
|
|
|
|
(define (no-user-evaluation-message frame)
|
|
(message-box
|
|
(string-constant evaluation-terminated)
|
|
(format (string-constant evaluation-terminated-explanation))
|
|
frame))
|
|
|
|
;; 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 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-snip-position
|
|
get-start-position
|
|
get-style-list
|
|
get-text
|
|
get-top-level-window
|
|
get-unread-start-point
|
|
get-value-port
|
|
in-edit-sequence?
|
|
insert
|
|
insert-between
|
|
invalidate-bitmap-cache
|
|
is-frozen?
|
|
is-locked?
|
|
last-position
|
|
line-location
|
|
lock
|
|
paragraph-start-position
|
|
position-line
|
|
position-paragraph
|
|
release-snip
|
|
reset-input-box
|
|
reset-region
|
|
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-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 context<%>)
|
|
(error 'drscheme:rep:text%
|
|
"expected an object that implements drscheme: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
|
|
(opt-lambda (ut thunk [always? #f])
|
|
(parameterize ([current-eventspace drscheme: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=
|
|
(for-each
|
|
(λ (v)
|
|
(unless (void? v)
|
|
(let* ([ls (current-language-settings)]
|
|
[lang (drscheme:language-configuration:language-settings-language ls)]
|
|
[settings (drscheme: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)
|
|
;; error-arrows : (union #f (listof (cons editor<%> number)))
|
|
(define error-arrows #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 (list (is-a?/c text:basic<%>) number number)))
|
|
;; -> (void)
|
|
(define/public (highlight-errors raw-locs error-arrows)
|
|
(let ([locs (filter (λ (loc) (and (is-a? (srcloc-source loc) text:basic<%>)
|
|
(number? (srcloc-position loc))
|
|
(number? (srcloc-span loc))))
|
|
raw-locs)])
|
|
(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 error-color #f #f 'high)))
|
|
locs)])
|
|
|
|
(when (and definitions-text error-arrows)
|
|
(let ([filtered-arrows
|
|
(remove-duplicate-error-arrows
|
|
(filter
|
|
(λ (arr)
|
|
(embedded-in? (car 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 first-loc
|
|
(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
|
|
(send first-file set-caret-owner (get-focus-snip) 'global)))))
|
|
|
|
(define/public (reset-highlighting)
|
|
(reset-error-ranges))
|
|
|
|
;; 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-table 'equal)])
|
|
(let loop ([arrs error-arrows]
|
|
[n 0])
|
|
(unless (null? arrs)
|
|
(hash-table-put! ht (car arrs) n)
|
|
(loop (cdr arrs) (+ n 1))))
|
|
(let* ([unsorted (hash-table-map ht list)]
|
|
[sorted (quicksort 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)
|
|
(let ([canvas (get-active-canvas)])
|
|
(when canvas
|
|
(let ([frame (send canvas get-top-level-window)])
|
|
(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 len))]
|
|
[else (update-after-insert)]))
|
|
|
|
(define had-an-insert? #f)
|
|
|
|
(define/augment (on-edit-sequence)
|
|
(set! had-an-insert? #f))
|
|
|
|
(define/augment (after-edit-sequence)
|
|
(when had-an-insert?
|
|
(update-after-insert (car had-an-insert?) (cdr had-an-insert?))))
|
|
|
|
(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 'drscheme: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-region prompt-position 'end)))
|
|
|
|
(define/augment after-delete
|
|
(lambda (x y)
|
|
(unless inserting-prompt?
|
|
(reset-highlighting))
|
|
(inner (void) after-delete x y)))
|
|
|
|
(define/override get-keymaps
|
|
(λ ()
|
|
(cons 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-teachpack-cache (preferences:get 'drscheme:teachpacks))
|
|
(user-custodian #f)
|
|
(user-eventspace-box (make-weak-box #f))
|
|
(user-namespace-box (make-weak-box #f))
|
|
(user-thread-box (make-weak-box #f))
|
|
(user-break-parameterization #f))
|
|
|
|
(define/public (get-user-language-settings) user-language-settings)
|
|
(define/public (get-user-custodian) user-custodian)
|
|
(define/public (get-user-teachpack-cache) user-teachpack-cache)
|
|
(define/public (set-user-teachpack-cache tpc) (set! user-teachpack-cache tpc))
|
|
(define/public (get-user-eventspace) (weak-box-value user-eventspace-box))
|
|
(define/public (get-user-thread) (weak-box-value user-thread-box))
|
|
(define/public (get-user-namespace) (weak-box-value user-namespace-box))
|
|
(define/public (get-user-break-parameterization) user-break-parameterization)
|
|
|
|
(field (in-evaluation? #f) ; a heursitic for making the Break button send a break
|
|
(should-collect-garbage? #f)
|
|
(ask-about-kill? #f))
|
|
(define/public (get-in-evaluation?) in-evaluation?)
|
|
|
|
(define/private (insert-warning)
|
|
(begin-edit-sequence)
|
|
(insert-between "\n")
|
|
(let ([start (get-unread-start-point)])
|
|
(insert-between
|
|
(string-constant interactions-out-of-sync))
|
|
(let ([end (get-unread-start-point)])
|
|
(change-style warning-style-delta start end)))
|
|
(end-edit-sequence))
|
|
|
|
(field (already-warned? #f))
|
|
|
|
(define/private (cleanup)
|
|
(set! in-evaluation? #f)
|
|
(update-running #f)
|
|
(unless (and (get-user-thread) (thread-running? (get-user-thread)))
|
|
(lock #t)
|
|
(unless shutting-down?
|
|
(no-user-evaluation-message
|
|
(let ([canvas (get-active-canvas)])
|
|
(and canvas
|
|
(send canvas get-top-level-window)))))))
|
|
(field (need-interaction-cleanup? #f))
|
|
|
|
(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))
|
|
|
|
(inherit backward-containing-sexp)
|
|
|
|
(define/augment (submit-to-port? key)
|
|
(and prompt-position
|
|
(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)
|
|
;; the -2 drops the last newline from history (why -2 and not -1?!)
|
|
(save-interaction-in-history prompt-position (- (last-position) 2))
|
|
(freeze-colorer)
|
|
|
|
(let* ([needs-execution? (send context needs-execution?)])
|
|
(when (if (preferences:get 'drscheme:execute-warning-once)
|
|
(and (not already-warned?)
|
|
needs-execution?)
|
|
needs-execution?)
|
|
(set! already-warned? #t)
|
|
(insert-warning)))
|
|
|
|
;; put two eofs in the port; one to terminate a potentially incomplete sexp
|
|
;; (or a non-self-terminating one, like a number) and the other to ensure that
|
|
;; an eof really does come thru the calls to `read'.
|
|
;; the cleanup thunk clears out the extra eof, if one is still there after evaluation
|
|
(send-eof-to-in-port)
|
|
(send-eof-to-in-port)
|
|
(set! prompt-position #f)
|
|
(evaluate-from-port
|
|
(get-in-port)
|
|
#f
|
|
(λ ()
|
|
(clear-input-port))))
|
|
|
|
;; 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-region sp 'end)
|
|
(when (is-frozen?) (thaw-colorer))))
|
|
(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)
|
|
(when should-collect-garbage?
|
|
(set! should-collect-garbage? #f)
|
|
(collect-garbage))
|
|
(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 (drscheme:language-configuration:language-settings-language settings)]
|
|
[settings (drscheme:language-configuration:language-settings-settings settings)]
|
|
[get-sexp/syntax/eof
|
|
(if complete-program?
|
|
(send lang front-end/complete-program port settings user-teachpack-cache)
|
|
(send lang front-end/interaction port settings user-teachpack-cache))])
|
|
|
|
; 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.)
|
|
; A continuation hop might take us out of this instance of
|
|
; evaluation and into another one, which is fine.
|
|
|
|
(let/ec k
|
|
(let ([saved-error-escape-k (current-error-escape-k)]
|
|
[cleanup? #f])
|
|
(dynamic-wind
|
|
(λ ()
|
|
(set! cleanup? #f)
|
|
(current-error-escape-k (λ ()
|
|
(set! cleanup? #t)
|
|
(k (void)))))
|
|
(λ ()
|
|
(let loop ()
|
|
(let ([sexp/syntax/eof (get-sexp/syntax/eof)])
|
|
(unless (eof-object? sexp/syntax/eof)
|
|
(call-with-values
|
|
(λ ()
|
|
(call-with-break-parameterization
|
|
(get-user-break-parameterization)
|
|
(λ ()
|
|
(eval-syntax sexp/syntax/eof))))
|
|
(λ x (display-results x)))
|
|
(loop))))
|
|
(set! cleanup? #t))
|
|
(λ ()
|
|
(current-error-escape-k saved-error-escape-k)
|
|
(when cleanup?
|
|
(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))))))))))))
|
|
|
|
(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-thread-box (make-weak-box #f))))
|
|
|
|
(define/public (kill-evaluation) ; =Kernel=, =Handler=
|
|
(when user-custodian
|
|
(custodian-shutdown-all user-custodian))
|
|
(set! user-custodian #f))
|
|
|
|
(field (user-break-enabled #t))
|
|
|
|
(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-grace 'not-yet-thread-grace)
|
|
(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)))))))))
|
|
|
|
(define/private protect-user-evaluation ; =User=, =Handler=, =No-Breaks=
|
|
(λ (thunk cleanup)
|
|
|
|
;; We only run cleanup if thunk finishes normally or tries to
|
|
;; error-escape. Otherwise, it must be a continuation jump
|
|
;; into a different call to protect-user-evaluation.
|
|
|
|
;; `thunk' is responsible for ensuring that breaks are off when
|
|
;; it returns or jumps out.
|
|
|
|
(set! in-evaluation? #t)
|
|
(update-running #t)
|
|
|
|
(let/ec k
|
|
(let ([saved-error-escape-k (current-error-escape-k)]
|
|
[cleanup? #f])
|
|
(dynamic-wind
|
|
(λ ()
|
|
(set! cleanup? #f)
|
|
(current-error-escape-k (λ ()
|
|
(set! cleanup? #t)
|
|
(k (void)))))
|
|
(λ ()
|
|
(thunk)
|
|
; Breaks must be off!
|
|
(set! cleanup? #t))
|
|
(λ ()
|
|
(current-error-escape-k saved-error-escape-k)
|
|
(when cleanup?
|
|
(set! in-evaluation? #f)
|
|
(update-running #f)
|
|
(cleanup))))))))
|
|
|
|
(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 (make-custodian))
|
|
; (custodian-limit-memory user-custodian 10000000 user-custodian)
|
|
(set! user-eventspace-box (make-weak-box
|
|
(parameterize ([current-custodian user-custodian])
|
|
(make-eventspace))))
|
|
(set! user-break-parameterization (parameterize-break
|
|
#t
|
|
(current-break-parameterization)))
|
|
(set! user-break-enabled #t)
|
|
(set! eval-thread-thunks null)
|
|
(set! eval-thread-state-sema (make-semaphore 1))
|
|
(set! eval-thread-queue-sema (make-semaphore 0))
|
|
|
|
(let* ([init-thread-complete (make-semaphore 0)]
|
|
[goahead (make-semaphore)]
|
|
[queue-user/wait
|
|
(λ (thnk)
|
|
(let ([wait (make-semaphore 0)])
|
|
(parameterize ([current-eventspace (get-user-eventspace)])
|
|
(queue-callback
|
|
(λ ()
|
|
(thnk)
|
|
(semaphore-post wait))))
|
|
(semaphore-wait wait)))])
|
|
|
|
; setup standard parameters
|
|
(let ([snip-classes
|
|
; the snip-classes in the DrScheme eventspace's snip-class-list
|
|
(drscheme:eval:get-snip-classes)])
|
|
(queue-user/wait
|
|
(λ () ; =User=, =No-Breaks=
|
|
; No user code has been evaluated yet, so we're in the clear...
|
|
(break-enabled #f)
|
|
(set! user-thread-box (make-weak-box (current-thread)))
|
|
(initialize-parameters snip-classes))))
|
|
|
|
;; disable breaks until an evaluation actually occurs
|
|
(send context set-breakables #f #f)
|
|
|
|
;; initialize the language
|
|
(send (drscheme:language-configuration:language-settings-language user-language-settings)
|
|
on-execute
|
|
(drscheme:language-configuration:language-settings-settings user-language-settings)
|
|
queue-user/wait)
|
|
|
|
;; installs the teachpacks
|
|
;; must happen after language is initialized.
|
|
(queue-user/wait
|
|
(λ () ; =User=, =No-Breaks=
|
|
(drscheme:teachpack:install-teachpacks
|
|
user-teachpack-cache)))
|
|
|
|
(parameterize ([current-eventspace (get-user-eventspace)])
|
|
(queue-callback
|
|
(λ ()
|
|
(let ([drscheme-error-escape-handler
|
|
(λ ()
|
|
((current-error-escape-k)))])
|
|
(error-escape-handler drscheme-error-escape-handler))
|
|
|
|
(set! in-evaluation? #f)
|
|
(update-running #f)
|
|
(send context set-breakables #f #f)
|
|
|
|
;; 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))))
|
|
|
|
(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 'drscheme:console-previous-exprs
|
|
(trim-previous-exprs
|
|
(append
|
|
(preferences:get 'drscheme: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)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; ;;;
|
|
;;; Execution ;;;
|
|
;;; ;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; initialize-paramters : (listof snip-class%) -> void
|
|
(define/private initialize-parameters ; =User=
|
|
(λ (snip-classes)
|
|
|
|
(current-language-settings user-language-settings)
|
|
(error-value->string-handler drscheme-error-value->string-handler)
|
|
(error-print-source-location #f)
|
|
(error-display-handler drscheme-error-display-handler)
|
|
(current-load-relative-directory #f)
|
|
(current-custodian user-custodian)
|
|
(current-load text-editor-load-handler)
|
|
|
|
(drscheme:eval:set-basic-parameters snip-classes)
|
|
(current-rep this)
|
|
(let ([dir (or (send context get-directory)
|
|
drscheme:init:first-dir)])
|
|
(current-directory dir)
|
|
(current-load-relative-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))
|
|
(break-enabled #t)
|
|
(let* ([primitive-dispatch-handler (event-dispatch-handler)])
|
|
(event-dispatch-handler
|
|
(rec 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=, =No-Breaks=
|
|
|
|
(let* ([ub? (eq? user-break-enabled 'user)]
|
|
[break-ok? (if ub?
|
|
(break-enabled)
|
|
user-break-enabled)])
|
|
(break-enabled #f)
|
|
|
|
; We must distinguish between "top-level" events and
|
|
; those within `yield' in the user's program.
|
|
|
|
(cond
|
|
[(not in-evaluation?)
|
|
(send context reset-offer-kill)
|
|
(send context set-breakables (get-user-thread) (get-user-custodian))
|
|
|
|
(protect-user-evaluation
|
|
; Run the dispatch:
|
|
(λ () ; =User=, =Handler=, =No-Breaks=
|
|
; This procedure is responsible for adjusting breaks to
|
|
; match the user's expectations:
|
|
(dynamic-wind
|
|
(λ ()
|
|
(break-enabled break-ok?)
|
|
(unless ub?
|
|
(set! user-break-enabled 'user)))
|
|
(λ ()
|
|
(primitive-dispatch-handler eventspace))
|
|
(λ ()
|
|
(unless ub?
|
|
(set! user-break-enabled (break-enabled)))
|
|
(break-enabled #f))))
|
|
; Cleanup after dispatch
|
|
(λ ()
|
|
;; in principle, the line below might cause
|
|
;; a "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)))
|
|
|
|
; Restore break:
|
|
(when ub?
|
|
(break-enabled break-ok?))]
|
|
[else
|
|
; Nested dispatch; don't adjust interface, and restore break:
|
|
(break-enabled break-ok?)
|
|
(primitive-dispatch-handler eventspace)]))]
|
|
[else
|
|
; =User=, =Non-Handler=, =No-Breaks=
|
|
(primitive-dispatch-handler eventspace)])))))))
|
|
|
|
(define/public (reset-console)
|
|
(when (thread? thread-killed)
|
|
(kill-thread thread-killed))
|
|
(send context clear-annotations)
|
|
(drscheme:debug:hide-backtrace-window)
|
|
(shutdown-user-custodian)
|
|
(clear-input-port)
|
|
(clear-box-input-port)
|
|
(clear-output-ports)
|
|
(set-allow-edits #t)
|
|
(set! should-collect-garbage? #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)
|
|
(freeze-colorer)
|
|
(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)
|
|
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))
|
|
(insert/delta this (format ".~n") welcome-delta)
|
|
|
|
(for-each
|
|
(λ (fn)
|
|
(insert/delta this
|
|
(string-append (string-constant teachpack) ": ")
|
|
welcome-delta)
|
|
(insert/delta this fn dark-green-delta)
|
|
(insert/delta this (format ".~n") welcome-delta))
|
|
(map path->string
|
|
(drscheme:teachpack:teachpack-cache-filenames
|
|
user-teachpack-cache)))
|
|
(set! setting-up-repl? #f)
|
|
|
|
(set! already-warned? #f)
|
|
(reset-region (last-position) (last-position))
|
|
(set-unread-start-point (last-position))
|
|
(set-insertion-point (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.~n") (version:version))
|
|
welcome-delta)
|
|
(set-clickback before after
|
|
(λ args (drscheme:app:about-drscheme))
|
|
click-delta))
|
|
(set! setting-up-repl? #f)
|
|
(thaw-colorer)
|
|
(send context disable-evaluation)
|
|
(reset-console)
|
|
(insert-prompt)
|
|
(send context enable-evaluation)
|
|
(end-edit-sequence)
|
|
(clear-undos))
|
|
|
|
;; 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 'drscheme: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)
|
|
(let* ([new-previous-exprs
|
|
(let* ([trimmed-previous-exprs (trim-previous-exprs local-previous-exprs)])
|
|
(let loop ([l trimmed-previous-exprs])
|
|
(if (null? l)
|
|
(list snips)
|
|
(cons (car l) (loop (cdr l))))))])
|
|
(set! local-previous-exprs new-previous-exprs)))
|
|
|
|
(define/private (trim-previous-exprs lst)
|
|
(if ((length lst). >= . console-max-save-previous-exprs)
|
|
(cdr lst)
|
|
lst))
|
|
|
|
(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))))))
|
|
|
|
(super-new)
|
|
(auto-wrap #t)
|
|
(set-styles-sticky #f)))
|
|
|
|
(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 drscheme: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 (syntax? expr)
|
|
(insert/delta text " in: ")
|
|
(insert/delta text (format "~s" (syntax-object->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 drscheme: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 -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
|
|
(text:nbsp->space-mixin
|
|
(mode:host-text-mixin
|
|
(text:foreground-color-mixin
|
|
text:clever-file-format%)))))))))))))))
|