3713 lines
171 KiB
Scheme
3713 lines
171 KiB
Scheme
|
|
#|
|
|
|
|
closing:
|
|
warning messages don't have frame as parent.....
|
|
|
|
tab panels new behavior:
|
|
- save all tabs (pr 6689?)
|
|
|
|
module browser threading seems wrong.
|
|
|
|
|#
|
|
|
|
(module unit mzscheme
|
|
(require (lib "contract.ss")
|
|
(lib "unit.ss")
|
|
(lib "class.ss")
|
|
(lib "file.ss")
|
|
(lib "etc.ss")
|
|
(lib "list.ss")
|
|
(lib "port.ss")
|
|
(lib "string-constant.ss" "string-constants")
|
|
(lib "framework.ss" "framework")
|
|
(lib "name-message.ss" "mrlib")
|
|
(lib "bitmap-label.ss" "mrlib")
|
|
|
|
"stick-figures.ss"
|
|
"drsig.ss"
|
|
"auto-language.ss"
|
|
|
|
(prefix drscheme:arrow: "../arrow.ss")
|
|
|
|
(lib "mred.ss" "mred")
|
|
(prefix mred: (lib "mred.ss" "mred"))
|
|
|
|
(lib "date.ss"))
|
|
|
|
(provide unit@)
|
|
|
|
(define module-browser-progress-constant (string-constant module-browser-progress))
|
|
(define status-compiling-definitions (string-constant module-browser-compiling-defns))
|
|
(define show-lib-paths (string-constant module-browser-show-lib-paths/short))
|
|
(define show-planet-paths (string-constant module-browser-show-planet-paths/short))
|
|
(define refresh (string-constant module-browser-refresh))
|
|
|
|
(define-unit unit@
|
|
(import [prefix help-desk: drscheme:help-desk^]
|
|
[prefix drscheme:app: drscheme:app^]
|
|
[prefix drscheme:frame: drscheme:frame^]
|
|
[prefix drscheme:text: drscheme:text^]
|
|
[prefix drscheme:rep: drscheme:rep^]
|
|
[prefix drscheme:language-configuration: drscheme:language-configuration/internal^]
|
|
[prefix drscheme:language: drscheme:language^]
|
|
[prefix drscheme:get/extend: drscheme:get/extend^]
|
|
[prefix drscheme:module-overview: drscheme:module-overview^]
|
|
[prefix drscheme:tools: drscheme:tools^]
|
|
[prefix drscheme:eval: drscheme:eval^]
|
|
[prefix drscheme:init: drscheme:init^]
|
|
[prefix drscheme:module-language: drscheme:module-language^]
|
|
[prefix drscheme:modes: drscheme:modes^])
|
|
(export (rename drscheme:unit^
|
|
[-frame% frame%]
|
|
[-frame<%> frame<%>]))
|
|
|
|
(define-local-member-name
|
|
get-visible-defs
|
|
set-visible-defs
|
|
set-focus-d/i
|
|
get-i
|
|
set-i)
|
|
(define tab<%>
|
|
(interface (drscheme:rep:context<%>)
|
|
get-frame
|
|
get-defs
|
|
get-ints
|
|
get-visible-defs
|
|
set-visible-defs
|
|
set-visible-ints
|
|
set-focus-d/i
|
|
get-i
|
|
set-i
|
|
break-callback
|
|
is-current-tab?
|
|
get-enabled
|
|
on-close
|
|
can-close?))
|
|
|
|
(define definitions-text<%>
|
|
(interface ()
|
|
begin-metadata-changes
|
|
end-metadata-changes
|
|
get-tab
|
|
get-next-settings
|
|
after-set-next-settings
|
|
set-needs-execution-message))
|
|
|
|
(define-struct teachpack-callbacks
|
|
(get-names ;; settings -> (listof string)
|
|
add ;; settings path -> settings
|
|
remove ;; string[returned from teachpack-names] settings -> settings
|
|
remove-all ;; settings -> settings
|
|
))
|
|
|
|
;; get rid of set-user-teachpack-cache method
|
|
|
|
(keymap:add-to-right-button-menu
|
|
(let ([old (keymap:add-to-right-button-menu)])
|
|
(λ (menu text event)
|
|
(old menu text event)
|
|
(when (and (is-a? text text%)
|
|
(or (is-a? text (get-definitions-text%))
|
|
(is-a? text drscheme:rep:text%))
|
|
(is-a? event mouse-event%))
|
|
(let* ([end (send text get-end-position)]
|
|
[start (send text get-start-position)])
|
|
(unless (= 0 (send text last-position))
|
|
(let ([str (if (= end start)
|
|
(find-symbol
|
|
text
|
|
(call-with-values
|
|
(λ ()
|
|
(send text dc-location-to-editor-location
|
|
(send event get-x)
|
|
(send event get-y)))
|
|
(λ (x y)
|
|
(send text find-position x y))))
|
|
(send text get-text start end))]
|
|
[language
|
|
(let ([canvas (send text get-canvas)])
|
|
(and canvas
|
|
(let ([tlw (send canvas get-top-level-window)])
|
|
(and (is-a? tlw -frame<%>)
|
|
(send (send tlw get-definitions-text)
|
|
get-next-settings)))))])
|
|
(unless (string=? str "")
|
|
(make-object separator-menu-item% menu)
|
|
(make-object menu-item%
|
|
(format (string-constant search-help-desk-for)
|
|
(shorten-str
|
|
str
|
|
(- 200 (string-length (string-constant search-help-desk-for)))))
|
|
menu
|
|
(λ x (help-desk:help-desk str #f 'keyword+index 'contains language)))
|
|
(make-object menu-item%
|
|
(format (string-constant exact-lucky-search-help-desk-for)
|
|
(shorten-str
|
|
str
|
|
(- 200 (string-length (string-constant exact-lucky-search-help-desk-for)))))
|
|
menu
|
|
(λ x (help-desk:help-desk str #t 'keyword+index 'exact language)))
|
|
(void)))))))))
|
|
|
|
;; find-symbol : number -> string
|
|
;; finds the symbol around the position `pos' (approx)
|
|
(define (find-symbol text pos)
|
|
(let* ([before
|
|
(let loop ([i (- pos 1)]
|
|
[chars null])
|
|
(if (< i 0)
|
|
chars
|
|
(let ([char (send text get-character i)])
|
|
(if (non-letter? char)
|
|
chars
|
|
(loop (- i 1)
|
|
(cons char chars))))))]
|
|
[after
|
|
(let loop ([i pos])
|
|
(if (< i (send text last-position))
|
|
(let ([char (send text get-character i)])
|
|
(if (non-letter? char)
|
|
null
|
|
(cons char (loop (+ i 1)))))
|
|
null))])
|
|
(apply string (append before after))))
|
|
|
|
;; non-letter? : char -> boolean
|
|
;; returns #t if the character belongs in a symbol (approx) and #f it is
|
|
;; a divider between symbols (approx)
|
|
(define (non-letter? x)
|
|
(or (char-whitespace? x)
|
|
(memq x '(#\` #\' #\, #\; #\"
|
|
#\{ #\( #\[ #\] #\) #\}))))
|
|
(define (shorten-str str len)
|
|
(if ((string-length str) . <= . len)
|
|
str
|
|
(substring str 0 len)))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ;;; ; ; ; ;
|
|
; ; ; ;
|
|
; ; ; ; ;
|
|
; ;;;; ; ; ;;; ;;; ;;;; ; ;;; ; ;; ;; ; ; ;;; ; ;;; ;; ;
|
|
; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;;
|
|
; ; ; ;;;;; ;;; ;; ; ;;; ; ; ;; ; ; ;;;;; ; ;;; ;; ;
|
|
; ;
|
|
; ; ;
|
|
; ;;;;
|
|
|
|
(define (get-fraction-from-user parent)
|
|
(let* ([dlg (make-object dialog% (string-constant enter-fraction))]
|
|
[hp (make-object horizontal-panel% dlg)]
|
|
[_1 (make-object message% (string-constant whole-part) hp)]
|
|
[whole (make-object text-field% #f hp void)]
|
|
[vp (make-object vertical-panel% hp)]
|
|
[hp2 (make-object horizontal-panel% vp)]
|
|
[num (make-object text-field% #f hp2 void)]
|
|
[num-m (make-object message% (string-constant numerator) hp2)]
|
|
[hp3 (make-object horizontal-panel% vp)]
|
|
[den (make-object text-field% #f hp3 void)]
|
|
[den-m (make-object message% (string-constant denominator) hp3)]
|
|
[bp (make-object horizontal-panel% dlg)]
|
|
[ok? #f]
|
|
[validate-number
|
|
(λ ()
|
|
(let ([num-s (string->number (send num get-value))]
|
|
[den-s (string->number (send den get-value))]
|
|
[whole-s (if (string=? (send whole get-value) "")
|
|
0
|
|
(string->number (send whole get-value)))])
|
|
(if (and num-s den-s whole-s)
|
|
(let ([ans (+ whole-s (/ num-s den-s))])
|
|
(if (and (exact? ans)
|
|
(real? ans)
|
|
(not (integer? ans)))
|
|
ans
|
|
#f))
|
|
#f)))]
|
|
[ok-callback
|
|
(λ ()
|
|
(cond
|
|
[(validate-number)
|
|
(set! ok? #t)
|
|
(send dlg show #f)]
|
|
[else
|
|
(message-box
|
|
(string-constant drscheme)
|
|
(string-constant invalid-number)
|
|
dlg)]))]
|
|
[cancel-callback
|
|
(λ () (send dlg show #f))])
|
|
(let-values ([(ok cancel)
|
|
(gui-utils:ok/cancel-buttons
|
|
bp
|
|
(λ (x y) (ok-callback))
|
|
(λ (x y) (cancel-callback)))])
|
|
(let ([mw (max (send den-m get-width) (send num-m get-width))])
|
|
(send den-m min-width mw)
|
|
(send num-m min-width mw))
|
|
(send bp set-alignment 'right 'center)
|
|
(send dlg show #t)
|
|
(and ok? (validate-number)))))
|
|
|
|
;; create-executable : (instanceof drscheme:unit:frame<%>) -> void
|
|
(define (create-executable frame)
|
|
(let* ([definitions-text (send frame get-definitions-text)]
|
|
[program-filename (send definitions-text get-filename)])
|
|
(cond
|
|
[(not program-filename)
|
|
(message-box (string-constant create-executable-title)
|
|
(string-constant must-save-before-executable)
|
|
frame)]
|
|
[else
|
|
(when (or (not (send definitions-text is-modified?))
|
|
(gui-utils:get-choice
|
|
(string-constant definitions-not-saved)
|
|
(string-constant yes)
|
|
(string-constant no)
|
|
(string-constant drscheme)
|
|
#f
|
|
frame))
|
|
(let ([settings (send definitions-text get-next-settings)])
|
|
(send (drscheme:language-configuration:language-settings-language settings)
|
|
create-executable
|
|
(drscheme:language-configuration:language-settings-settings settings)
|
|
frame
|
|
program-filename)))])))
|
|
|
|
(define make-execute-bitmap
|
|
(bitmap-label-maker (string-constant execute-button-label)
|
|
(build-path (collection-path "icons") "run.png")))
|
|
(define make-save-bitmap
|
|
(bitmap-label-maker (string-constant save-button-label)
|
|
(build-path (collection-path "icons") "save.png")))
|
|
(define make-break-bitmap
|
|
(bitmap-label-maker (string-constant break-button-label)
|
|
(build-path (collection-path "icons") "break.png")))
|
|
|
|
(define-values (get-program-editor-mixin add-to-program-editor-mixin)
|
|
(let* ([program-editor-mixin
|
|
(mixin (editor:basic<%> (class->interface text%)) ()
|
|
(init-rest args)
|
|
(inherit get-top-level-window)
|
|
|
|
(define/private (reset-highlighting)
|
|
(let ([f (get-top-level-window)])
|
|
(when (and f
|
|
(is-a? f -frame<%>))
|
|
(let ([interactions-text (send f get-interactions-text)])
|
|
(when (object? interactions-text)
|
|
(send interactions-text reset-highlighting))))))
|
|
|
|
(define/augment (after-insert x y)
|
|
(reset-highlighting)
|
|
(inner (void) after-insert x y))
|
|
|
|
(define/augment (after-delete x y)
|
|
(reset-highlighting)
|
|
(inner (void) after-delete x y))
|
|
|
|
(apply super-make-object args))]
|
|
[get-program-editor-mixin
|
|
(λ ()
|
|
(drscheme:tools:only-in-phase 'drscheme:unit:get-program-editor-mixin 'phase2 'init-complete)
|
|
program-editor-mixin)]
|
|
[add-to-program-editor-mixin
|
|
(λ (mixin)
|
|
(drscheme:tools:only-in-phase 'drscheme:unit:add-to-program-editor-mixin 'phase1)
|
|
(set! program-editor-mixin (compose mixin program-editor-mixin)))])
|
|
(values get-program-editor-mixin
|
|
add-to-program-editor-mixin)))
|
|
|
|
|
|
;; this sends a message to it's frame when it gets the focus
|
|
(define make-searchable-canvas%
|
|
(λ (%)
|
|
(class %
|
|
(inherit get-top-level-window)
|
|
(define/override (on-focus on?)
|
|
(when on?
|
|
(send (get-top-level-window) make-searchable this))
|
|
(super on-focus on?))
|
|
(super-new))))
|
|
|
|
(define interactions-canvas%
|
|
(class (make-searchable-canvas%
|
|
(canvas:info-mixin
|
|
(canvas:wide-snip-mixin
|
|
(canvas:info-mixin
|
|
canvas:color%))))
|
|
(init [style '()])
|
|
(super-new (style (cons 'auto-hscroll style)))))
|
|
|
|
|
|
(define definitions-canvas%
|
|
(class (make-searchable-canvas% (canvas:delegate-mixin (canvas:info-mixin canvas:color%)))
|
|
(init [style '()])
|
|
(super-new (style (cons 'auto-hscroll style)))))
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ;;; ; ;
|
|
; ; ; ;
|
|
; ; ; ; ; ;
|
|
; ;; ; ;;; ;;;;;;; ; ;; ; ;;;; ; ;;; ; ;; ;;; ;;;; ;;; ; ; ;;;;
|
|
; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;
|
|
; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;;;;;; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;; ; ;;;; ; ; ; ; ; ;; ; ;;; ; ; ;;; ;; ;;;; ; ; ;;
|
|
;
|
|
;
|
|
;
|
|
|
|
|
|
(define get-definitions-text%
|
|
(let ([definitions-text% #f])
|
|
(λ ()
|
|
(drscheme:tools:only-in-phase 'phase2 'init-complete)
|
|
(unless definitions-text%
|
|
(set! definitions-text% (make-definitions-text%)))
|
|
definitions-text%)))
|
|
|
|
(define (make-definitions-text%)
|
|
(let ([definitions-super%
|
|
((get-program-editor-mixin)
|
|
(drscheme:module-language:module-language-put-file-mixin
|
|
(scheme:text-mixin
|
|
(color:text-mixin
|
|
(drscheme:rep:drs-bindings-keymap-mixin
|
|
(mode:host-text-mixin
|
|
(text:delegate-mixin
|
|
(text:foreground-color-mixin
|
|
(drscheme:rep:drs-autocomplete-mixin
|
|
(λ (x) x)
|
|
text:info%)))))))))])
|
|
(class* definitions-super% (definitions-text<%>)
|
|
(inherit get-top-level-window)
|
|
|
|
(define interactions-text #f)
|
|
(define/public (set-interactions-text it)
|
|
(set! interactions-text it))
|
|
|
|
(define tab #f)
|
|
(define/public (get-tab) tab)
|
|
(define/public (set-tab t) (set! tab t))
|
|
|
|
(inherit get-surrogate set-surrogate)
|
|
(define/public (set-current-mode mode)
|
|
(let ([surrogate (drscheme:modes:mode-surrogate mode)])
|
|
(set-surrogate surrogate)
|
|
(when interactions-text
|
|
(send interactions-text set-surrogate surrogate)
|
|
(send interactions-text set-submit-predicate
|
|
(drscheme:modes:mode-repl-submit mode)))))
|
|
|
|
(define/public (is-current-mode? mode)
|
|
(let ([surrogate (drscheme:modes:mode-surrogate mode)])
|
|
(eq? surrogate (get-surrogate))))
|
|
|
|
(define/public (change-mode-to-match)
|
|
(let* ([language-settings (get-next-settings)]
|
|
[language-name (and language-settings
|
|
(send (drscheme:language-configuration:language-settings-language
|
|
language-settings)
|
|
get-language-position))])
|
|
(let loop ([modes (drscheme:modes:get-modes)])
|
|
(cond
|
|
[(null? modes) (error 'change-mode-to-match
|
|
"didn't find a matching mode")]
|
|
[else (let ([mode (car modes)])
|
|
(if ((drscheme:modes:mode-matches-language mode) language-name)
|
|
(unless (is-current-mode? mode)
|
|
(set-current-mode mode))
|
|
(loop (cdr modes))))]))))
|
|
|
|
(inherit begin-edit-sequence end-edit-sequence
|
|
delete insert last-position paragraph-start-position
|
|
get-character)
|
|
|
|
(define save-file-metadata #f)
|
|
|
|
(define/pubment (begin-metadata-changes)
|
|
(set! ignore-edits? #t)
|
|
(inner (void) begin-metadata-changes))
|
|
(define/pubment (end-metadata-changes)
|
|
(set! ignore-edits? #f)
|
|
(inner (void) end-metadata-changes))
|
|
|
|
(define/augment (on-save-file filename fmt)
|
|
(inner (void) on-save-file filename fmt)
|
|
(let* ([lang (drscheme:language-configuration:language-settings-language next-settings)]
|
|
[settings (drscheme:language-configuration:language-settings-settings next-settings)]
|
|
[name-mod (send lang get-reader-module)])
|
|
(when name-mod ;; the reader-module method's result is used a test of whether or not the get-metadata method is used for this language
|
|
(let ([metadata (send lang get-metadata (filename->modname filename) settings)])
|
|
(begin-edit-sequence)
|
|
(begin-metadata-changes)
|
|
(set! save-file-metadata metadata)
|
|
(insert metadata 0 0)))))
|
|
(define/private (filename->modname filename)
|
|
(let-values ([(base name dir) (split-path filename)])
|
|
(string->symbol (regexp-replace #rx"\\.[^.]*$"
|
|
(path->string name)
|
|
""))))
|
|
|
|
(define/augment (after-save-file success?)
|
|
(when success?
|
|
(let ([filename (get-filename)])
|
|
(when filename
|
|
;; if a filesystem error happens, just give up
|
|
;; on setting the file creator and type.
|
|
(with-handlers ([exn:fail:filesystem? void])
|
|
(let-values ([(creator type) (file-creator-and-type filename)])
|
|
(file-creator-and-type filename #"DrSc" type))))))
|
|
(when save-file-metadata
|
|
(let ([modified? (is-modified?)])
|
|
(delete 0 (string-length save-file-metadata))
|
|
(set! save-file-metadata #f)
|
|
;; restore modification status to where it was before the metadata is removed
|
|
(set-modified modified?)
|
|
(end-metadata-changes)
|
|
(end-edit-sequence)))
|
|
(inner (void) after-save-file success?))
|
|
|
|
(define/augment (on-load-file filename format)
|
|
(inner (void) on-load-file filename format)
|
|
(begin-edit-sequence))
|
|
(define/augment (after-load-file success?)
|
|
(when success?
|
|
(let* ([module-language
|
|
(and (preferences:get 'drscheme:switch-to-module-language-automatically?)
|
|
(ormap
|
|
(λ (lang)
|
|
(and (is-a? lang drscheme:module-language:module-language<%>)
|
|
lang))
|
|
(drscheme:language-configuration:get-languages)))]
|
|
[module-language-settings
|
|
(let ([prefs-setting (preferences:get
|
|
drscheme:language-configuration:settings-preferences-symbol)])
|
|
(cond
|
|
[(eq? (drscheme:language-configuration:language-settings-language prefs-setting)
|
|
module-language)
|
|
(drscheme:language-configuration:language-settings-settings prefs-setting)]
|
|
[else
|
|
(and module-language
|
|
(send module-language default-settings))]))])
|
|
(let-values ([(matching-language settings)
|
|
(pick-new-language
|
|
this
|
|
(drscheme:language-configuration:get-languages)
|
|
module-language
|
|
module-language-settings)])
|
|
(when matching-language
|
|
(set-next-settings
|
|
(drscheme:language-configuration:make-language-settings
|
|
matching-language
|
|
settings)
|
|
#f))))
|
|
(set-modified #f))
|
|
|
|
(end-edit-sequence)
|
|
(inner (void) after-load-file success?))
|
|
|
|
(inherit is-modified? run-after-edit-sequence)
|
|
(define/override (set-modified mod?)
|
|
(super set-modified mod?)
|
|
(run-after-edit-sequence
|
|
(λ ()
|
|
(let ([f (get-top-level-window)])
|
|
(when (and f
|
|
(is-a? f -frame<%>))
|
|
(send f update-save-button))))))
|
|
(define/override set-filename
|
|
(case-lambda
|
|
[(fn) (set-filename fn #f)]
|
|
[(fn tmp?)
|
|
(super set-filename fn tmp?)
|
|
(let ([f (get-top-level-window)])
|
|
(when (and f
|
|
(is-a? f -frame<%>))
|
|
(send f update-save-message)))]))
|
|
|
|
(field
|
|
[needs-execution-state #f]
|
|
[already-warned-state #f]
|
|
[execute-settings (preferences:get drscheme:language-configuration:settings-preferences-symbol)]
|
|
[next-settings execute-settings])
|
|
|
|
|
|
(define/pubment (get-next-settings) next-settings)
|
|
(define/pubment set-next-settings
|
|
(opt-lambda (_next-settings [update-prefs? #t])
|
|
(when (or (send (drscheme:language-configuration:language-settings-language _next-settings)
|
|
get-reader-module)
|
|
(send (drscheme:language-configuration:language-settings-language next-settings)
|
|
get-reader-module))
|
|
(set-modified #t))
|
|
(set! next-settings _next-settings)
|
|
(change-mode-to-match)
|
|
|
|
(let ([f (get-top-level-window)])
|
|
(when (and f
|
|
(is-a? f -frame<%>))
|
|
(send f language-changed)))
|
|
|
|
(let ([lang (drscheme:language-configuration:language-settings-language next-settings)]
|
|
[sets (drscheme:language-configuration:language-settings-settings next-settings)])
|
|
(preferences:set
|
|
'drscheme:recent-language-names
|
|
(limit-length
|
|
(remove-duplicate-languages
|
|
(cons (cons (send lang get-language-name)
|
|
(send lang marshall-settings sets))
|
|
(preferences:get 'drscheme:recent-language-names)))
|
|
10)))
|
|
|
|
(when update-prefs?
|
|
(preferences:set
|
|
drscheme:language-configuration:settings-preferences-symbol
|
|
next-settings))
|
|
|
|
(after-set-next-settings _next-settings)))
|
|
|
|
(define/pubment (after-set-next-settings s)
|
|
(inner (void) after-set-next-settings s))
|
|
|
|
(define/public (needs-execution)
|
|
(or needs-execution-state
|
|
(and (not (this-and-next-language-the-same?))
|
|
(string-constant needs-execute-language-changed))))
|
|
|
|
(define/public (this-and-next-language-the-same?)
|
|
(let ([execute-lang (drscheme:language-configuration:language-settings-language execute-settings)]
|
|
[next-lang (drscheme:language-configuration:language-settings-language next-settings)])
|
|
(and (eq? execute-lang next-lang)
|
|
(equal?
|
|
(send execute-lang marshall-settings
|
|
(drscheme:language-configuration:language-settings-settings execute-settings))
|
|
(send execute-lang marshall-settings
|
|
(drscheme:language-configuration:language-settings-settings next-settings))))))
|
|
|
|
(define/pubment (set-needs-execution-message msg)
|
|
(set! needs-execution-state msg))
|
|
(define/pubment (teachpack-changed)
|
|
(set! needs-execution-state (string-constant needs-execute-teachpack-changed)))
|
|
(define/pubment (just-executed)
|
|
(set! execute-settings next-settings)
|
|
(set! needs-execution-state #f)
|
|
(set! already-warned-state #f))
|
|
(define/pubment (already-warned?)
|
|
already-warned-state)
|
|
(define/pubment (already-warned)
|
|
(set! already-warned-state #t))
|
|
|
|
(define ignore-edits? #f)
|
|
(define/augment (after-insert x y)
|
|
(unless ignore-edits?
|
|
(set! needs-execution-state (string-constant needs-execute-defns-edited)))
|
|
(inner (void) after-insert x y))
|
|
(define/augment (after-delete x y)
|
|
(unless ignore-edits?
|
|
(set! needs-execution-state (string-constant needs-execute-defns-edited)))
|
|
(inner (void) after-delete x y))
|
|
|
|
(inherit get-filename)
|
|
(field
|
|
[tmp-date-string #f])
|
|
|
|
(inherit get-filename/untitled-name)
|
|
(define/private (get-date-string)
|
|
(string-append
|
|
(date->string (seconds->date (current-seconds)))
|
|
" "
|
|
(get-filename/untitled-name)))
|
|
|
|
(define/override (on-paint before dc left top right bottom dx dy draw-caret)
|
|
(when (and before
|
|
(or (is-a? dc post-script-dc%)
|
|
(is-a? dc printer-dc%)))
|
|
(set! tmp-date-string (get-date-string))
|
|
(let-values ([(w h d s) (send dc get-text-extent tmp-date-string)])
|
|
(send (current-ps-setup) set-editor-margin 0 (inexact->exact (ceiling h)))))
|
|
(super on-paint before dc left top right bottom dx dy draw-caret)
|
|
(when (and (not before)
|
|
(or (is-a? dc post-script-dc%)
|
|
(is-a? dc printer-dc%)))
|
|
(send dc draw-text (get-date-string) 0 0)
|
|
(void))
|
|
|
|
;; draw the arrows
|
|
(when before
|
|
(when error-arrows
|
|
(let ([old-pen (send dc get-pen)])
|
|
(send dc set-pen (send the-pen-list find-or-create-pen "red" 1 'solid))
|
|
(let loop ([pts error-arrows])
|
|
(cond
|
|
[(null? pts) (void)]
|
|
[(null? (cdr pts)) (void)]
|
|
[else (let ([pt1 (car pts)]
|
|
[pt2 (cadr pts)])
|
|
(draw-arrow dc dx dy pt1 pt2)
|
|
(loop (cdr pts)))]))
|
|
(send dc set-pen old-pen)))))
|
|
|
|
(define/private (draw-arrow dc dx dy pt1 pt2)
|
|
(let-values ([(x1 y1) (find-poss (car pt1) (cadr pt1) (+ (cadr pt1) 1))]
|
|
[(x2 y2) (find-poss (car pt2) (cadr pt2) (+ (cadr pt2) 1))])
|
|
(drscheme:arrow:draw-arrow dc x1 y1 x2 y2 dx dy)))
|
|
|
|
(inherit dc-location-to-editor-location)
|
|
(define/private (find-poss text left-pos right-pos)
|
|
(let ([xlb (box 0)]
|
|
[ylb (box 0)]
|
|
[xrb (box 0)]
|
|
[yrb (box 0)])
|
|
(send text position-location left-pos xlb ylb #t)
|
|
(send text position-location right-pos xrb yrb #f)
|
|
(let*-values ([(xl-off yl-off) (send text editor-location-to-dc-location (unbox xlb) (unbox ylb))]
|
|
[(xl yl) (dc-location-to-editor-location xl-off yl-off)]
|
|
[(xr-off yr-off) (send text editor-location-to-dc-location (unbox xrb) (unbox yrb))]
|
|
[(xr yr) (dc-location-to-editor-location xr-off yr-off)])
|
|
(values (/ (+ xl xr) 2)
|
|
(/ (+ yl yr) 2)))))
|
|
|
|
(inherit invalidate-bitmap-cache)
|
|
(define/public (set-error-arrows arrows)
|
|
(set! error-arrows arrows)
|
|
(invalidate-bitmap-cache))
|
|
|
|
(field [error-arrows #f])
|
|
|
|
(super-new)
|
|
|
|
(inherit set-max-undo-history)
|
|
(set-max-undo-history 'forever))))
|
|
|
|
|
|
|
|
; ; ;; ;
|
|
; ; ;
|
|
; ; ;
|
|
; ;;; ; ;;; ;;; ; ; ;;; ;;;
|
|
; ; ;; ; ; ; ; ;; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ;;;;; ; ; ; ; ;;;;;
|
|
; ; ; ; ; ; ; ; ;
|
|
; ; ;; ; ; ; ; ; ;
|
|
; ;;; ; ;;;; ; ; ; ; ;;;; ; ; ;
|
|
;
|
|
;
|
|
|
|
|
|
|
|
;; get-pos : text mouse-event% -> (union #f number)
|
|
(define (get-pos text event)
|
|
(let*-values ([(event-x event-y)
|
|
(values (send event get-x)
|
|
(send event get-y))]
|
|
[(x y) (send text dc-location-to-editor-location
|
|
event-x
|
|
event-y)])
|
|
(let* ([on-it? (box #f)]
|
|
[pos (send text find-position x y #f on-it?)])
|
|
(and (unbox on-it?)
|
|
pos))))
|
|
|
|
(let ([old (keymap:add-to-right-button-menu)])
|
|
(keymap:add-to-right-button-menu
|
|
(λ (menu editor event)
|
|
(when (is-a? editor text%)
|
|
(let* ([canvas (send editor get-canvas)]
|
|
[frame (and canvas (send canvas get-top-level-window))])
|
|
(when (is-a? frame -frame<%>)
|
|
(let* ([language-settings (send (send frame get-definitions-text) get-next-settings)]
|
|
[new-language (drscheme:language-configuration:language-settings-language language-settings)]
|
|
[capability-info (send new-language capability-value 'drscheme:define-popup)])
|
|
(when capability-info
|
|
(let* ([current-pos (get-pos editor event)]
|
|
[current-word (and current-pos (get-current-word editor current-pos))]
|
|
[defn (and current-word
|
|
(ormap (λ (defn) (and (string=? current-word (defn-name defn))
|
|
defn))
|
|
(get-definitions (car capability-info)
|
|
#f
|
|
editor)))])
|
|
(when defn
|
|
(new separator-menu-item% (parent menu))
|
|
(new menu-item%
|
|
(parent menu)
|
|
(label (format (string-constant jump-to-defn) (defn-name defn)))
|
|
(callback (λ (x y)
|
|
(send editor set-position (defn-start-pos defn))))))))))))
|
|
(old menu editor event))))
|
|
|
|
;; get-current-word : editor number -> string
|
|
;; returns the string that is being clicked on
|
|
(define (get-current-word editor pos)
|
|
(let* ([search
|
|
(λ (dir offset)
|
|
(let loop ([pos pos])
|
|
(cond
|
|
[(or (= pos 0)
|
|
(= pos (send editor last-position)))
|
|
pos]
|
|
[(memq (send editor get-character pos) '(#\space #\return #\newline #\( #\) #\[ #\] #\tab))
|
|
(offset pos)]
|
|
[else (loop (dir pos))])))]
|
|
[before (search sub1 add1)]
|
|
[after (search add1 (λ (x) x))])
|
|
(send editor get-text before after)))
|
|
|
|
(define func-defs-canvas%
|
|
(class name-message%
|
|
(init-field frame)
|
|
|
|
(unless (is-a? frame -frame<%>)
|
|
(error 'func-defs-canvas "frame is not a drscheme:unit:frame<%>"))
|
|
|
|
(define sort-by-name? #f)
|
|
(define sorting-name (string-constant sort-by-name))
|
|
(define/private (change-sorting-order)
|
|
(set! sort-by-name? (not sort-by-name?))
|
|
(set! sorting-name (if sort-by-name?
|
|
(string-constant sort-by-position)
|
|
(string-constant sort-by-name))))
|
|
|
|
(define capability-info (drscheme:language:get-capability-default 'drscheme:define-popup))
|
|
|
|
(inherit set-message set-hidden?)
|
|
(define/public (language-changed new-language)
|
|
(set! capability-info (send new-language capability-value 'drscheme:define-popup))
|
|
(cond
|
|
[capability-info
|
|
(set-message #f (cdr capability-info))
|
|
(set-hidden? #f)]
|
|
[else
|
|
(set-hidden? #t)]))
|
|
(define/override (fill-popup menu reset)
|
|
(when capability-info
|
|
(let* ([text (send frame get-definitions-text)]
|
|
[unsorted-defns (get-definitions (car capability-info)
|
|
(not sort-by-name?)
|
|
text)]
|
|
[defns (if sort-by-name?
|
|
(sort
|
|
unsorted-defns
|
|
(λ (x y) (string-ci<=? (defn-name x) (defn-name y))))
|
|
unsorted-defns)])
|
|
(make-object menu:can-restore-menu-item% sorting-name
|
|
menu
|
|
(λ (x y)
|
|
(change-sorting-order)))
|
|
(make-object separator-menu-item% menu)
|
|
(if (null? defns)
|
|
(send (make-object menu:can-restore-menu-item%
|
|
(string-constant no-definitions-found)
|
|
menu
|
|
void)
|
|
enable #f)
|
|
(let loop ([defns defns])
|
|
(unless (null? defns)
|
|
(let* ([defn (car defns)]
|
|
[checked?
|
|
(let ([t-start (send text get-start-position)]
|
|
[t-end (send text get-end-position)]
|
|
[d-start (defn-start-pos defn)]
|
|
[d-end (defn-end-pos defn)])
|
|
(or (<= t-start d-start t-end)
|
|
(<= t-start d-end t-end)
|
|
(<= d-start t-start t-end d-end)))]
|
|
[item
|
|
(make-object (if checked?
|
|
menu:can-restore-checkable-menu-item%
|
|
menu:can-restore-menu-item%)
|
|
(regexp-replace*
|
|
#rx"&"
|
|
(gui-utils:trim-string (defn-name defn) 200)
|
|
"&&")
|
|
menu
|
|
(λ (x y)
|
|
(reset)
|
|
(send text set-position (defn-start-pos defn) (defn-start-pos defn))
|
|
(let ([canvas (send text get-canvas)])
|
|
(when canvas
|
|
(send canvas focus)))))])
|
|
(when checked?
|
|
(send item check #t))
|
|
(loop (cdr defns)))))))))
|
|
|
|
(super-new (label "(define ...)"))))
|
|
|
|
;; defn = (make-defn number string number number)
|
|
(define-struct defn (indent name start-pos end-pos))
|
|
|
|
;; get-definitions : boolean text -> (listof defn)
|
|
(define (get-definitions tag-string indent? text)
|
|
(let* ([min-indent 0]
|
|
[defs (let loop ([pos 0])
|
|
(let ([defn-pos (send text find-string tag-string 'forward pos 'eof #t #f)])
|
|
(cond
|
|
[(not defn-pos) null]
|
|
[(in-semicolon-comment? text defn-pos)
|
|
(loop (+ defn-pos (string-length tag-string)))]
|
|
[else
|
|
(let ([indent (get-defn-indent text defn-pos)]
|
|
[name (get-defn-name text (+ defn-pos (string-length tag-string)))])
|
|
(set! min-indent (min indent min-indent))
|
|
(cons (make-defn indent name defn-pos defn-pos)
|
|
(loop (+ defn-pos (string-length tag-string)))))])))])
|
|
|
|
;; update end-pos's based on the start pos of the next defn
|
|
(unless (null? defs)
|
|
(let loop ([first (car defs)]
|
|
[defs (cdr defs)])
|
|
(cond
|
|
[(null? defs)
|
|
(set-defn-end-pos! first (send text last-position))]
|
|
[else (set-defn-end-pos! first (max (- (defn-start-pos (car defs)) 1)
|
|
(defn-start-pos first)))
|
|
(loop (car defs) (cdr defs))])))
|
|
|
|
(when indent?
|
|
(for-each (λ (defn)
|
|
(set-defn-name! defn
|
|
(string-append
|
|
(apply string
|
|
(vector->list
|
|
(make-vector
|
|
(- (defn-indent defn) min-indent) #\space)))
|
|
(defn-name defn))))
|
|
defs))
|
|
defs))
|
|
|
|
;; in-semicolon-comment: text number -> boolean
|
|
;; returns #t if `define-start-pos' is in a semicolon comment and #f otherwise
|
|
(define (in-semicolon-comment? text define-start-pos)
|
|
(let* ([para (send text position-paragraph define-start-pos)]
|
|
[start (send text paragraph-start-position para)])
|
|
(let loop ([pos start])
|
|
(cond
|
|
[(pos . >= . define-start-pos) #f]
|
|
[(char=? #\; (send text get-character pos)) #t]
|
|
[else (loop (+ pos 1))]))))
|
|
|
|
;; get-defn-indent : text number -> number
|
|
;; returns the amount to indent a particular definition
|
|
(define (get-defn-indent text pos)
|
|
(let* ([para (send text position-paragraph pos)]
|
|
[para-start (send text paragraph-start-position para #t)])
|
|
(let loop ([c-pos para-start]
|
|
[offset 0])
|
|
(if (< c-pos pos)
|
|
(let ([char (send text get-character c-pos)])
|
|
(cond
|
|
[(char=? char #\tab)
|
|
(loop (+ c-pos 1) (+ offset (- 8 (modulo offset 8))))]
|
|
[else
|
|
(loop (+ c-pos 1) (+ offset 1))]))
|
|
offset))))
|
|
|
|
;; skip-to-whitespace/paren : text number -> number
|
|
;; skips to the next parenthesis or whitespace after `pos', returns that position.
|
|
(define (skip-to-whitespace/paren text pos)
|
|
(let loop ([pos pos])
|
|
(if (>= pos (send text last-position))
|
|
(send text last-position)
|
|
(let ([char (send text get-character pos)])
|
|
(cond
|
|
[(or (char=? #\) char)
|
|
(char=? #\( char)
|
|
(char=? #\] char)
|
|
(char=? #\[ char)
|
|
(char-whitespace? char))
|
|
pos]
|
|
[else (loop (+ pos 1))])))))
|
|
|
|
;; skip-whitespace/paren : text number -> number
|
|
;; skips past any parenthesis or whitespace
|
|
(define (skip-whitespace/paren text pos)
|
|
(let loop ([pos pos])
|
|
(if (>= pos (send text last-position))
|
|
(send text last-position)
|
|
(let ([char (send text get-character pos)])
|
|
(cond
|
|
[(or (char=? #\) char)
|
|
(char=? #\( char)
|
|
(char=? #\] char)
|
|
(char=? #\[ char)
|
|
(char-whitespace? char))
|
|
(loop (+ pos 1))]
|
|
[else pos])))))
|
|
|
|
;; get-defn-name : text number -> string
|
|
;; returns the name of the definition starting at `define-pos'
|
|
(define (get-defn-name text define-pos)
|
|
(if (>= define-pos (send text last-position))
|
|
(string-constant end-of-buffer-define)
|
|
(let* ([start-pos (skip-whitespace/paren text (skip-to-whitespace/paren text define-pos))]
|
|
[end-pos (skip-to-whitespace/paren text start-pos)])
|
|
(send text get-text start-pos end-pos))))
|
|
|
|
(define (set-box/f! b v) (when (box? b) (set-box! b v)))
|
|
|
|
|
|
|
|
|
|
|
|
;;
|
|
;
|
|
;
|
|
;;; ; ;; ;;; ; ;;; ;; ;;;
|
|
; ;; ; ; ;; ;; ; ; ;
|
|
; ; ; ; ; ; ; ;
|
|
; ; ;;;; ; ; ; ;;;;;
|
|
; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ;
|
|
; ; ;;;;; ; ; ; ;;;;
|
|
|
|
|
|
|
|
(define dragable/def-int-mixin
|
|
(mixin (panel:dragable<%>) ()
|
|
(init-field unit-frame)
|
|
(inherit get-percentages)
|
|
(define/augment (after-percentage-change)
|
|
(let ([percentages (get-percentages)])
|
|
(when (and (= 1
|
|
(length (send unit-frame get-definitions-canvases))
|
|
(length (send unit-frame get-interactions-canvases)))
|
|
(= 2 (length percentages)))
|
|
(preferences:set 'drscheme:unit-window-size-percentage (car percentages))))
|
|
(inner (void) after-percentage-change))
|
|
(super-new)))
|
|
|
|
(define vertical-dragable/def-int% (dragable/def-int-mixin panel:vertical-dragable%))
|
|
(define horizontal-dragable/def-int% (dragable/def-int-mixin panel:horizontal-dragable%))
|
|
|
|
(define super-frame%
|
|
(drscheme:frame:mixin
|
|
(drscheme:frame:basics-mixin
|
|
(frame:searchable-text-mixin
|
|
(frame:searchable-mixin
|
|
(frame:text-info-mixin
|
|
(frame:delegate-mixin
|
|
(frame:status-line-mixin
|
|
(frame:info-mixin
|
|
(frame:text-mixin
|
|
(frame:open-here-mixin
|
|
(frame:editor-mixin
|
|
(frame:standard-menus-mixin
|
|
(frame:register-group-mixin
|
|
(frame:basic-mixin
|
|
frame%)))))))))))))))
|
|
|
|
(define tab%
|
|
(class* object% (drscheme:rep:context<%> tab<%>)
|
|
(init-field frame
|
|
defs
|
|
i
|
|
defs-shown?
|
|
ints-shown?)
|
|
(define enabled? #t)
|
|
(field [ints #f]
|
|
[visible-defs #f]
|
|
[visible-ints #f]
|
|
[focus-d/i 'defs])
|
|
|
|
;; only called to initialize this tab.
|
|
;; the interactions editor should be invariant.
|
|
(define/public (set-ints i) (set! ints i))
|
|
|
|
(define/public-final (get-frame) frame)
|
|
(define/public-final (get-defs) defs)
|
|
(define/public-final (get-ints) ints)
|
|
(define/public-final (get-visible-defs) (values visible-defs defs-shown?))
|
|
(define/public-final (set-visible-defs vd ds?)
|
|
(set! visible-defs vd)
|
|
(set! defs-shown? ds?))
|
|
(define/public-final (get-visible-ints) (values visible-ints ints-shown?))
|
|
(define/public-final (set-visible-ints vi is?)
|
|
(set! visible-ints vi)
|
|
(set! ints-shown? is?))
|
|
(define/public-final (set-focus-d/i di)
|
|
(set! focus-d/i di))
|
|
(define/public-final (get-focus-d/i) focus-d/i)
|
|
(define/public-final (get-i) i)
|
|
(define/public-final (set-i _i) (set! i _i))
|
|
(define/public (disable-evaluation)
|
|
(set! enabled? #f)
|
|
(send defs lock #t)
|
|
(send ints lock #t)
|
|
(send frame disable-evaluation-in-tab this))
|
|
(define/public (enable-evaluation)
|
|
(set! enabled? #t)
|
|
(send defs lock #f)
|
|
(send ints lock #f)
|
|
(send frame enable-evaluation-in-tab this))
|
|
(define/public (get-enabled) enabled?)
|
|
|
|
(define/public (get-directory)
|
|
(let ([filename (send defs get-filename)])
|
|
(if (and (path? filename)
|
|
(file-exists? filename))
|
|
(let-values ([(base _1 _2) (split-path (normalize-path filename))])
|
|
base)
|
|
#f)))
|
|
(define/public (needs-execution)
|
|
(send defs needs-execution))
|
|
|
|
(define/pubment (can-close?)
|
|
(and (send defs can-close?)
|
|
(send ints can-close?)
|
|
(inner #t can-close?)))
|
|
(define/pubment (on-close)
|
|
(send defs on-close)
|
|
(send ints on-close)
|
|
(inner (void) on-close))
|
|
|
|
;; this should really do something local to the tab, but
|
|
;; for now it doesn't.
|
|
(define/public (ensure-rep-shown rep)
|
|
(send frame ensure-rep-shown rep))
|
|
|
|
(field [thread-to-break-box (make-weak-box #f)]
|
|
[custodian-to-kill-box (make-weak-box #f)]
|
|
[offer-kill? #f])
|
|
|
|
;; break-callback : -> void
|
|
(define/public (break-callback)
|
|
(let ([thread-to-break (weak-box-value thread-to-break-box)]
|
|
[custodian-to-kill (weak-box-value custodian-to-kill-box)])
|
|
(cond
|
|
[(or (not thread-to-break)
|
|
(not custodian-to-kill))
|
|
(bell)]
|
|
[offer-kill?
|
|
(if (user-wants-kill?)
|
|
(when thread-to-break
|
|
(break-thread thread-to-break))
|
|
(when custodian-to-kill
|
|
(custodian-shutdown-all custodian-to-kill)))]
|
|
[else
|
|
(when thread-to-break
|
|
(break-thread thread-to-break))
|
|
;; only offer a kill the next time if
|
|
;; something got broken.
|
|
(set! offer-kill? #t)])))
|
|
|
|
;; user-wants-kill? : -> boolean
|
|
;; handles events, so be sure to check state
|
|
;; after calling to avoid race conditions.
|
|
(define/private (user-wants-kill?)
|
|
(gui-utils:get-choice
|
|
(string-constant kill-evaluation?)
|
|
(string-constant just-break)
|
|
(string-constant kill)
|
|
(string-constant kill?)
|
|
'diallow-close
|
|
frame))
|
|
|
|
;; reset-offer-kill
|
|
(define/public (reset-offer-kill)
|
|
(set! offer-kill? #f))
|
|
|
|
;; get-breakables : -> (union #f thread) (union #f cust) -> void
|
|
(define/public (get-breakables)
|
|
(values (weak-box-value thread-to-break-box) (weak-box-value custodian-to-kill-box)))
|
|
|
|
;; set-breakables : (union #f thread) (union #f cust) -> void
|
|
(define/public (set-breakables thd cust)
|
|
(set! thread-to-break-box (make-weak-box thd))
|
|
(set! custodian-to-kill-box (make-weak-box cust)))
|
|
|
|
(define/pubment (clear-annotations)
|
|
(inner (void) clear-annotations)
|
|
(send ints reset-highlighting))
|
|
|
|
(define running? #f)
|
|
(define/public-final (is-running?) running?)
|
|
(define/public (update-running b?)
|
|
(set! running? b?)
|
|
(send frame update-running b?))
|
|
|
|
(define/public-final (is-current-tab?) (eq? this (send frame get-current-tab)))
|
|
|
|
(super-new)))
|
|
|
|
;; should only be called by the tab% object
|
|
(define-local-member-name
|
|
disable-evaluation-in-tab
|
|
enable-evaluation-in-tab)
|
|
|
|
(define -frame<%>
|
|
(interface (drscheme:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:open-here<%>)
|
|
get-special-menu
|
|
get-interactions-text
|
|
get-definitions-text
|
|
get-interactions-canvas
|
|
get-definitions-canvas
|
|
get-button-panel
|
|
execute-callback
|
|
get-current-tab
|
|
open-in-new-tab
|
|
on-tab-change
|
|
enable-evaluation
|
|
disable-evaluation
|
|
get-definitions/interactions-panel-parent
|
|
register-capability-menu-item
|
|
|
|
ensure-rep-shown
|
|
ensure-rep-hidden
|
|
ensure-defs-shown))
|
|
|
|
(define frame-mixin
|
|
(mixin (drscheme:frame:<%> frame:searchable-text<%> frame:delegate<%> frame:open-here<%>)
|
|
(-frame<%>)
|
|
(init filename)
|
|
(inherit set-label-prefix get-show-menu
|
|
get-menu%
|
|
get-area-container
|
|
update-info
|
|
get-file-menu
|
|
file-menu:get-close-item
|
|
file-menu:get-save-item
|
|
file-menu:get-save-as-item
|
|
file-menu:get-revert-item
|
|
file-menu:get-print-item)
|
|
|
|
;; logging : (union #f string[directory-name])
|
|
(field [logging #f]
|
|
[definitions-log-counter 0] ;; number
|
|
[interactions-log-counter 0] ;; number
|
|
[logging-parent-panel #f] ;; panel (unitialized short time only)
|
|
[logging-panel #f] ;; panel (unitialized short time only)
|
|
[logging-menu-item #f]) ;; menu-item (unitialized short time only)
|
|
;; log-definitions : -> void
|
|
(define/private (log-definitions)
|
|
(when logging
|
|
(set! definitions-log-counter (+ definitions-log-counter 1))
|
|
(send definitions-text save-file
|
|
(build-path logging (format "~a-definitions" (pad-two definitions-log-counter)))
|
|
'copy)))
|
|
|
|
;; log-ineractions : -> void
|
|
(define/private (log-interactions)
|
|
(when logging
|
|
(set! interactions-log-counter (+ interactions-log-counter 1))
|
|
(send interactions-text save-file
|
|
(build-path logging (format "~a-interactions" (pad-two interactions-log-counter)))
|
|
'copy)))
|
|
|
|
;; pad-two : number -> string
|
|
;; pads a number to two digits?
|
|
(define/private (pad-two n)
|
|
(cond
|
|
[(<= 0 n 9) (format "0~a" n)]
|
|
[else (format "~a" n)]))
|
|
|
|
;; start-logging : -> void
|
|
;; turns on the logging and shows the logging gui
|
|
(define/private (start-logging)
|
|
(let ([log-directory (mred:get-directory
|
|
(string-constant please-choose-a-log-directory)
|
|
this)])
|
|
(when (and log-directory
|
|
(ensure-empty log-directory))
|
|
(send logging-menu-item set-label (string-constant stop-logging))
|
|
(set! logging log-directory)
|
|
(set! definitions-log-counter 0)
|
|
(set! interactions-log-counter 0)
|
|
(build-logging-panel)
|
|
(log-definitions))))
|
|
|
|
;; stop-logging : -> void
|
|
;; turns off the logging procedure
|
|
(define/private (stop-logging)
|
|
(log-interactions)
|
|
(send logging-menu-item set-label (string-constant log-definitions-and-interactions))
|
|
(set! logging #f)
|
|
(send logging-panel change-children (λ (l) null)))
|
|
|
|
;; build-logging-panel : -> void
|
|
;; builds the contents of the logging panel
|
|
(define/private (build-logging-panel)
|
|
(define hp (make-object horizontal-panel% logging-panel '(border)))
|
|
(make-object message% (string-constant logging-to) hp)
|
|
(send (make-object message% (path->string logging) hp) stretchable-width #t)
|
|
(make-object button% (string-constant stop-logging) hp (λ (x y) (stop-logging))))
|
|
|
|
;; ensure-empty : string[directory] -> boolean
|
|
;; if the log-directory is empty, just return #t
|
|
;; if not, ask the user about emptying it.
|
|
;; if they say yes, try to empty it.
|
|
;; if that fails, report the error and return #f.
|
|
;; if it succeeds, return #t.
|
|
;; if they say no, return #f.
|
|
(define/private (ensure-empty log-directory)
|
|
(let ([dir-list (directory-list log-directory)])
|
|
(or (null? dir-list)
|
|
(let ([query (message-box
|
|
(string-constant drscheme)
|
|
(format (string-constant erase-log-directory-contents) log-directory)
|
|
this
|
|
'(yes-no))])
|
|
(cond
|
|
[(eq? query 'no)
|
|
#f]
|
|
[(eq? query 'yes)
|
|
(with-handlers ([exn:fail:filesystem?
|
|
(λ (exn)
|
|
(message-box
|
|
(string-constant drscheme)
|
|
(format (string-constant error-erasing-log-directory)
|
|
(if (exn? exn)
|
|
(format "~a" (exn-message exn))
|
|
(format "~s" exn)))
|
|
this)
|
|
#f)])
|
|
(for-each (λ (file) (delete-file (build-path log-directory file)))
|
|
dir-list)
|
|
#t)])))))
|
|
|
|
(define/override (make-root-area-container cls parent)
|
|
(let* ([outer-panel (super make-root-area-container module-browser-dragable-panel% parent)]
|
|
[saved-p (preferences:get 'drscheme:module-browser-size-percentage)]
|
|
[_module-browser-panel (new vertical-panel%
|
|
(parent outer-panel)
|
|
(alignment '(left center))
|
|
(stretchable-width #f))]
|
|
[louter-panel (make-object vertical-panel% outer-panel)]
|
|
[root (make-object cls louter-panel)])
|
|
(set! module-browser-panel _module-browser-panel)
|
|
(set! module-browser-parent-panel outer-panel)
|
|
(send outer-panel change-children (λ (l) (remq module-browser-panel l)))
|
|
(preferences:set 'drscheme:module-browser-size-percentage saved-p)
|
|
(set! logging-parent-panel (new horizontal-panel%
|
|
(parent louter-panel)
|
|
(stretchable-height #f)))
|
|
(set! logging-panel (make-object horizontal-panel% logging-parent-panel))
|
|
(unless toolbar-shown?
|
|
(send logging-parent-panel change-children (λ (l) '())))
|
|
root))
|
|
|
|
(inherit show-info hide-info is-info-hidden?)
|
|
(field [toolbar-shown? (preferences:get 'drscheme:toolbar-shown)]
|
|
[toolbar-menu-item #f])
|
|
|
|
(define/override (on-toolbar-button-click)
|
|
(toggle-toolbar-visiblity))
|
|
|
|
(define/private (toggle-toolbar-visiblity)
|
|
(set! toolbar-shown? (not toolbar-shown?))
|
|
(preferences:set 'drscheme:toolbar-shown toolbar-shown?)
|
|
(update-toolbar-visiblity))
|
|
|
|
(define/private (update-toolbar-visiblity)
|
|
(cond
|
|
[toolbar-shown?
|
|
(show-info)
|
|
(send top-outer-panel change-children (λ (l) (list top-panel)))
|
|
(send logging-parent-panel change-children (λ (l) (list logging-panel)))
|
|
(send toolbar-menu-item set-label (string-constant hide-toolbar))]
|
|
[else
|
|
(hide-info)
|
|
(send top-outer-panel change-children (λ (l) '()))
|
|
(send logging-parent-panel change-children (λ (l) '()))
|
|
(send toolbar-menu-item set-label (string-constant show-toolbar))])
|
|
(update-defs/ints-resize-corner))
|
|
|
|
(field [remove-show-status-line-callback
|
|
(preferences:add-callback
|
|
'framework:show-status-line
|
|
(λ (p v)
|
|
(update-defs/ints-resize-corner/pref v)))])
|
|
|
|
(define/private (update-defs/ints-resize-corner)
|
|
(update-defs/ints-resize-corner/pref (preferences:get 'framework:show-status-line)))
|
|
|
|
(define/private (update-defs/ints-resize-corner/pref si-pref)
|
|
(let ([bottom-material? (and toolbar-shown? si-pref)])
|
|
(let loop ([cs definitions-canvases])
|
|
(cond
|
|
[(null? cs) (void)]
|
|
[(null? (cdr cs))
|
|
(send (car cs) set-resize-corner (and (not bottom-material?)
|
|
(not interactions-shown?)))]
|
|
[else
|
|
(send (car cs) set-resize-corner #f)
|
|
(loop (cdr cs))]))
|
|
(let loop ([cs interactions-canvases])
|
|
(cond
|
|
[(null? cs) (void)]
|
|
[(null? (cdr cs))
|
|
(send (car cs) set-resize-corner (and (not bottom-material?)
|
|
interactions-shown?))]
|
|
[else
|
|
(send (car cs) set-resize-corner #f)
|
|
(loop (cdr cs))]))))
|
|
|
|
[define definitions-item #f]
|
|
[define interactions-item #f]
|
|
[define name-message #f]
|
|
[define save-button #f]
|
|
[define save-init-shown? #f]
|
|
|
|
[define/private set-save-init-shown? (λ (x) (set! save-init-shown? x))]
|
|
|
|
[define canvas-show-mode #f]
|
|
[define allow-split? #f]
|
|
[define forced-quit? #f]
|
|
[define search-canvas #f]
|
|
|
|
(define/public (make-searchable canvas)
|
|
(update-info)
|
|
(set! search-canvas canvas))
|
|
(define/override (get-text-to-search)
|
|
(if search-canvas
|
|
(send search-canvas get-editor)
|
|
(get-editor)))
|
|
|
|
(define was-locked? #f)
|
|
|
|
(define/public-final (disable-evaluation-in-tab tab)
|
|
(when (eq? tab current-tab)
|
|
(disable-evaluation)))
|
|
|
|
(define/pubment (disable-evaluation)
|
|
(when execute-menu-item
|
|
(send execute-menu-item enable #f))
|
|
(send execute-button enable #f)
|
|
(inner (void) disable-evaluation))
|
|
|
|
(define/public-final (enable-evaluation-in-tab tab)
|
|
(when (eq? tab current-tab)
|
|
(enable-evaluation)))
|
|
|
|
(define/pubment (enable-evaluation)
|
|
(when execute-menu-item
|
|
(send execute-menu-item enable #t))
|
|
(send execute-button enable #t)
|
|
(inner (void) enable-evaluation))
|
|
|
|
(inherit set-label)
|
|
(inherit modified)
|
|
(define/public (update-save-button)
|
|
(let ([mod? (send definitions-text is-modified?)])
|
|
(modified mod?)
|
|
(if save-button
|
|
(unless (eq? mod? (send save-button is-shown?))
|
|
(send save-button show mod?))
|
|
(set! save-init-shown? mod?))
|
|
(update-tab-label current-tab)))
|
|
|
|
(define/public (language-changed)
|
|
(let* ([settings (send definitions-text get-next-settings)]
|
|
[language (drscheme:language-configuration:language-settings-language settings)])
|
|
(send func-defs-canvas language-changed language)
|
|
(send language-message set-yellow/lang
|
|
(not (send definitions-text this-and-next-language-the-same?))
|
|
(string-append (send language get-language-name)
|
|
(if (send language default-settings?
|
|
(drscheme:language-configuration:language-settings-settings settings))
|
|
""
|
|
(string-append " " (string-constant custom)))))
|
|
(let ([label (send scheme-menu get-label)]
|
|
[new-label (send language capability-value 'drscheme:language-menu-title)])
|
|
(unless (equal? label new-label)
|
|
(send scheme-menu set-label new-label)))))
|
|
|
|
;; update-save-message : -> void
|
|
;; sets the save message. If input is #f, uses the frame's
|
|
;; title.
|
|
(define/public (update-save-message)
|
|
(when name-message
|
|
(let ([filename (send definitions-text get-filename)])
|
|
(send name-message set-message
|
|
(if filename #t #f)
|
|
(send definitions-text get-filename/untitled-name))))
|
|
(update-tabs-labels))
|
|
|
|
(define/private (update-tabs-labels)
|
|
(for-each (λ (tab) (update-tab-label tab)) tabs)
|
|
(send tabs-panel set-selection (send current-tab get-i))
|
|
(send (send tabs-panel get-parent)
|
|
change-children
|
|
(λ (l)
|
|
(cond
|
|
[(= (send tabs-panel get-number) 1)
|
|
(remq tabs-panel l)]
|
|
[else
|
|
(if (memq tabs-panel l)
|
|
l
|
|
(cons tabs-panel l))]))))
|
|
|
|
(define/private (update-tab-label tab)
|
|
(let ([label (get-defs-tab-label (send tab get-defs) tab)])
|
|
(unless (equal? label (send tabs-panel get-item-label (send tab get-i)))
|
|
(send tabs-panel set-item-label (send tab get-i) label))))
|
|
|
|
(define/private (get-defs-tab-label defs tab)
|
|
(let ([fn (send defs get-filename)])
|
|
(add-modified-flag
|
|
defs
|
|
(if fn
|
|
(get-tab-label-from-filename fn)
|
|
(send defs get-filename/untitled-name)))))
|
|
|
|
(define/private (get-tab-label-from-filename fn)
|
|
(let* ([take-n
|
|
(λ (n lst)
|
|
(let loop ([n n]
|
|
[lst lst])
|
|
(cond
|
|
[(zero? n) null]
|
|
[(null? lst) null]
|
|
[else (cons (car lst) (loop (- n 1) (cdr lst)))])))]
|
|
[find-exp-diff
|
|
(λ (p1 p2)
|
|
(let loop ([p1 p1]
|
|
[p2 p2]
|
|
[i 1])
|
|
(cond
|
|
[(or (null? p1) (null? p2)) i]
|
|
[else (let ([f1 (car p1)]
|
|
[f2 (car p2)])
|
|
(if (equal? f1 f2)
|
|
(loop (cdr p1) (cdr p2) (+ i 1))
|
|
i))])))]
|
|
[exp (reverse (explode-path (normalize-path/exists fn)))]
|
|
[other-exps
|
|
(filter
|
|
(λ (x) (and x
|
|
(not (equal? exp x))))
|
|
(map (λ (other-tab)
|
|
(let ([fn (send (send other-tab get-defs) get-filename)])
|
|
(and fn
|
|
(reverse (explode-path (normalize-path/exists fn))))))
|
|
tabs))]
|
|
[size
|
|
(let loop ([other-exps other-exps]
|
|
[size 1])
|
|
(cond
|
|
[(null? other-exps) size]
|
|
[else (let ([new-size (find-exp-diff (car other-exps) exp)])
|
|
(loop (cdr other-exps)
|
|
(max new-size size)))]))])
|
|
(path->string (apply build-path (reverse (take-n size exp))))))
|
|
|
|
(define/private (normalize-path/exists fn)
|
|
(if (file-exists? fn)
|
|
(normalize-path fn)
|
|
fn))
|
|
|
|
(define/private (add-modified-flag text string)
|
|
(if (send text is-modified?)
|
|
(let ([prefix (get-save-diamond-prefix)])
|
|
(if prefix
|
|
(string-append prefix string)
|
|
string))
|
|
string))
|
|
|
|
(define/private (get-save-diamond-prefix)
|
|
(let ([candidate-prefixes (list
|
|
(case (system-type)
|
|
[(windows) "• "]
|
|
[else "◆ "])
|
|
"* ")])
|
|
(ormap
|
|
(lambda (candidate)
|
|
(and (andmap (λ (x) (send normal-control-font screen-glyph-exists? x #t))
|
|
(string->list candidate))
|
|
candidate))
|
|
candidate-prefixes)))
|
|
|
|
[define/override get-canvas% (λ () (drscheme:get/extend:get-definitions-canvas))]
|
|
|
|
(define/public (update-running running?)
|
|
(send running-canvas set-running running?))
|
|
(define/public (ensure-defs-shown)
|
|
(unless definitions-shown?
|
|
(toggle-show/hide-definitions)
|
|
(update-shown)))
|
|
(define/public (ensure-rep-shown rep)
|
|
(unless (eq? rep interactions-text)
|
|
(let loop ([tabs tabs])
|
|
(unless (null? tabs)
|
|
(let ([tab (car tabs)])
|
|
(if (eq? (send tab get-ints) rep)
|
|
(change-to-tab tab)
|
|
(loop (cdr tabs)))))))
|
|
(unless interactions-shown?
|
|
(toggle-show/hide-interactions)
|
|
(update-shown)))
|
|
(define/public (ensure-rep-hidden)
|
|
(when interactions-shown?
|
|
(toggle-show/hide-interactions)
|
|
(update-shown)))
|
|
|
|
(define/override (get-editor%) (drscheme:get/extend:get-definitions-text))
|
|
(define/public (still-untouched?)
|
|
(and (= (send definitions-text last-position) 0)
|
|
(not (send definitions-text is-modified?))
|
|
(not (send definitions-text get-filename))
|
|
(let* ([prompt (send interactions-text get-prompt)]
|
|
[first-prompt-para
|
|
(let loop ([n 0])
|
|
(cond
|
|
[(n . <= . (send interactions-text last-paragraph))
|
|
(if (string=?
|
|
(send interactions-text get-text
|
|
(send interactions-text paragraph-start-position n)
|
|
(+ (send interactions-text paragraph-start-position n)
|
|
(string-length prompt)))
|
|
prompt)
|
|
n
|
|
(loop (+ n 1)))]
|
|
[else #f]))])
|
|
(and first-prompt-para
|
|
(= first-prompt-para (send interactions-text last-paragraph))
|
|
(equal?
|
|
(send interactions-text get-text
|
|
(send interactions-text paragraph-start-position first-prompt-para)
|
|
(send interactions-text paragraph-end-position first-prompt-para))
|
|
(send interactions-text get-prompt))))))
|
|
(define/public (change-to-file name)
|
|
(cond
|
|
[(and name (file-exists? name))
|
|
(ensure-rep-hidden)
|
|
(send definitions-text begin-edit-sequence)
|
|
(send definitions-text load-file/gui-error name)
|
|
(send definitions-text end-edit-sequence)
|
|
(send language-message set-yellow #f)]
|
|
[name
|
|
(send definitions-text set-filename name)]
|
|
[else (send definitions-text clear)])
|
|
(send definitions-canvas focus))
|
|
|
|
|
|
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ;
|
|
; ;
|
|
; ;
|
|
; ; ;; ;; ;;; ;; ; ;;; ;;;
|
|
; ;; ;; ; ; ; ; ;; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ;;
|
|
; ; ; ; ; ; ; ; ;;;;;; ;;
|
|
; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ;; ; ;
|
|
; ; ; ; ;;; ;; ; ;;;; ;;;
|
|
;
|
|
;
|
|
;
|
|
|
|
|
|
(define/private (add-modes-submenu edit-menu)
|
|
(new menu%
|
|
(parent edit-menu)
|
|
(label (string-constant mode-submenu-label))
|
|
(demand-callback
|
|
(λ (menu)
|
|
(for-each (λ (item) (send item delete))
|
|
(send menu get-items))
|
|
(for-each (λ (mode)
|
|
(let* ([item
|
|
(new checkable-menu-item%
|
|
(label (drscheme:modes:mode-name mode))
|
|
(parent menu)
|
|
(callback
|
|
(λ (_1 _2) (send definitions-text set-current-mode mode))))])
|
|
(when (send definitions-text is-current-mode? mode)
|
|
(send item check #t))))
|
|
(drscheme:modes:get-modes))))))
|
|
|
|
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ; ; ; ;
|
|
; ; ; ; ;
|
|
; ; ; ; ; ;
|
|
; ;;; ; ;; ; ; ;;;; ; ;;; ;;; ; ; ;;; ; ;; ;;; ;;;
|
|
; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ;
|
|
; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;
|
|
; ;; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ;; ;;;;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;
|
|
; ;;; ; ;; ; ; ;; ; ;;; ;;; ; ; ;;;;; ; ;; ;;; ;;;;
|
|
; ; ; ;
|
|
; ; ; ;
|
|
; ; ;
|
|
|
|
|
|
(inherit get-edit-target-window)
|
|
|
|
(define/private (split)
|
|
(let ([canvas-to-be-split (get-edit-target-window)])
|
|
(cond
|
|
[(memq canvas-to-be-split definitions-canvases)
|
|
(split-definitions canvas-to-be-split)]
|
|
[(memq canvas-to-be-split interactions-canvases)
|
|
(split-interactions canvas-to-be-split)]
|
|
[else (bell)])))
|
|
|
|
(define/private (split-definitions canvas-to-be-split)
|
|
(handle-split canvas-to-be-split
|
|
(λ (x) (set! definitions-canvases x))
|
|
definitions-canvases
|
|
(drscheme:get/extend:get-definitions-canvas)
|
|
definitions-text))
|
|
|
|
(define/private (split-interactions canvas-to-be-split)
|
|
(handle-split canvas-to-be-split
|
|
(λ (x) (set! interactions-canvases x))
|
|
interactions-canvases
|
|
(drscheme:get/extend:get-interactions-canvas)
|
|
interactions-text))
|
|
|
|
(define/private (handle-split canvas-to-be-split set-canvases! canvases canvas% text)
|
|
(let-values ([(ox oy ow oh cursor-y)
|
|
(get-visible-region canvas-to-be-split)])
|
|
(let ([orig-percentages (send resizable-panel get-percentages)]
|
|
[orig-canvases (send resizable-panel get-children)]
|
|
[new-canvas (new canvas%
|
|
(parent resizable-panel)
|
|
(editor text)
|
|
(style '()))])
|
|
|
|
(set-canvases!
|
|
(let loop ([canvases canvases])
|
|
(cond
|
|
[(null? canvases) (error 'split "couldn't split; didn't find canvas")]
|
|
[else
|
|
(let ([canvas (car canvases)])
|
|
(if (eq? canvas canvas-to-be-split)
|
|
(list* new-canvas
|
|
canvas
|
|
(cdr canvases))
|
|
(cons canvas (loop (cdr canvases)))))])))
|
|
|
|
(update-shown)
|
|
|
|
;; with-handlers prevents bad calls to set-percentages
|
|
;; might still leave GUI in bad state, however.
|
|
(with-handlers ([exn:fail? (λ (x) (void))])
|
|
(send resizable-panel set-percentages
|
|
(let loop ([canvases orig-canvases]
|
|
[percentages orig-percentages])
|
|
(cond
|
|
[(null? canvases)
|
|
(error 'split "couldn't split; didn't find canvas")]
|
|
[(null? percentages)
|
|
(error 'split "wrong number of percentages: ~s ~s"
|
|
orig-percentages
|
|
(send resizable-panel get-children))]
|
|
[else (let ([canvas (car canvases)])
|
|
(if (eq? canvas-to-be-split canvas)
|
|
(list* (/ (car percentages) 2)
|
|
(/ (car percentages) 2)
|
|
(cdr percentages))
|
|
(cons
|
|
(car percentages)
|
|
(loop (cdr canvases)
|
|
(cdr percentages)))))]))))
|
|
|
|
(set-visible-region new-canvas ox oy ow oh cursor-y)
|
|
(set-visible-region canvas-to-be-split ox oy ow oh cursor-y)
|
|
|
|
(send new-canvas focus))))
|
|
|
|
;; split-demand : menu-item -> void
|
|
;; enables the menu-item if splitting is allowed, disables otherwise
|
|
(define/private (split-demand item)
|
|
(let ([canvas-to-be-split (get-edit-target-window)])
|
|
(send item enable
|
|
(or (memq canvas-to-be-split definitions-canvases)
|
|
(memq canvas-to-be-split interactions-canvases)))))
|
|
|
|
;; collapse-demand : menu-item -> void
|
|
;; enables the menu-item if collapsing is allowed, disables otherwise
|
|
(define/private (collapse-demand item)
|
|
(let ([canvas-to-be-split (get-edit-target-window)])
|
|
(cond
|
|
[(memq canvas-to-be-split definitions-canvases)
|
|
(send item enable (2 . <= . (length definitions-canvases)))]
|
|
[(memq canvas-to-be-split interactions-canvases)
|
|
(send item enable (2 . <= . (length interactions-canvases)))]
|
|
[else
|
|
(send item enable #f)])))
|
|
|
|
;; get-visible-region : editor-canvas -> number number number number (union #f number)
|
|
;; calculates the visible region of the editor in this editor-canvas, returning
|
|
;; four numbers for the x, y, width and height of the visible region
|
|
;; also, the last two booleans indiciate if the beginning and the end
|
|
;; of the selection was visible before the split, respectively.
|
|
(define/private (get-visible-region canvas)
|
|
(send canvas call-as-primary-owner
|
|
(λ ()
|
|
(let* ([text (send canvas get-editor)]
|
|
[admin (send text get-admin)]
|
|
[start (send text get-start-position)]
|
|
[end (send text get-end-position)])
|
|
(let-values ([(x y w h) (get-visible-area admin)])
|
|
(let ([ysb (box 0)])
|
|
(send text position-location (send text get-start-position) #f ysb)
|
|
(values x y w h
|
|
(and (= start end)
|
|
(<= y (unbox ysb) (+ y h))
|
|
(unbox ysb)))))))))
|
|
|
|
;; set-visible-region : editor-canvas number number number number (union #f number) -> void
|
|
;; sets the visible region of the text displayed by the editor canvas
|
|
;; to be the middle of the region (vertically) specified by x, y, w, and h.
|
|
;; if start-visible? and/or end-visible? are true, some special handling
|
|
;; is done to try to keep the start and end visible, with precendence
|
|
;; given to start if both are #t.
|
|
(define/private (set-visible-region canvas x y w h cursor-y)
|
|
(send canvas call-as-primary-owner
|
|
(λ ()
|
|
(let* ([text (send canvas get-editor)]
|
|
[admin (send text get-admin)]
|
|
[nwb (box 0)]
|
|
[nhb (box 0)])
|
|
(send admin get-view #f #f nwb nhb)
|
|
(let* ([nw (unbox nwb)]
|
|
[nh (unbox nhb)]
|
|
|
|
[nx x]
|
|
[raw-y (- (+ y (/ h 2)) (/ nh 2))]
|
|
[ny (if (and cursor-y
|
|
(not (<= raw-y cursor-y (+ raw-y nh))))
|
|
(- cursor-y (/ nh 2))
|
|
raw-y)])
|
|
(send canvas scroll-to nx ny nw nh #t)
|
|
(void))))))
|
|
|
|
;; get-visible-area : admin -> number number number number
|
|
;; returns the visible area for this admin
|
|
(define/private (get-visible-area admin)
|
|
(let ([bx (box 0)]
|
|
[by (box 0)]
|
|
[bw (box 0)]
|
|
[bh (box 0)])
|
|
(send admin get-view bx by bw bh)
|
|
(values (unbox bx)
|
|
(unbox by)
|
|
(unbox bw)
|
|
(unbox bh))))
|
|
|
|
(define/private (collapse)
|
|
(let* ([target (get-edit-target-window)])
|
|
(cond
|
|
[(memq target definitions-canvases)
|
|
(collapse-definitions target)]
|
|
[(memq target interactions-canvases)
|
|
(collapse-interactions target)]
|
|
[else (bell)])))
|
|
|
|
(define/private (collapse-definitions target)
|
|
(handle-collapse
|
|
target
|
|
(λ () definitions-canvases)
|
|
(λ (c) (set! definitions-canvases c))))
|
|
|
|
(define/private (collapse-interactions target)
|
|
(handle-collapse
|
|
target
|
|
(λ () interactions-canvases)
|
|
(λ (c) (set! interactions-canvases c))))
|
|
|
|
(define/private (handle-collapse target get-canvases set-canvases!)
|
|
(if (= 1 (length (get-canvases)))
|
|
(bell)
|
|
(let* ([old-percentages (send resizable-panel get-percentages)]
|
|
[soon-to-be-bigger-canvas #f]
|
|
[percentages
|
|
(if (eq? (car (get-canvases)) target)
|
|
(begin
|
|
(set! soon-to-be-bigger-canvas (cadr (get-canvases)))
|
|
(cons (+ (car old-percentages)
|
|
(cadr old-percentages))
|
|
(cddr old-percentages)))
|
|
(let loop ([canvases (cdr (get-canvases))]
|
|
[prev-canvas (car (get-canvases))]
|
|
[percentages (cdr old-percentages)]
|
|
[prev-percentage (car old-percentages)])
|
|
(cond
|
|
[(null? canvases)
|
|
(error 'collapse "internal error.1")]
|
|
[(null? percentages)
|
|
(error 'collapse "internal error.2")]
|
|
[else
|
|
(if (eq? (car canvases) target)
|
|
(begin
|
|
(set! soon-to-be-bigger-canvas prev-canvas)
|
|
(cons (+ (car percentages)
|
|
prev-percentage)
|
|
(cdr percentages)))
|
|
(cons prev-percentage
|
|
(loop (cdr canvases)
|
|
(car canvases)
|
|
(cdr percentages)
|
|
(car percentages))))])))])
|
|
(unless soon-to-be-bigger-canvas
|
|
(error 'collapse "internal error.3"))
|
|
(set-canvases! (remq target (get-canvases)))
|
|
(update-shown)
|
|
|
|
(let ([target-admin
|
|
(send target call-as-primary-owner
|
|
(λ ()
|
|
(send (send target get-editor) get-admin)))]
|
|
[to-be-bigger-admin
|
|
(send soon-to-be-bigger-canvas call-as-primary-owner
|
|
(λ ()
|
|
(send (send soon-to-be-bigger-canvas get-editor) get-admin)))])
|
|
(let-values ([(bx by bw bh) (get-visible-area target-admin)])
|
|
|
|
;; this line makes the soon-to-be-bigger-canvas bigger
|
|
;; if it fails, we're out of luck, but at least we don't crash.
|
|
(with-handlers ([exn:fail? (λ (x) (void))])
|
|
(send resizable-panel set-percentages percentages))
|
|
|
|
(let-values ([(ax ay aw ah) (get-visible-area to-be-bigger-admin)])
|
|
(send soon-to-be-bigger-canvas scroll-to
|
|
bx
|
|
(- by (/ (- ah bh) 2))
|
|
aw
|
|
ah
|
|
#t))))
|
|
|
|
(send target set-editor #f)
|
|
(send soon-to-be-bigger-canvas focus))))
|
|
;
|
|
;
|
|
;
|
|
; ;
|
|
; ;
|
|
; ;
|
|
; ;;; ; ;; ;;; ; ; ; ; ;; ;; ;;; ; ;; ; ;
|
|
; ; ;; ; ; ; ; ; ; ;; ;; ; ; ; ;; ; ; ;
|
|
; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;; ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;
|
|
; ;;; ; ; ;;; ; ; ; ; ; ;;;; ; ; ;; ;
|
|
;
|
|
;
|
|
;
|
|
|
|
|
|
(define interactions-shown? #t)
|
|
(define definitions-shown? #t)
|
|
|
|
(define/private (toggle-show/hide-definitions)
|
|
(set! definitions-shown? (not definitions-shown?))
|
|
(unless definitions-shown?
|
|
(set! interactions-shown? #t)))
|
|
(define/private (toggle-show/hide-interactions)
|
|
(set! interactions-shown? (not interactions-shown?))
|
|
(unless interactions-shown?
|
|
(set! definitions-shown? #t)))
|
|
|
|
(define/override (update-shown)
|
|
(super update-shown)
|
|
|
|
(let ([new-children
|
|
(foldl
|
|
(λ (shown? children sofar)
|
|
(if shown?
|
|
(append children sofar)
|
|
sofar))
|
|
null
|
|
(list interactions-shown?
|
|
definitions-shown?)
|
|
(list interactions-canvases
|
|
definitions-canvases))]
|
|
[p (preferences:get 'drscheme:unit-window-size-percentage)])
|
|
|
|
(update-defs/ints-resize-corner)
|
|
|
|
(send definitions-item set-label
|
|
(if definitions-shown?
|
|
(string-constant hide-definitions-menu-item-label)
|
|
(string-constant show-definitions-menu-item-label)))
|
|
(send interactions-item set-label
|
|
(if interactions-shown?
|
|
(string-constant hide-interactions-menu-item-label)
|
|
(string-constant show-interactions-menu-item-label)))
|
|
|
|
(send resizable-panel begin-container-sequence)
|
|
|
|
;; this might change the unit-window-size-percentage, so save/restore it
|
|
(send resizable-panel change-children (λ (l) new-children))
|
|
|
|
(preferences:set 'drscheme:unit-window-size-percentage p)
|
|
|
|
;; restore preferred interactions/definitions sizes
|
|
(when (and (= 1 (length definitions-canvases))
|
|
(= 1 (length interactions-canvases))
|
|
(= 2 (length new-children)))
|
|
(with-handlers ([exn:fail? (λ (x) (void))])
|
|
(send resizable-panel set-percentages
|
|
(list p (- 1 p))))))
|
|
|
|
(send resizable-panel end-container-sequence)
|
|
|
|
(when (ormap (λ (child)
|
|
(and (is-a? child editor-canvas%)
|
|
(not (send child has-focus?))))
|
|
(send resizable-panel get-children))
|
|
(let loop ([children (send resizable-panel get-children)])
|
|
(cond
|
|
[(null? children) (void)]
|
|
[else (let ([child (car children)])
|
|
(if (is-a? child editor-canvas%)
|
|
(send child focus)
|
|
(loop (cdr children))))])))
|
|
|
|
|
|
(for-each
|
|
(λ (get-item)
|
|
(let ([item (get-item)])
|
|
(when item
|
|
(send item enable definitions-shown?))))
|
|
(list (λ () (file-menu:get-revert-item))
|
|
(λ () (file-menu:get-save-item))
|
|
(λ () (file-menu:get-save-as-item))
|
|
;(λ () (file-menu:save-as-text-item)) ; Save As Text...
|
|
(λ () (file-menu:get-print-item))))
|
|
(send file-menu:print-transcript-item enable interactions-shown?))
|
|
|
|
(define/augment (can-close?)
|
|
(and (andmap (lambda (tab)
|
|
(or (eq? tab current-tab)
|
|
(and (send (send tab get-defs) can-close?)
|
|
(send (send tab get-ints) can-close?))))
|
|
tabs)
|
|
(send interactions-text can-close?)
|
|
(inner #t can-close?)))
|
|
(define/augment (on-close)
|
|
(inner (void) on-close)
|
|
(for-each (lambda (tab)
|
|
(unless (eq? tab current-tab)
|
|
(send (send tab get-defs) on-close)
|
|
(send (send tab get-ints) on-close)))
|
|
tabs)
|
|
(when (eq? this newest-frame)
|
|
(set! newest-frame #f))
|
|
(when logging
|
|
(stop-logging))
|
|
(remove-show-status-line-callback)
|
|
(send interactions-text on-close))
|
|
|
|
;; execute-callback : -> void
|
|
;; uses the state of the button to determine if an execution is
|
|
;; already running. This function is called from many places, not
|
|
;; just the execute button.
|
|
(define/public (execute-callback)
|
|
(when (send execute-button is-enabled?)
|
|
(check-if-save-file-up-to-date)
|
|
(when (preferences:get 'drscheme:show-interactions-on-execute)
|
|
(ensure-rep-shown interactions-text))
|
|
(when logging
|
|
(log-definitions)
|
|
(log-interactions))
|
|
(send definitions-text just-executed)
|
|
(send language-message set-yellow #f)
|
|
(send interactions-canvas focus)
|
|
(send interactions-text reset-console)
|
|
(send interactions-text clear-undos)
|
|
(let ([start 0])
|
|
(send definitions-text split-snip start)
|
|
(let ([text-port (open-input-text-editor definitions-text start)])
|
|
(port-count-lines! text-port)
|
|
(let* ([line (send definitions-text position-paragraph start)]
|
|
[column (- start (send definitions-text paragraph-start-position line))]
|
|
[relocated-port (relocate-input-port text-port
|
|
(+ line 1)
|
|
column
|
|
(+ start 1))])
|
|
(port-count-lines! relocated-port)
|
|
(send interactions-text evaluate-from-port
|
|
relocated-port
|
|
#t
|
|
(λ ()
|
|
(send interactions-text clear-undos))))))))
|
|
|
|
(inherit revert save)
|
|
(define/private (check-if-save-file-up-to-date)
|
|
(when (send definitions-text save-file-out-of-date?)
|
|
(let ([user-choice
|
|
(message-box/custom
|
|
(string-constant drscheme)
|
|
(string-constant definitions-modified)
|
|
(string-constant ignore)
|
|
(string-constant revert)
|
|
#f
|
|
this
|
|
'(caution default=2 number-order)
|
|
1)])
|
|
(case user-choice
|
|
[(1) (void)]
|
|
[(2) (revert)]))))
|
|
|
|
(inherit get-menu-bar get-focus-object get-edit-target-object)
|
|
|
|
(inherit is-maximized?)
|
|
(define/override (on-size w h)
|
|
(preferences:set 'drscheme:unit-window-width w)
|
|
(preferences:set 'drscheme:unit-window-height h)
|
|
(preferences:set 'drscheme:unit-window-max? (is-maximized?))
|
|
(super on-size w h))
|
|
|
|
(define on-move-timer-args #f)
|
|
(define on-move-timer #f)
|
|
(define/override (on-move x y)
|
|
(cond
|
|
[on-move-timer
|
|
(set! on-move-timer-args (cons x y))]
|
|
[else
|
|
(set! on-move-timer-args (cons x y))
|
|
(set! on-move-timer
|
|
(new timer%
|
|
[notify-callback
|
|
(λ ()
|
|
(set! on-move-timer #f)
|
|
(set! on-move-timer-args #f)
|
|
(preferences:set 'drscheme:frame:initial-position on-move-timer-args))]
|
|
[interval 1000]
|
|
[just-once? #t]))]))
|
|
|
|
(define/override (get-editor) definitions-text)
|
|
(define/override (get-canvas)
|
|
(initialize-definitions-canvas)
|
|
definitions-canvas)
|
|
(define/private (initialize-definitions-canvas)
|
|
(unless definitions-canvas
|
|
(set! definitions-canvas
|
|
(new (drscheme:get/extend:get-definitions-canvas)
|
|
(parent resizable-panel)
|
|
(editor definitions-text)))))
|
|
|
|
(define/override (get-delegated-text) definitions-text)
|
|
(define/override (get-open-here-editor) definitions-text)
|
|
|
|
;; wire the definitions text to the interactions text and initialize it.
|
|
(define/private (init-definitions-text tab)
|
|
(let ([defs (send tab get-defs)]
|
|
[ints (send tab get-ints)])
|
|
(send defs set-interactions-text ints)
|
|
(send defs set-tab tab)
|
|
(send ints set-definitions-text defs)
|
|
(send defs change-mode-to-match)))
|
|
|
|
|
|
;
|
|
;
|
|
; @@
|
|
; @ @
|
|
; @@@@@ $@$: @-@$ :@@+@
|
|
; @ -@ @+ *$ @$ -@
|
|
; @ -$@$@ @ @ :@@$-
|
|
; @ $* @ @ @ *@
|
|
; @: :$ @- *@ @ +$ @ :@
|
|
; :@@$- -$$-@@@@+@$ $+@@:
|
|
;
|
|
;
|
|
;
|
|
;
|
|
|
|
(define/public (get-current-tab) current-tab)
|
|
|
|
;; create-new-tab : -> void
|
|
;; creates a new tab and updates the GUI for that new tab
|
|
(define/private create-new-tab
|
|
(opt-lambda ([filename #f])
|
|
(let* ([defs (new (drscheme:get/extend:get-definitions-text))]
|
|
[tab-count (length tabs)]
|
|
[new-tab (new (drscheme:get/extend:get-tab)
|
|
(defs defs)
|
|
(i tab-count)
|
|
(frame this)
|
|
(defs-shown? #t)
|
|
(ints-shown? (not filename)))]
|
|
[ints (make-object (drscheme:get/extend:get-interactions-text) new-tab)])
|
|
(send new-tab set-ints ints)
|
|
(set! tabs (append tabs (list new-tab)))
|
|
(send tabs-panel append (if filename
|
|
(get-tab-label-from-filename filename)
|
|
(get-defs-tab-label defs #f)))
|
|
(init-definitions-text new-tab)
|
|
(when filename (send defs load-file filename))
|
|
(change-to-nth-tab (- (send tabs-panel get-number) 1))
|
|
(send ints initialize-console)
|
|
(send tabs-panel set-selection (- (send tabs-panel get-number) 1))
|
|
(set! newest-frame this)
|
|
(update-menu-bindings))))
|
|
|
|
;; change-to-tab : tab -> void
|
|
;; updates current-tab, definitions-text, and interactactions-text
|
|
;; to be the nth tab. Also updates the GUI to show the new tab
|
|
(inherit begin-container-sequence end-container-sequence)
|
|
(define/private (change-to-tab tab)
|
|
(let ([old-delegate (send definitions-text get-delegate)]
|
|
[old-tab current-tab])
|
|
(save-visible-tab-regions)
|
|
(set! current-tab tab)
|
|
(set! definitions-text (send current-tab get-defs))
|
|
(set! interactions-text (send current-tab get-ints))
|
|
|
|
|
|
(begin-container-sequence)
|
|
(for-each (λ (defs-canvas) (send defs-canvas set-editor definitions-text))
|
|
definitions-canvases)
|
|
(for-each (λ (ints-canvas) (send ints-canvas set-editor interactions-text))
|
|
interactions-canvases)
|
|
|
|
(update-save-message)
|
|
(update-save-button)
|
|
(language-changed)
|
|
|
|
(send definitions-text update-frame-filename)
|
|
(send definitions-text set-delegate old-delegate)
|
|
(update-running (send current-tab is-running?))
|
|
(on-tab-change old-tab current-tab)
|
|
(end-container-sequence)
|
|
;; restore-visible-tab-regions has to be outside the container sequence
|
|
;; or else things get moved again during the container sequence end
|
|
(restore-visible-tab-regions)))
|
|
|
|
(define/pubment (on-tab-change from-tab to-tab)
|
|
(let ([old-enabled (send from-tab get-enabled)]
|
|
[new-enabled (send to-tab get-enabled)])
|
|
(unless (eq? old-enabled new-enabled)
|
|
(if new-enabled
|
|
(enable-evaluation)
|
|
(disable-evaluation))))
|
|
|
|
(let ([from-defs (send from-tab get-defs)]
|
|
[to-defs (send to-tab get-defs)])
|
|
(let ([delegate (send from-defs get-delegate)])
|
|
(send from-defs set-delegate #f)
|
|
(send to-defs set-delegate delegate)))
|
|
|
|
(inner (void) on-tab-change from-tab to-tab))
|
|
|
|
(define/public (next-tab) (change-to-delta-tab +1))
|
|
(define/public (prev-tab) (change-to-delta-tab -1))
|
|
|
|
(define/private (change-to-delta-tab dt)
|
|
(change-to-nth-tab (modulo (+ (send current-tab get-i) dt) (length tabs))))
|
|
|
|
(define/private (close-current-tab)
|
|
(cond
|
|
[(null? tabs) (void)]
|
|
[(null? (cdr tabs)) (void)]
|
|
[else
|
|
(let loop ([l-tabs tabs])
|
|
(cond
|
|
[(null? l-tabs) (error 'close-current-tab "uh oh.3")]
|
|
[else
|
|
(let ([tab (car l-tabs)])
|
|
(if (eq? tab current-tab)
|
|
(when (close-tab tab)
|
|
(for-each (lambda (t) (send t set-i (- (send t get-i) 1)))
|
|
(cdr l-tabs))
|
|
(set! tabs (remq tab tabs))
|
|
(send tabs-panel delete (send tab get-i))
|
|
(update-menu-bindings)
|
|
(change-to-tab (cond
|
|
[(< (send tab get-i) (length tabs))
|
|
(list-ref tabs (send tab get-i))]
|
|
[else (car (last-pair tabs))])))
|
|
(loop (cdr l-tabs))))]))]))
|
|
|
|
(define/private (close-tab tab)
|
|
(cond
|
|
[(send tab can-close?)
|
|
(send tab on-close)
|
|
#t]
|
|
[else #f]))
|
|
|
|
(define/public (open-in-new-tab filename)
|
|
(create-new-tab filename))
|
|
|
|
(define/private (change-to-nth-tab n)
|
|
(unless (< n (length tabs))
|
|
(error 'change-to-nth-tab "number too big ~s" n))
|
|
(change-to-tab (list-ref tabs n)))
|
|
|
|
(define/private (save-visible-tab-regions)
|
|
(send current-tab set-visible-ints
|
|
(get-tab-visible-regions interactions-text)
|
|
interactions-shown?)
|
|
(send current-tab set-visible-defs
|
|
(get-tab-visible-regions definitions-text)
|
|
definitions-shown?)
|
|
(send current-tab set-focus-d/i
|
|
(if (ormap (λ (x) (send x has-focus?)) interactions-canvases)
|
|
'ints
|
|
'defs)))
|
|
|
|
(define/private (get-tab-visible-regions txt)
|
|
(map (λ (canvas)
|
|
(let-values ([(x y w h _) (get-visible-region canvas)])
|
|
(list x y w h)))
|
|
(send txt get-canvases)))
|
|
|
|
(define/private (restore-visible-tab-regions)
|
|
(define (set-visible-regions txt regions ints?)
|
|
(when regions
|
|
(let* ([canvases (send txt get-canvases)]
|
|
[canvases-count (length canvases)]
|
|
[regions-count (length regions)])
|
|
(cond
|
|
[(> canvases-count regions-count)
|
|
(let loop ([i (- canvases-count regions-count)]
|
|
[canvases canvases])
|
|
(unless (zero? i)
|
|
(if ints?
|
|
(collapse-interactions (car canvases))
|
|
(collapse-definitions (car canvases)))
|
|
(loop (- i 1)
|
|
(cdr canvases))))]
|
|
[(= canvases-count regions-count)
|
|
(void)]
|
|
[(< canvases-count regions-count)
|
|
(let loop ([i (- regions-count canvases-count)]
|
|
[canvases canvases])
|
|
(unless (zero? i)
|
|
(if ints?
|
|
(split-interactions (car canvases))
|
|
(split-definitions (car canvases)))
|
|
(loop (- i 1)
|
|
(cdr canvases))))]))
|
|
(for-each (λ (c r)
|
|
(set-visible-tab-region txt c r))
|
|
(send txt get-canvases)
|
|
regions)))
|
|
(define (set-visible-tab-region txt canvas region)
|
|
(let ([admin (send txt get-admin)])
|
|
(send admin scroll-to
|
|
(first region)
|
|
(second region)
|
|
(third region)
|
|
(fourth region))))
|
|
(let-values ([(vi is?) (send current-tab get-visible-ints)]
|
|
[(vd ds?) (send current-tab get-visible-defs)])
|
|
(set! interactions-shown? is?)
|
|
(set! definitions-shown? ds?)
|
|
(update-shown)
|
|
(set-visible-regions definitions-text vd #f)
|
|
(set-visible-regions interactions-text vi #t))
|
|
(case (send current-tab get-focus-d/i)
|
|
[(defs) (send (car definitions-canvases) focus)]
|
|
[(ints) (send (car interactions-canvases) focus)]))
|
|
|
|
(define/private (pathname-equal? p1 p2)
|
|
(with-handlers ([exn:fail:filesystem? (λ (x) #f)])
|
|
(string=? (path->string (normal-case-path (normalize-path p1)))
|
|
(path->string (normal-case-path (normalize-path p2))))))
|
|
(define/override (make-visible filename)
|
|
(let loop ([tabs tabs])
|
|
(unless (null? tabs)
|
|
(let* ([tab (car tabs)]
|
|
[tab-filename (send (send tab get-defs) get-filename)])
|
|
(if (and tab-filename
|
|
(pathname-equal? filename tab-filename))
|
|
(change-to-tab tab)
|
|
(loop (cdr tabs)))))))
|
|
|
|
(define/override (editing-this-file? filename)
|
|
(ormap (λ (tab)
|
|
(let ([fn (send (send tab get-defs) get-filename)])
|
|
(and fn
|
|
(pathname-equal? fn filename))))
|
|
tabs))
|
|
|
|
(define/override (get-menu-item%)
|
|
(class (super get-menu-item%)
|
|
(inherit get-label get-plain-label)
|
|
(define/override (restore-keybinding)
|
|
(cond
|
|
[(equal? (get-plain-label) (string-constant close))
|
|
(update-close-menu-item-shortcut this)]
|
|
[(equal? (get-plain-label) (string-constant close-tab))
|
|
(update-close-tab-menu-item-shortcut this)]
|
|
[else (super restore-keybinding)]))
|
|
(super-new)))
|
|
|
|
(define/private (update-menu-bindings)
|
|
(when (preferences:get 'framework:menu-bindings)
|
|
(when close-tab-menu-item
|
|
(update-close-tab-menu-item-shortcut close-tab-menu-item))
|
|
(update-close-menu-item-shortcut (file-menu:get-close-item))))
|
|
|
|
(define/private (update-close-tab-menu-item-shortcut item)
|
|
(let ([just-one? (and (pair? tabs) (null? (cdr tabs)))])
|
|
(send item set-label (if just-one?
|
|
(string-constant close-tab)
|
|
(string-constant close-tab-amp)))
|
|
(send item set-shortcut (if just-one? #f #\w))))
|
|
|
|
(define/private (update-close-menu-item-shortcut item)
|
|
(let ([just-one? (and (pair? tabs) (null? (cdr tabs)))])
|
|
(send item set-label (if just-one?
|
|
(string-constant close-menu-item)
|
|
(string-constant close)))
|
|
(send item set-shortcut (if just-one? #\w #f))))
|
|
|
|
|
|
;;
|
|
;; end tabs
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define/public (get-definitions-text) definitions-text)
|
|
(define/public (get-interactions-text) interactions-text)
|
|
|
|
(define/public (get-definitions/interactions-panel-parent)
|
|
(get-area-container))
|
|
|
|
(inherit delegated-text-shown? hide-delegated-text show-delegated-text)
|
|
(define/override (add-show-menu-items show-menu)
|
|
(super add-show-menu-items show-menu)
|
|
(set! definitions-item
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant hide-definitions-menu-item-label)
|
|
(get-show-menu)
|
|
(λ (_1 _2)
|
|
(toggle-show/hide-definitions)
|
|
(update-shown))
|
|
#\d
|
|
(string-constant definitions-menu-item-help-string)))
|
|
(set! interactions-item
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant show-interactions-menu-item-label)
|
|
(get-show-menu)
|
|
(λ (_1 _2)
|
|
(toggle-show/hide-interactions)
|
|
(update-shown))
|
|
#\e
|
|
(string-constant interactions-menu-item-help-string)))
|
|
|
|
(new menu:can-restore-menu-item%
|
|
(shortcut #\u)
|
|
(label
|
|
(if (delegated-text-shown?)
|
|
(string-constant hide-overview)
|
|
(string-constant show-overview)))
|
|
(parent (get-show-menu))
|
|
(callback
|
|
(λ (menu evt)
|
|
(if (delegated-text-shown?)
|
|
(begin
|
|
(send menu set-label (string-constant show-overview))
|
|
(preferences:set 'framework:show-delegate? #f)
|
|
(hide-delegated-text))
|
|
(begin
|
|
(send menu set-label (string-constant hide-overview))
|
|
(preferences:set 'framework:show-delegate? #t)
|
|
(show-delegated-text))))))
|
|
|
|
(set! module-browser-menu-item
|
|
(new menu:can-restore-menu-item%
|
|
(label (if module-browser-shown?
|
|
(string-constant hide-module-browser)
|
|
(string-constant show-module-browser)))
|
|
(parent (get-show-menu))
|
|
(callback
|
|
(λ (menu evt)
|
|
(if module-browser-shown?
|
|
(hide-module-browser)
|
|
(show-module-browser))))))
|
|
|
|
(set! toolbar-menu-item
|
|
(new menu-item%
|
|
(label (string-constant show-toolbar))
|
|
(parent show-menu)
|
|
(callback
|
|
(λ (x y)
|
|
(toggle-toolbar-visiblity))))))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ; ;
|
|
; ; ; ;
|
|
; ; ; ;
|
|
; ; ;; ;; ;;; ;; ; ; ; ; ;;; ; ;; ; ; ;;; ; ; ; ;;; ;;; ; ;
|
|
; ;; ;; ; ; ; ; ;; ; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ; ;; ;;;;;; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ;; ; ;; ; ; ;; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ;;; ;; ; ;; ; ; ;;;; ; ;; ; ;;; ; ; ;;; ;;;; ;
|
|
;
|
|
;
|
|
;
|
|
|
|
|
|
(field [module-browser-shown? #f]
|
|
[module-browser-parent-panel #f]
|
|
[module-browser-panel #f]
|
|
[module-browser-ec #f]
|
|
[module-browser-button #f]
|
|
[module-browser-lib-path-check-box #f]
|
|
[module-browser-planet-path-check-box #f]
|
|
[module-browser-name-length-choice #f]
|
|
[module-browser-pb #f]
|
|
[module-browser-menu-item 'module-browser-menu-item-unset])
|
|
|
|
(inherit open-status-line close-status-line update-status-line)
|
|
|
|
(define/private (show-module-browser)
|
|
(when module-browser-panel
|
|
(when (can-browse-language?)
|
|
(set! module-browser-shown? #t)
|
|
(send module-browser-menu-item set-label (string-constant hide-module-browser))
|
|
(update-module-browser-pane))))
|
|
|
|
(define/private (hide-module-browser)
|
|
(when module-browser-panel
|
|
(set! module-browser-shown? #f)
|
|
(send module-browser-menu-item set-label (string-constant show-module-browser))
|
|
(close-status-line 'plt:module-browser:mouse-over)
|
|
(send module-browser-parent-panel change-children
|
|
(λ (l)
|
|
(remq module-browser-panel l)))))
|
|
|
|
(define/private (can-browse-language?)
|
|
(let* ([lang/config (preferences:get (drscheme:language-configuration:get-settings-preferences-symbol))]
|
|
[lang (drscheme:language-configuration:language-settings-language lang/config)]
|
|
[strs (send lang get-language-position)]
|
|
[can-browse?
|
|
(or (regexp-match #rx"module" (car (last-pair strs)))
|
|
(ormap (λ (x) (regexp-match #rx"PLT" x))
|
|
strs))])
|
|
(unless can-browse?
|
|
(message-box (string-constant drscheme)
|
|
(string-constant module-browser-only-in-plt-and-module-langs)))
|
|
can-browse?))
|
|
|
|
(define/private (update-module-browser-pane)
|
|
(open-status-line 'plt:module-browser:mouse-over)
|
|
(send module-browser-panel begin-container-sequence)
|
|
(unless module-browser-ec
|
|
(set! module-browser-pb
|
|
(drscheme:module-overview:make-module-overview-pasteboard
|
|
#t
|
|
(λ (x) (mouse-currently-over x))))
|
|
(set! module-browser-ec (make-object editor-canvas%
|
|
module-browser-panel
|
|
module-browser-pb))
|
|
|
|
(let* ([show-callback
|
|
(λ (cb key)
|
|
(if (send cb get-value)
|
|
(send module-browser-pb show-visible-paths key)
|
|
(send module-browser-pb remove-visible-paths key))
|
|
(preferences:set 'drscheme:module-browser:hide-paths (send module-browser-pb get-hidden-paths)))]
|
|
[mk-checkbox
|
|
(λ (key label)
|
|
(new check-box%
|
|
(parent module-browser-panel)
|
|
(label label)
|
|
(value (not (memq key (preferences:get 'drscheme:module-browser:hide-paths))))
|
|
(callback
|
|
(λ (cb _)
|
|
(show-callback cb key)))))])
|
|
(set! module-browser-lib-path-check-box (mk-checkbox 'lib show-lib-paths))
|
|
(set! module-browser-planet-path-check-box (mk-checkbox 'planet show-planet-paths)))
|
|
|
|
(set! module-browser-name-length-choice
|
|
(new choice%
|
|
(parent module-browser-panel)
|
|
(label (string-constant module-browser-name-length))
|
|
(choices (list (string-constant module-browser-name-short)
|
|
(string-constant module-browser-name-medium)
|
|
(string-constant module-browser-name-long)))
|
|
(selection (preferences:get 'drscheme:module-browser:name-length))
|
|
(callback
|
|
(λ (x y)
|
|
(let ([selection (send module-browser-name-length-choice get-selection)])
|
|
(preferences:set 'drscheme:module-browser:name-length selection)
|
|
(update-module-browser-name-length selection))))))
|
|
(update-module-browser-name-length
|
|
(preferences:get 'drscheme:module-browser:name-length))
|
|
|
|
(set! module-browser-button
|
|
(new button%
|
|
(parent module-browser-panel)
|
|
(label refresh)
|
|
(callback (λ (x y) (update-module-browser-pane)))
|
|
(stretchable-width #t))))
|
|
|
|
(let ([p (preferences:get 'drscheme:module-browser-size-percentage)])
|
|
(send module-browser-parent-panel change-children
|
|
(λ (l)
|
|
(cons module-browser-panel
|
|
(remq module-browser-panel l))))
|
|
(with-handlers ([exn:fail? void])
|
|
(send module-browser-parent-panel set-percentages (list p (- 1 p))))
|
|
(send module-browser-parent-panel end-container-sequence)
|
|
(calculate-module-browser)))
|
|
|
|
(define/private (update-module-browser-name-length i)
|
|
(send module-browser-pb set-name-length
|
|
(case i
|
|
[(0) 'short]
|
|
[(1) 'medium]
|
|
[(2) 'long])))
|
|
|
|
(define/private (mouse-currently-over snips)
|
|
(if (null? snips)
|
|
(update-status-line 'plt:module-browser:mouse-over #f)
|
|
(let* ([snip (car snips)]
|
|
[lines (send snip get-lines)]
|
|
[name (or (send snip get-filename)
|
|
(send snip get-word))]
|
|
[str (if lines
|
|
(format (string-constant module-browser-filename-format) name lines)
|
|
name)])
|
|
(update-status-line 'plt:module-browser:mouse-over str))))
|
|
|
|
(define/private (calculate-module-browser)
|
|
(let ([mod-tab current-tab])
|
|
(let-values ([(old-break-thread old-custodian) (send mod-tab get-breakables)])
|
|
(open-status-line 'plt:module-browser)
|
|
(update-status-line 'plt:module-browser status-compiling-definitions)
|
|
(send module-browser-button enable #f)
|
|
(send module-browser-lib-path-check-box enable #f)
|
|
(send module-browser-planet-path-check-box enable #f)
|
|
(send module-browser-name-length-choice enable #f)
|
|
(disable-evaluation-in-tab current-tab)
|
|
(drscheme:module-overview:fill-pasteboard
|
|
module-browser-pb
|
|
(drscheme:language:make-text/pos
|
|
definitions-text
|
|
0
|
|
(send definitions-text last-position))
|
|
(λ (str) (update-status-line
|
|
'plt:module-browser
|
|
(format module-browser-progress-constant str)))
|
|
(λ (user-thread user-custodian)
|
|
(send mod-tab set-breakables user-thread user-custodian)))
|
|
(send mod-tab set-breakables old-break-thread old-custodian)
|
|
(send mod-tab enable-evaluation)
|
|
(send module-browser-button enable #t)
|
|
(send module-browser-lib-path-check-box enable #t)
|
|
(send module-browser-planet-path-check-box enable #t)
|
|
(send module-browser-name-length-choice enable #t)
|
|
(close-status-line 'plt:module-browser))))
|
|
|
|
;; set-directory : text -> void
|
|
;; sets the current-directory and current-load-relative-directory
|
|
;; based on the file saved in the definitions-text
|
|
(define/private (set-directory definitions-text)
|
|
(let* ([tmp-b (box #f)]
|
|
[fn (send definitions-text get-filename tmp-b)])
|
|
(unless (unbox tmp-b)
|
|
(when fn
|
|
(let-values ([(base name dir?) (split-path fn)])
|
|
(current-directory base)
|
|
(current-load-relative-directory base))))))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; ; ;; ;; ;;; ; ;; ; ; ;;;
|
|
; ;; ;; ; ; ; ;; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ;;
|
|
; ; ; ; ;;;;;; ; ; ; ; ;;
|
|
; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ;; ;
|
|
; ; ; ; ;;;; ; ; ;; ; ;;;
|
|
;
|
|
;
|
|
;
|
|
|
|
(define execute-menu-item #f)
|
|
(define file-menu:print-transcript-item #f)
|
|
(define file-menu:create-new-tab-item #f)
|
|
|
|
(define/override (file-menu:between-new-and-open file-menu)
|
|
(set! file-menu:create-new-tab-item
|
|
(new menu:can-restore-menu-item%
|
|
(label (string-constant new-tab))
|
|
(shortcut #\=)
|
|
(parent file-menu)
|
|
(callback
|
|
(λ (x y)
|
|
(create-new-tab))))))
|
|
[define/override file-menu:between-open-and-revert
|
|
(lambda (file-menu)
|
|
(super file-menu:between-open-and-revert file-menu)
|
|
(make-object separator-menu-item% file-menu))]
|
|
(define close-tab-menu-item #f)
|
|
(define/override (file-menu:between-close-and-quit file-menu)
|
|
(set! close-tab-menu-item
|
|
(new (get-menu-item%)
|
|
(label (string-constant close-tab))
|
|
(demand-callback
|
|
(λ (item)
|
|
(send item enable (1 . < . (send tabs-panel get-number)))))
|
|
(parent file-menu)
|
|
(callback
|
|
(λ (x y)
|
|
(close-current-tab)))))
|
|
(super file-menu:between-close-and-quit file-menu))
|
|
|
|
(define/override (file-menu:save-string) (string-constant save-definitions))
|
|
(define/override (file-menu:save-as-string) (string-constant save-definitions-as))
|
|
(define/override (file-menu:between-save-as-and-print file-menu)
|
|
(let ([sub-menu (make-object menu% (string-constant save-other) file-menu)])
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant save-definitions-as-text)
|
|
sub-menu
|
|
(λ (_1 _2)
|
|
(let ([filename (send definitions-text put-file #f #f)])
|
|
(when filename
|
|
(send definitions-text save-file/gui-error filename 'text)))))
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant save-interactions)
|
|
sub-menu
|
|
(λ (_1 _2)
|
|
(send interactions-text save-file/gui-error)))
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant save-interactions-as)
|
|
sub-menu
|
|
(λ (_1 _2)
|
|
(let ([filename (send interactions-text put-file #f #f)])
|
|
(when filename
|
|
(send interactions-text save-file/gui-error filename 'standard)))))
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant save-interactions-as-text)
|
|
sub-menu
|
|
(λ (_1 _2)
|
|
(let ([filename (send interactions-text put-file #f #f)])
|
|
(when filename
|
|
(send interactions-text save-file/gui-error filename 'text)))))
|
|
(make-object separator-menu-item% file-menu)
|
|
(set! logging-menu-item
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant log-definitions-and-interactions)
|
|
file-menu
|
|
(λ (x y)
|
|
(if logging
|
|
(stop-logging)
|
|
(start-logging)))))
|
|
(make-object separator-menu-item% file-menu)
|
|
(super file-menu:between-save-as-and-print file-menu)))
|
|
|
|
[define/override file-menu:print-string (λ () (string-constant print-definitions))]
|
|
(define/override (file-menu:between-print-and-close file-menu)
|
|
(set! file-menu:print-transcript-item
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant print-interactions)
|
|
file-menu
|
|
(λ (_1 _2)
|
|
(send interactions-text print
|
|
#t
|
|
#t
|
|
(preferences:get 'framework:print-output-mode)))))
|
|
(super file-menu:between-print-and-close file-menu))
|
|
|
|
(define/override (edit-menu:between-find-and-preferences edit-menu)
|
|
(new menu-item%
|
|
[label (string-constant complete-word)]
|
|
[shortcut #\/]
|
|
[parent edit-menu]
|
|
[demand-callback
|
|
(λ (mi)
|
|
(send mi enable
|
|
(let ([ed (get-edit-target-object)])
|
|
(and ed
|
|
(is-a? ed text:autocomplete<%>)))))]
|
|
[callback (λ (x y)
|
|
(send (get-edit-target-object) auto-complete))])
|
|
(super edit-menu:between-find-and-preferences edit-menu)
|
|
(add-modes-submenu edit-menu))
|
|
|
|
;; capability-menu-items : hash-table[menu -o> (listof (list menu-item number key)))
|
|
(define capability-menu-items (make-hash-table))
|
|
(define/public (register-capability-menu-item key menu)
|
|
(let ([items (send menu get-items)])
|
|
(when (null? items)
|
|
(error 'register-capability-menu-item "menu ~e has no items" menu))
|
|
(let* ([menu-item (car (last-pair items))]
|
|
[this-one (list menu-item (- (length items) 1) key)]
|
|
[old-ones (hash-table-get capability-menu-items menu (λ () '()))])
|
|
(hash-table-put! capability-menu-items menu (cons this-one old-ones)))))
|
|
|
|
(define/private (update-items/capability menu)
|
|
(let ([new-items (get-items/capability menu)])
|
|
(for-each (λ (i) (send i delete)) (send menu get-items))
|
|
(for-each (λ (i) (send i restore)) new-items)))
|
|
(define/private (get-items/capability menu)
|
|
(let loop ([capability-items
|
|
(reverse
|
|
(hash-table-get capability-menu-items menu (λ () '())))]
|
|
[all-items (send menu get-items)]
|
|
[i 0])
|
|
(cond
|
|
[(null? capability-items) all-items]
|
|
[else
|
|
(let* ([cap-item-list (car capability-items)]
|
|
[cap-item (list-ref cap-item-list 0)]
|
|
[cap-num (list-ref cap-item-list 1)]
|
|
[cap-key (list-ref cap-item-list 2)])
|
|
(cond
|
|
[(= cap-num i)
|
|
(let ([is-on? (get-current-capability-value cap-key)])
|
|
(cond
|
|
[is-on?
|
|
(cond
|
|
[(null? all-items)
|
|
(cons cap-item (loop (cdr capability-items) null (+ i 1)))]
|
|
[(eq? (car all-items) cap-item)
|
|
(cons cap-item (loop (cdr capability-items) (cdr all-items) (+ i 1)))]
|
|
[else
|
|
(cons cap-item (loop (cdr capability-items) all-items (+ i 1)))])]
|
|
[else
|
|
(cond
|
|
[(null? all-items)
|
|
(loop (cdr capability-items) null (+ i 1))]
|
|
[(eq? (car all-items) cap-item)
|
|
(loop (cdr capability-items) (cdr all-items) (+ i 1))]
|
|
[else
|
|
(loop (cdr capability-items) all-items (+ i 1))])]))]
|
|
[else (cons (car all-items)
|
|
(loop capability-items
|
|
(cdr all-items)
|
|
(+ i 1)))]))])))
|
|
|
|
(define/private (get-current-capability-value key)
|
|
(let* ([language-settings (send (get-definitions-text) get-next-settings)]
|
|
[new-language (drscheme:language-configuration:language-settings-language language-settings)])
|
|
(send new-language capability-value key)))
|
|
|
|
(define language-menu 'uninited-language-menu)
|
|
(define scheme-menu 'scheme-menu-not-yet-init)
|
|
(define special-menu 'special-menu-not-yet-init)
|
|
(define/public (get-special-menu) special-menu)
|
|
|
|
(define/public (choose-language-callback)
|
|
(let ([new-settings (drscheme:language-configuration:language-dialog
|
|
#f
|
|
(send definitions-text get-next-settings)
|
|
this)])
|
|
(when new-settings
|
|
(send definitions-text set-next-settings new-settings))))
|
|
|
|
;; must be called from on-demand (on each menu click), or the state won't be handled properly
|
|
(define/private (update-teachpack-menu)
|
|
(for-each (λ (item) (send item delete)) teachpack-items)
|
|
(let ([tp-callbacks (get-current-capability-value 'drscheme:teachpack-menu-items)])
|
|
(cond
|
|
[tp-callbacks
|
|
(let* ([language (drscheme:language-configuration:language-settings-language
|
|
(send (get-definitions-text) get-next-settings))]
|
|
[settings (drscheme:language-configuration:language-settings-settings
|
|
(send (get-definitions-text) get-next-settings))]
|
|
[tp-names ((teachpack-callbacks-get-names tp-callbacks) settings)]
|
|
[update-settings
|
|
(λ (settings)
|
|
(send (get-definitions-text) set-next-settings
|
|
(drscheme:language-configuration:make-language-settings language settings))
|
|
(send (get-definitions-text) teachpack-changed))])
|
|
(set! teachpack-items
|
|
(list*
|
|
(make-object separator-menu-item% language-menu)
|
|
(new menu:can-restore-menu-item%
|
|
[label (string-constant add-teachpack-menu-item-label)]
|
|
[parent language-menu]
|
|
[callback
|
|
(λ (_1 _2)
|
|
(update-settings ((teachpack-callbacks-add tp-callbacks) settings this)))])
|
|
(let ([mi (new menu:can-restore-menu-item%
|
|
[label (string-constant clear-all-teachpacks-menu-item-label)]
|
|
[parent language-menu]
|
|
[callback
|
|
(λ (_1 _2)
|
|
(update-settings ((teachpack-callbacks-remove-all tp-callbacks) settings)))])])
|
|
|
|
(send mi enable (not (null? tp-names)))
|
|
mi)
|
|
(map (λ (name)
|
|
(new menu:can-restore-menu-item%
|
|
[label (format (string-constant clear-teachpack) name)]
|
|
[parent language-menu]
|
|
[callback
|
|
(λ (item evt)
|
|
(update-settings ((teachpack-callbacks-remove tp-callbacks) settings name)))]))
|
|
tp-names))))]
|
|
[else
|
|
(set! teachpack-items
|
|
(list
|
|
(new menu:can-restore-menu-item%
|
|
[label (string-constant add-teachpack-menu-item-label)]
|
|
[parent language-menu]
|
|
[callback
|
|
(λ (_1 _2)
|
|
(message-box (string-constant drscheme)
|
|
(format (string-constant teachpacks-only-in-languages)
|
|
(apply
|
|
string-append
|
|
(reverse
|
|
(filter
|
|
values
|
|
(map (λ (l)
|
|
(and
|
|
(send l capability-value 'drscheme:teachpack-menu-items)
|
|
(format "\n ~a" (send l get-language-name))))
|
|
(drscheme:language-configuration:get-languages))))))
|
|
this))])))])))
|
|
|
|
(define/private (initialize-menus)
|
|
(let* ([mb (get-menu-bar)]
|
|
[language-menu-on-demand (λ (menu-item) (update-teachpack-menu))]
|
|
[_ (set! language-menu (make-object (get-menu%)
|
|
(string-constant language-menu-name)
|
|
mb
|
|
#f
|
|
language-menu-on-demand))]
|
|
[_ (set! scheme-menu (new (get-menu%)
|
|
[label (drscheme:language:get-capability-default
|
|
'drscheme:language-menu-title)]
|
|
[parent mb]))]
|
|
[send-method
|
|
(λ (method)
|
|
(λ (_1 _2)
|
|
(let ([text (get-focus-object)])
|
|
(when (is-a? text scheme:text<%>)
|
|
(method text)))))]
|
|
[show/hide-capability-menus
|
|
(λ ()
|
|
(for-each (λ (menu) (update-items/capability menu)) (send (get-menu-bar) get-items)))])
|
|
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant choose-language-menu-item-label)
|
|
language-menu
|
|
(λ (_1 _2) (choose-language-callback))
|
|
#\l)
|
|
|
|
(set! execute-menu-item
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant execute-menu-item-label)
|
|
scheme-menu
|
|
(λ (_1 _2) (execute-callback))
|
|
#\t
|
|
(string-constant execute-menu-item-help-string)))
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant break-menu-item-label)
|
|
scheme-menu
|
|
(λ (_1 _2) (send current-tab break-callback))
|
|
#\b
|
|
(string-constant break-menu-item-help-string))
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant kill-menu-item-label)
|
|
scheme-menu
|
|
(λ (_1 _2) (send interactions-text kill-evaluation))
|
|
#\k
|
|
(string-constant kill-menu-item-help-string))
|
|
(when (custodian-memory-accounting-available?)
|
|
(new menu-item%
|
|
[label (string-constant limit-memory-menu-item-label)]
|
|
[parent scheme-menu]
|
|
[callback
|
|
(λ (item b)
|
|
(let ([num (get-mbytes this
|
|
(let ([limit (send interactions-text get-custodian-limit)])
|
|
(and limit
|
|
(floor (/ limit 1024 1024)))))])
|
|
(when num
|
|
(cond
|
|
[(eq? num #t)
|
|
(preferences:set 'drscheme:limit-memory #f)
|
|
(send interactions-text set-custodian-limit #f)]
|
|
[else
|
|
(preferences:set 'drscheme:limit-memory
|
|
(* 1024 1024 num))
|
|
(send interactions-text set-custodian-limit
|
|
(* 1024 1024 num))]))))]))
|
|
(new menu:can-restore-menu-item%
|
|
(label (string-constant clear-error-highlight-menu-item-label))
|
|
(parent scheme-menu)
|
|
(callback
|
|
(λ (_1 _2)
|
|
(let ([ints (send (get-current-tab) get-ints)])
|
|
(send ints reset-error-ranges))))
|
|
(help-string (string-constant clear-error-highlight-item-help-string))
|
|
(demand-callback
|
|
(λ (item)
|
|
(let ([ints (send (get-current-tab) get-ints)])
|
|
(send item enable (send ints get-error-ranges))))))
|
|
(make-object separator-menu-item% scheme-menu)
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant create-executable-menu-item-label)
|
|
scheme-menu
|
|
(λ (x y) (create-executable this)))
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant module-browser...)
|
|
scheme-menu
|
|
(λ (x y) (drscheme:module-overview:module-overview this)))
|
|
(make-object separator-menu-item% scheme-menu)
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant reindent-menu-item-label)
|
|
scheme-menu
|
|
(send-method (λ (x) (send x tabify-selection))))
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant reindent-all-menu-item-label)
|
|
scheme-menu
|
|
(send-method (λ (x) (send x tabify-all)))
|
|
#\i)
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant box-comment-out-menu-item-label)
|
|
scheme-menu
|
|
(send-method (λ (x) (send x box-comment-out-selection))))
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant semicolon-comment-out-menu-item-label)
|
|
scheme-menu
|
|
(send-method (λ (x) (send x comment-out-selection))))
|
|
(make-object menu:can-restore-menu-item%
|
|
(string-constant uncomment-menu-item-label)
|
|
scheme-menu
|
|
(λ (x y)
|
|
(let ([text (get-focus-object)])
|
|
(when (is-a? text text%)
|
|
(let ([admin (send text get-admin)])
|
|
(cond
|
|
[(is-a? admin editor-snip-editor-admin<%>)
|
|
(let ([es (send admin get-snip)])
|
|
(cond
|
|
[(is-a? es comment-box:snip%)
|
|
(let ([es-admin (send es get-admin)])
|
|
(when es-admin
|
|
(let ([ed (send es-admin get-editor)])
|
|
(when (is-a? ed scheme:text<%>)
|
|
(send ed uncomment-box/selection)))))]
|
|
[else (send text uncomment-selection)]))]
|
|
[else (send text uncomment-selection)]))))))
|
|
|
|
(set! special-menu
|
|
(new (get-menu%)
|
|
[label (string-constant special-menu)]
|
|
[parent mb]
|
|
[demand-callback
|
|
(λ (special-menu)
|
|
;; just here for convience -- it actually works on all menus, not just the special menu
|
|
(show/hide-capability-menus))]))
|
|
|
|
(let ([has-editor-on-demand
|
|
(λ (menu-item)
|
|
(let ([edit (get-edit-target-object)])
|
|
(send menu-item enable (and edit (is-a? edit editor<%>)))))]
|
|
[callback
|
|
(λ (menu evt)
|
|
(let ([edit (get-edit-target-object)])
|
|
(when (and edit
|
|
(is-a? edit editor<%>))
|
|
(let ([number (get-fraction-from-user this)])
|
|
(when number
|
|
(send edit insert
|
|
(number-snip:make-fraction-snip number #f)))))
|
|
#t))]
|
|
[insert-lambda
|
|
(λ ()
|
|
(let ([edit (get-edit-target-object)])
|
|
(when (and edit
|
|
(is-a? edit editor<%>))
|
|
(send edit insert "\u03BB")))
|
|
#t)]
|
|
[insert-large-semicolon-letters
|
|
(λ ()
|
|
(let ([edit (get-edit-target-object)])
|
|
(when edit
|
|
(let ([str (get-text-from-user (string-constant large-semicolon-letters)
|
|
(string-constant text-to-insert)
|
|
this)])
|
|
(when (and str
|
|
(not (equal? str "")))
|
|
(let ()
|
|
(define language-settings (send definitions-text get-next-settings))
|
|
(define-values (comment-prefix comment-character)
|
|
(if language-settings
|
|
(send (drscheme:language-configuration:language-settings-language
|
|
language-settings)
|
|
get-comment-character)
|
|
(values ";" #\;)))
|
|
(define bdc (make-object bitmap-dc% (make-object bitmap% 1 1 #t)))
|
|
(define the-font (send (send (editor:get-standard-style-list)
|
|
find-named-style
|
|
"Standard")
|
|
get-font))
|
|
(define-values (tw th td ta) (send bdc get-text-extent str the-font))
|
|
(define tmp-color (make-object color%))
|
|
|
|
(define (get-char x y)
|
|
(send bdc get-pixel x y tmp-color)
|
|
(let ([red (send tmp-color red)])
|
|
(if (= red 0)
|
|
comment-character
|
|
#\space)))
|
|
(define bitmap
|
|
(make-object bitmap%
|
|
(inexact->exact tw)
|
|
(inexact->exact th)
|
|
#t))
|
|
|
|
(define (fetch-line y)
|
|
(let loop ([x (send bitmap get-width)]
|
|
[chars null])
|
|
(cond
|
|
[(zero? x) (apply string chars)]
|
|
[else (loop (- x 1) (cons (get-char (- x 1) y) chars))])))
|
|
|
|
(send bdc set-bitmap bitmap)
|
|
(send bdc clear)
|
|
(send bdc set-font the-font)
|
|
(send bdc draw-text str 0 0)
|
|
|
|
(send edit begin-edit-sequence)
|
|
(let ([start (send edit get-start-position)]
|
|
[end (send edit get-end-position)])
|
|
(send edit delete start end)
|
|
(send edit insert "\n" start start)
|
|
(let loop ([y (send bitmap get-height)])
|
|
(unless (zero? y)
|
|
(send edit insert (fetch-line (- y 1)) start start)
|
|
(send edit insert comment-prefix start start)
|
|
(send edit insert "\n" start start)
|
|
(loop (- y 1)))))
|
|
(send edit end-edit-sequence)))))))]
|
|
[c% (get-menu-item%)])
|
|
|
|
(frame:add-snip-menu-items
|
|
special-menu
|
|
c%
|
|
(λ (item)
|
|
(let ([label (send item get-label)])
|
|
(cond
|
|
[(equal? label (string-constant insert-comment-box-menu-item-label))
|
|
(register-capability-menu-item 'drscheme:special:insert-comment-box special-menu)]
|
|
[(equal? label (string-constant insert-image-item))
|
|
(register-capability-menu-item 'drscheme:special:insert-image special-menu)]))))
|
|
|
|
(make-object c% (string-constant insert-fraction-menu-item-label)
|
|
special-menu callback
|
|
#f #f
|
|
has-editor-on-demand)
|
|
(register-capability-menu-item 'drscheme:special:insert-fraction special-menu)
|
|
|
|
(make-object c% (string-constant insert-large-letters...)
|
|
special-menu
|
|
(λ (x y) (insert-large-semicolon-letters))
|
|
#f #f
|
|
has-editor-on-demand)
|
|
(register-capability-menu-item 'drscheme:special:insert-large-letters special-menu)
|
|
|
|
(make-object c% (string-constant insert-lambda)
|
|
special-menu
|
|
(λ (x y) (insert-lambda))
|
|
#\\
|
|
#f
|
|
has-editor-on-demand)
|
|
(register-capability-menu-item 'drscheme:special:insert-lambda special-menu))
|
|
|
|
(make-object separator-menu-item% (get-show-menu))
|
|
|
|
(new menu:can-restore-menu-item%
|
|
(shortcut (if (eq? (system-type) 'macosx) #f #\m))
|
|
(label (string-constant split-menu-item-label))
|
|
(parent (get-show-menu))
|
|
(callback (λ (x y) (split)))
|
|
(demand-callback (λ (item) (split-demand item))))
|
|
(new menu:can-restore-menu-item%
|
|
(shortcut #\r)
|
|
(label (string-constant collapse-menu-item-label))
|
|
(parent (get-show-menu))
|
|
(callback (λ (x y) (collapse)))
|
|
(demand-callback (λ (item) (collapse-demand item))))
|
|
|
|
(frame:reorder-menus this)))
|
|
|
|
;
|
|
;
|
|
;
|
|
;
|
|
; ++-@@- -+@+- +++: :++
|
|
; +@@-+@ -@-:-@--@- -@
|
|
; :@: @: @+ ++ @::@::@
|
|
; :@ @: @@@@@@@ +--@--*
|
|
; :@ @: @- -@+*+@:
|
|
; -@: :@- +@:::+@ :@@:@@
|
|
; @@@ +@@: +@@@+: ++ ++
|
|
;
|
|
;
|
|
;
|
|
|
|
(define definitions-text (new (drscheme:get/extend:get-definitions-text)))
|
|
|
|
;; tabs : (listof tab)
|
|
(define tabs (list (new (drscheme:get/extend:get-tab)
|
|
(defs definitions-text)
|
|
(frame this)
|
|
(i 0)
|
|
(defs-shown? #t)
|
|
(ints-shown? #t))))
|
|
(define/public-final (get-tabs) tabs)
|
|
|
|
;; current-tab : tab
|
|
;; corresponds to the tabs-panel's active button.
|
|
(define current-tab (car tabs))
|
|
|
|
(define interactions-text (new (drscheme:get/extend:get-interactions-text)
|
|
(context (car tabs))))
|
|
(send (car tabs) set-ints interactions-text)
|
|
|
|
(init-definitions-text (car tabs))
|
|
|
|
(super-new
|
|
(filename filename)
|
|
(style '(toolbar-button))
|
|
(width (preferences:get 'drscheme:unit-window-width))
|
|
(height (preferences:get 'drscheme:unit-window-height)))
|
|
|
|
(initialize-menus)
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ;
|
|
; ; ;
|
|
; ; ; ;
|
|
; ; ;; ;;; ; ;; ;;; ; ; ;;; ; ; ;;; ; ; ;;;;
|
|
; ;; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ;;;; ; ; ;;;;;; ; ; ;;;; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ;
|
|
; ; ;; ;;;;; ; ; ;;;; ; ; ;;;;; ; ;;; ;; ; ;;
|
|
; ; ;
|
|
; ; ;
|
|
; ; ;
|
|
|
|
|
|
;; most contain only top-panel (or nothing)
|
|
(define top-outer-panel (new horizontal-pane%
|
|
(parent (get-area-container))
|
|
(stretchable-height #f)))
|
|
|
|
[define top-panel (make-object horizontal-panel% top-outer-panel)]
|
|
[define name-panel (new vertical-pane%
|
|
(parent top-panel)
|
|
(alignment '(left center))
|
|
(stretchable-width #f)
|
|
(stretchable-height #f))]
|
|
(define panel-with-tabs (new vertical-panel%
|
|
(parent (get-definitions/interactions-panel-parent))))
|
|
(define tabs-panel (new tab-panel%
|
|
(font small-control-font)
|
|
(parent panel-with-tabs)
|
|
(stretchable-height #f)
|
|
(style '(deleted no-border))
|
|
(choices '("first name"))
|
|
(callback (λ (x y)
|
|
(let ([sel (send tabs-panel get-selection)])
|
|
(when sel
|
|
(change-to-nth-tab sel)))))))
|
|
[define resizable-panel (new (if (preferences:get 'drscheme:defs/ints-horizontal)
|
|
horizontal-dragable/def-int%
|
|
vertical-dragable/def-int%)
|
|
(unit-frame this)
|
|
(parent panel-with-tabs))]
|
|
|
|
[define definitions-canvas #f]
|
|
(initialize-definitions-canvas)
|
|
[define definitions-canvases (list definitions-canvas)]
|
|
[define interactions-canvas (new (drscheme:get/extend:get-interactions-canvas)
|
|
(parent resizable-panel)
|
|
(editor interactions-text))]
|
|
[define interactions-canvases (list interactions-canvas)]
|
|
|
|
|
|
(define/public (get-definitions-canvases)
|
|
;; before definition, just return null
|
|
(if (pair? definitions-canvases)
|
|
definitions-canvases
|
|
null))
|
|
(define/public (get-interactions-canvases)
|
|
;; before definition, just return null
|
|
(if (pair? interactions-canvases)
|
|
interactions-canvases
|
|
null))
|
|
|
|
(public get-definitions-canvas get-interactions-canvas)
|
|
[define get-definitions-canvas (λ () definitions-canvas)]
|
|
[define get-interactions-canvas (λ () interactions-canvas)]
|
|
|
|
(set! save-button
|
|
(make-object button%
|
|
(make-save-bitmap this)
|
|
top-panel
|
|
(λ args
|
|
(when definitions-text
|
|
(save)
|
|
(send definitions-canvas focus)))))
|
|
|
|
(set! name-message (new drs-name-message% [parent name-panel]))
|
|
[define teachpack-items null]
|
|
[define break-button (void)]
|
|
[define execute-button (void)]
|
|
[define button-panel (make-object horizontal-panel% top-panel)]
|
|
[define/public get-execute-button (λ () execute-button)]
|
|
[define/public get-break-button (λ () break-button)]
|
|
[define/public get-button-panel (λ () button-panel)]
|
|
|
|
(inherit get-info-panel)
|
|
(define running-canvas
|
|
(new running-canvas% [parent (get-info-panel)]))
|
|
|
|
|
|
[define func-defs-canvas (new func-defs-canvas%
|
|
(parent name-panel)
|
|
(frame this))]
|
|
|
|
(set! execute-button
|
|
(make-object button%
|
|
(make-execute-bitmap this)
|
|
button-panel
|
|
(λ (button evt) (execute-callback))))
|
|
(set! break-button
|
|
(make-object button%
|
|
(make-break-bitmap this)
|
|
button-panel
|
|
(λ (x y)
|
|
(send current-tab break-callback))))
|
|
|
|
(send button-panel stretchable-height #f)
|
|
(send button-panel stretchable-width #f)
|
|
|
|
(send top-panel change-children
|
|
(λ (l)
|
|
(list name-panel save-button
|
|
(make-object vertical-panel% top-panel) ;; spacer
|
|
button-panel)))
|
|
|
|
(send top-panel stretchable-height #f)
|
|
(inherit get-label)
|
|
(let ([m (send definitions-canvas get-editor)])
|
|
(set-save-init-shown?
|
|
(and m (send m is-modified?))))
|
|
|
|
(define language-message
|
|
(let* ([info-panel (get-info-panel)]
|
|
[vp (new vertical-panel%
|
|
[parent info-panel]
|
|
[alignment '(left center)]
|
|
[stretchable-width #t]
|
|
[stretchable-height #f])]
|
|
[l-m-label (new language-label-message% [parent vp] [frame this])]
|
|
[language-message (new language-message% [parent vp])])
|
|
(send info-panel change-children
|
|
(λ (l)
|
|
(list* vp
|
|
(remq* (list vp) l))))
|
|
language-message))
|
|
|
|
(update-save-message)
|
|
(update-save-button)
|
|
(language-changed)
|
|
|
|
(cond
|
|
[filename
|
|
(set! definitions-shown? #t)
|
|
(set! interactions-shown? #f)]
|
|
[else
|
|
(set! definitions-shown? #t)
|
|
(set! interactions-shown? #t)])
|
|
|
|
(update-shown)
|
|
|
|
(when (= 2 (length (send resizable-panel get-children)))
|
|
(send resizable-panel set-percentages
|
|
(let ([p (preferences:get 'drscheme:unit-window-size-percentage)])
|
|
(list p (- 1 p)))))
|
|
|
|
(set-label-prefix (string-constant drscheme))
|
|
(update-toolbar-visiblity)
|
|
(set! newest-frame this)
|
|
(send definitions-canvas focus)))
|
|
|
|
;; get-mbytes : top-level-window -> (union #f ;; cancel
|
|
;; integer[>=100] ;; a limit
|
|
;; #t) ;; no limit
|
|
(define (get-mbytes parent current-limit)
|
|
(define d (new dialog%
|
|
[label (string-constant drscheme)]
|
|
[parent parent]))
|
|
(define msg1 (new message%
|
|
[parent d]
|
|
[label (string-constant limit-memory-msg-1)]))
|
|
(define msg1.5 (new message%
|
|
[parent d]
|
|
[label (string-constant limit-memory-msg-2)]))
|
|
|
|
(define outer-hp (new horizontal-panel% [parent d] [alignment '(center bottom)]))
|
|
(define rb (new radio-box%
|
|
[label #f]
|
|
[choices (list (string-constant limit-memory-unlimited) (string-constant limit-memory-limited))]
|
|
[callback (λ (a b) (grayizie))]
|
|
[parent outer-hp]))
|
|
|
|
(define (grayizie)
|
|
(case (send rb get-selection)
|
|
[(0)
|
|
(send tb enable #f)
|
|
(send msg2 enable #f)
|
|
(background gray-foreground-sd)]
|
|
[(1)
|
|
(send tb enable #t)
|
|
(send msg2 enable #t)
|
|
(background black-foreground-sd)
|
|
(let ([e (send tb get-editor)])
|
|
(send e set-position 0 (send e last-position)))
|
|
(send tb focus)])
|
|
(update-ok-button-state))
|
|
|
|
(define hp (new horizontal-panel%
|
|
[parent outer-hp]
|
|
[stretchable-height #f]
|
|
[stretchable-width #f]))
|
|
|
|
(define tb
|
|
(new text-field%
|
|
[label #f]
|
|
[parent hp]
|
|
[init-value (if current-limit
|
|
(format "~a" current-limit)
|
|
"128")]
|
|
[stretchable-width #f]
|
|
[min-width 100]
|
|
[callback
|
|
(λ (tf e)
|
|
(let ([ed (send tf get-editor)])
|
|
(cond
|
|
[(is-valid-number? ed)
|
|
(background clear-sd)]
|
|
[else
|
|
(background yellow-sd)]))
|
|
(update-ok-button-state))]))
|
|
|
|
(define (update-ok-button-state)
|
|
(case (send rb get-selection)
|
|
[(0) (send ok-button enable #t)]
|
|
[(1) (send ok-button enable (is-valid-number? (send tb get-editor)))]))
|
|
|
|
(define msg2 (new message% [parent hp] [label (string-constant limit-memory-megabytes)]))
|
|
(define bp (new horizontal-panel% [parent d]))
|
|
(define-values (ok-button cancel-button)
|
|
(gui-utils:ok/cancel-buttons
|
|
bp
|
|
(λ (a b)
|
|
(case (send rb get-selection)
|
|
[(0) (set! result #t)]
|
|
[(1) (set! result (string->number (send (send tb get-editor) get-text)))])
|
|
(send d show #f))
|
|
(λ (a b) (send d show #f))))
|
|
|
|
(define result #f)
|
|
|
|
(define clear-sd (make-object style-delta%))
|
|
(define yellow-sd (make-object style-delta%))
|
|
|
|
(define black-foreground-sd (make-object style-delta%))
|
|
(define gray-foreground-sd (make-object style-delta%))
|
|
|
|
(define (is-valid-number? txt)
|
|
(let* ([n (string->number (send txt get-text))])
|
|
(and n
|
|
(integer? n)
|
|
(100 . <= . n))))
|
|
|
|
(define (background sd)
|
|
(let ([txt (send tb get-editor)])
|
|
(send txt change-style sd 0 (send txt last-position))))
|
|
|
|
(send clear-sd set-delta-background "white")
|
|
(send yellow-sd set-delta-background "yellow")
|
|
(send black-foreground-sd set-delta-foreground "black")
|
|
(send gray-foreground-sd set-delta-foreground "gray")
|
|
(send d set-alignment 'left 'center)
|
|
(send bp set-alignment 'right 'center)
|
|
(when current-limit
|
|
(send rb set-selection 1))
|
|
(update-ok-button-state)
|
|
(grayizie)
|
|
(send tb focus)
|
|
(let ([e (send tb get-editor)])
|
|
(send e set-position 0 (send e last-position)))
|
|
(send d show #t)
|
|
result)
|
|
|
|
|
|
|
|
(define (limit-length l n)
|
|
(let loop ([l l]
|
|
[n n])
|
|
(cond
|
|
[(or (null? l) (zero? n)) null]
|
|
[else (cons (car l) (loop (cdr l) (- n 1)))])))
|
|
(define (remove-duplicate-languages l)
|
|
(reverse
|
|
(let loop ([l (reverse l)])
|
|
(cond
|
|
[(null? l) l]
|
|
[else
|
|
(if (member (car (car l)) (map car (cdr l)))
|
|
(loop (cdr l))
|
|
(cons (car l) (loop (cdr l))))]))))
|
|
|
|
(define programming-language-label (string-constant programming-language-label))
|
|
(define second-line-indent 6)
|
|
(define language-message%
|
|
(class canvas%
|
|
(inherit get-dc get-client-size refresh)
|
|
(define message "")
|
|
(define to-draw-message #f)
|
|
(define/public (set-lang l)
|
|
(unless (equal? l message)
|
|
(set! message l)
|
|
(compute-new-string)
|
|
(refresh)))
|
|
|
|
(define yellow? #f)
|
|
|
|
(define/public (set-yellow/lang y? l)
|
|
(unless (and (equal? y? yellow?)
|
|
(equal? l message))
|
|
(set! yellow? y?)
|
|
(set! message l)
|
|
(compute-new-string)
|
|
(refresh)))
|
|
|
|
(define/override (on-size w h)
|
|
(compute-new-string)
|
|
(refresh))
|
|
|
|
(define/private (compute-new-string)
|
|
(let-values ([(cw ch) (get-client-size)])
|
|
(let ([width-to-use (- cw (get-left-side-padding))])
|
|
(let loop ([c (string-length message)])
|
|
(cond
|
|
[(= c 0) (set! to-draw-message "")]
|
|
[else
|
|
(let ([candidate (if (= c (string-length message))
|
|
message
|
|
(string-append (substring message 0 c) "..."))])
|
|
(let-values ([(tw th _1 _2) (send (get-dc) get-text-extent candidate small-control-font)])
|
|
(cond
|
|
[(tw . <= . width-to-use) (set! to-draw-message candidate)]
|
|
[else
|
|
(loop (- c 1))])))])))))
|
|
|
|
(define/public (set-yellow y?)
|
|
(unless (equal? y? yellow?)
|
|
(set! yellow? y?)
|
|
(refresh)))
|
|
|
|
(define last-time-width 0)
|
|
(define last-time-string "")
|
|
|
|
(define/override (on-paint)
|
|
(unless to-draw-message
|
|
(compute-new-string))
|
|
(let ([dc (get-dc)])
|
|
(send dc set-font small-control-font)
|
|
(let*-values ([(tw th _1 _2) (send dc get-text-extent to-draw-message)]
|
|
[(w h) (values (+ tw (get-left-side-padding)) th)])
|
|
(send dc set-pen (get-panel-background) 1 'transparent)
|
|
(send dc set-brush (get-panel-background) 'transparent)
|
|
(send dc draw-rectangle 0 0 w h)
|
|
(when yellow?
|
|
(send dc set-pen "black" 1 'transparent)
|
|
(send dc set-brush "yellow" 'solid)
|
|
(send dc draw-rectangle (get-left-side-padding) 0 tw th))
|
|
(send dc draw-text to-draw-message (get-left-side-padding) 0))))
|
|
|
|
(super-new [style '(transparent)])
|
|
(inherit stretchable-width stretchable-height)
|
|
(stretchable-width #t)
|
|
(stretchable-height #f)
|
|
|
|
(inherit min-height)
|
|
(let ([dc (get-dc)])
|
|
(let-values ([(w2 h2 _3 _4) (send dc get-text-extent "x" small-control-font)])
|
|
(min-height (inexact->exact (floor h2)))))))
|
|
|
|
(define language-label-message%
|
|
(class name-message%
|
|
(init-field frame)
|
|
(define/override (fill-popup menu reset)
|
|
(let ([added-one? #f])
|
|
(send (new menu-item%
|
|
[label (string-constant recent-languages)]
|
|
[callback void]
|
|
[parent menu])
|
|
enable #f)
|
|
(for-each
|
|
(λ (name/settings)
|
|
(let* ([name (car name/settings)]
|
|
[marshalled-settings (cdr name/settings)]
|
|
[lang (ormap
|
|
(λ (l) (and (equal? (send l get-language-name) name) l))
|
|
(drscheme:language-configuration:get-languages))])
|
|
(when lang
|
|
;; this test can fail when a language has been added wrongly via the tools interface
|
|
;; just ignore that menu item, in that case.
|
|
(let ([settings (send lang unmarshall-settings marshalled-settings)])
|
|
(when lang
|
|
(set! added-one? #t)
|
|
(new menu-item%
|
|
[parent menu]
|
|
[label (send lang get-language-name)]
|
|
[callback
|
|
(λ (x y)
|
|
(send (send frame get-definitions-text)
|
|
set-next-settings
|
|
(drscheme:language-configuration:make-language-settings
|
|
lang
|
|
settings)))]))))))
|
|
(preferences:get 'drscheme:recent-language-names))
|
|
(unless added-one?
|
|
(send (new menu-item%
|
|
[label (string-append
|
|
" << "
|
|
(string-constant no-recently-chosen-languages)
|
|
" >>")]
|
|
[parent menu]
|
|
[callback void])
|
|
enable #f))
|
|
(new separator-menu-item% [parent menu]))
|
|
(new menu-item%
|
|
[label (string-constant choose-language-menu-item-label)]
|
|
[parent menu]
|
|
[callback
|
|
(λ (x y)
|
|
(send frame choose-language-callback))]))
|
|
|
|
(super-new [label programming-language-label]
|
|
[font tiny-control-font])))
|
|
|
|
(define -frame% (frame-mixin super-frame%))
|
|
|
|
(define module-browser-dragable-panel%
|
|
(class panel:horizontal-dragable%
|
|
(inherit get-percentages)
|
|
(define/augment (after-percentage-change)
|
|
(let ([percentages (get-percentages)])
|
|
(when (and (pair? percentages)
|
|
(pair? (cdr percentages))
|
|
(null? (cddr percentages)))
|
|
(preferences:set 'drscheme:module-browser-size-percentage
|
|
(car percentages))))
|
|
(inner (void) after-percentage-change))
|
|
(super-new)))
|
|
|
|
(define drs-name-message%
|
|
(class name-message%
|
|
(define/override (on-choose-directory dir)
|
|
(let ([file (finder:get-file dir
|
|
(string-constant select-file)
|
|
#f
|
|
""
|
|
(send this get-top-level-window))])
|
|
(when file
|
|
(handler:edit-file file))))
|
|
(super-new)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; lambda-snipclass is for backwards compatibility
|
|
;;
|
|
(define lambda-snipclass
|
|
(make-object (class snip-class% ()
|
|
(define/override (read p) (make-object string-snip% "λ"))
|
|
(super-new))))
|
|
(send lambda-snipclass set-version 1)
|
|
(send lambda-snipclass set-classname "drscheme:lambda-snip%")
|
|
(send (get-the-snip-class-list) add lambda-snipclass)
|
|
|
|
(define newest-frame 'nothing-yet)
|
|
|
|
(define open-drscheme-window
|
|
(case-lambda
|
|
[() (open-drscheme-window #f)]
|
|
[(name)
|
|
(cond
|
|
[(and newest-frame
|
|
name
|
|
(not (eq? newest-frame 'nothing-yet))
|
|
(send newest-frame still-untouched?))
|
|
(send newest-frame change-to-file name)
|
|
(send newest-frame show #t)
|
|
(begin0 newest-frame
|
|
(set! newest-frame #f))]
|
|
[(and name ;; only open a tab if we have a filename
|
|
(preferences:get 'drscheme:open-in-tabs))
|
|
(let ([fr (let loop ([frs (cons (send (group:get-the-frame-group) get-active-frame)
|
|
(send (group:get-the-frame-group) get-frames))])
|
|
(cond
|
|
[(null? frs) #f]
|
|
[else (let ([fr (car frs)])
|
|
(or (and (is-a? fr -frame<%>)
|
|
fr)
|
|
(loop (cdr frs))))]))])
|
|
(if fr
|
|
(begin (send fr open-in-new-tab name)
|
|
(send fr show #t)
|
|
fr)
|
|
(create-new-drscheme-frame name)))]
|
|
[else
|
|
(create-new-drscheme-frame name)])]))
|
|
|
|
(define first-frame? #t)
|
|
(define (create-new-drscheme-frame filename)
|
|
(let* ([drs-frame% (drscheme:get/extend:get-unit-frame)]
|
|
[frame (new drs-frame% (filename filename))])
|
|
(send (send frame get-interactions-text) initialize-console)
|
|
(when first-frame?
|
|
(let ([pos (preferences:get 'drscheme:frame:initial-position)])
|
|
(when pos
|
|
(send frame move (car pos) (cdr pos))))
|
|
(unless (eq? (system-type) 'macosx)
|
|
;; mac os x has a bug where maximizing can make the window too big.
|
|
(send frame maximize (preferences:get 'drscheme:unit-window-max?))))
|
|
(send frame show #t)
|
|
(set! first-frame? #f)
|
|
frame))))
|