392 lines
16 KiB
Scheme
392 lines
16 KiB
Scheme
|
|
(module main mzscheme
|
|
(require (lib "string-constant.ss" "string-constants")
|
|
(lib "unitsig.ss")
|
|
"drsig.ss"
|
|
(lib "mred.ss" "mred")
|
|
(lib "framework.ss" "framework")
|
|
(lib "unitsig.ss")
|
|
(lib "class.ss")
|
|
(prefix pretty-print: (lib "pretty.ss"))
|
|
(prefix print-convert: (lib "pconvert.ss"))
|
|
(lib "include.ss")
|
|
(lib "list.ss")
|
|
(lib "file.ss")
|
|
(lib "external.ss" "browser")
|
|
(lib "plt-installer.ss" "setup"))
|
|
|
|
(provide main@)
|
|
(define argv (current-command-line-arguments))
|
|
|
|
(define main@
|
|
(unit/sig ()
|
|
(import [drscheme:app : drscheme:app^]
|
|
[drscheme:unit : drscheme:unit^]
|
|
[drscheme:get/extend : drscheme:get/extend^]
|
|
[drscheme:language-configuration : drscheme:language-configuration/internal^]
|
|
[drscheme:language : drscheme:language^]
|
|
[drscheme:teachpack : drscheme:teachpack^]
|
|
[drscheme:module-language : drscheme:module-language^]
|
|
[drscheme:tools : drscheme:tools^]
|
|
[drscheme:debug : drscheme:debug^]
|
|
[drscheme:frame : drscheme:frame^]
|
|
[drscheme:font : drscheme:font^]
|
|
[drscheme:modes : drscheme:modes^])
|
|
|
|
(application-file-handler
|
|
(let ([default (application-file-handler)])
|
|
(λ (name)
|
|
(if (null? (get-top-level-windows))
|
|
(handler:edit-file name)
|
|
(default name)))))
|
|
|
|
(application-quit-handler
|
|
(let ([default (application-quit-handler)])
|
|
(λ ()
|
|
(if (null? (get-top-level-windows))
|
|
(when (exit:user-oks-exit)
|
|
(exit:exit))
|
|
(default)))))
|
|
|
|
(application-about-handler
|
|
(λ ()
|
|
(drscheme:app:about-drscheme)))
|
|
|
|
(drscheme:modes:add-initial-modes)
|
|
|
|
(namespace-set-variable-value! 'help-desk:frame-mixin drscheme:frame:basics-mixin)
|
|
|
|
(finder:default-filters (list* '("Scheme (.scm)" "*.scm")
|
|
'("Scheme (.ss)" "*.ss")
|
|
(finder:default-filters)))
|
|
(application:current-app-name (string-constant drscheme))
|
|
|
|
(preferences:set-default 'drscheme:show-interactions-on-execute #t boolean?)
|
|
(preferences:set-default 'drscheme:open-in-tabs #f boolean?)
|
|
(preferences:set-default 'drscheme:toolbar-shown #t boolean?)
|
|
(preferences:set-default 'drscheme:user-defined-keybindings '() (λ (x) (and (list? x) (andmap path? x))))
|
|
(preferences:set-un/marshall
|
|
'drscheme:user-defined-keybindings
|
|
(λ (in) (map path->bytes in))
|
|
(λ (ex) (if (and (list? ex)
|
|
(andmap bytes? ex))
|
|
(map bytes->path ex)
|
|
'())))
|
|
|
|
(let ([number-between-zero-and-one?
|
|
(λ (x) (and (number? x) (<= 0 x 1)))])
|
|
(preferences:set-default 'drscheme:unit-window-size-percentage
|
|
1/2
|
|
number-between-zero-and-one?)
|
|
(preferences:set-default 'drscheme:module-browser-size-percentage
|
|
1/5
|
|
number-between-zero-and-one?))
|
|
(preferences:set-default 'drscheme:module-browser:name-length 1
|
|
(λ (x) (memq x '(0 1 2))))
|
|
|
|
(let ([frame-width 600]
|
|
[frame-height 650]
|
|
[window-trimming-upper-bound-width 20]
|
|
[window-trimming-upper-bound-height 50])
|
|
(let-values ([(w h) (get-display-size)])
|
|
(set! frame-width (min frame-width (- w window-trimming-upper-bound-width)))
|
|
(set! frame-height (min frame-height (- h window-trimming-upper-bound-height))))
|
|
(preferences:set-default 'drscheme:unit-window-width frame-width number?)
|
|
(preferences:set-default 'drscheme:unit-window-height frame-height number?))
|
|
|
|
(preferences:set-default 'drscheme:backtrace-window-width 400 number?)
|
|
(preferences:set-default 'drscheme:backtrace-window-height 300 number?)
|
|
(preferences:set-default 'drscheme:backtrace-window-x 0 number?)
|
|
(preferences:set-default 'drscheme:backtrace-window-y 0 number?)
|
|
|
|
(preferences:set-default 'drscheme:profile-how-to-count 'time
|
|
(λ (x)
|
|
(memq x '(time count))))
|
|
(preferences:set-default 'drscheme:profile:low-color
|
|
(make-object color% 150 255 150)
|
|
(λ (x) (is-a? x color%)))
|
|
(preferences:set-default 'drscheme:profile:high-color
|
|
(make-object color% 255 150 150)
|
|
(λ (x) (is-a? x color%)))
|
|
(preferences:set-default 'drscheme:profile:scale
|
|
'linear
|
|
(λ (x) (memq x '(sqrt linear square))))
|
|
|
|
(preferences:set-default 'drscheme:test-coverage-ask-about-clearing? #t boolean?)
|
|
|
|
;; size is in editor positions
|
|
(preferences:set-default 'drscheme:repl-buffer-size
|
|
'(#t . 1000)
|
|
(λ (x)
|
|
(and (pair? x)
|
|
(boolean? (car x))
|
|
(integer? (cdr x))
|
|
(<= 1 (cdr x) 10000))))
|
|
|
|
(let ([marshall-color
|
|
(λ (c)
|
|
(list (send c red) (send c green) (send c blue)))]
|
|
[unmarshall-color
|
|
(λ (l)
|
|
(if (and (list? l)
|
|
(= 3 (length l))
|
|
(andmap (λ (x) (and number? (<= 0 x 255)))
|
|
l))
|
|
(make-object color% (car l) (cadr l) (caddr l))
|
|
(make-object color% 0 0 0)))])
|
|
(preferences:set-un/marshall
|
|
'drscheme:profile:low-color
|
|
marshall-color
|
|
unmarshall-color)
|
|
(preferences:set-un/marshall
|
|
'drscheme:profile:high-color
|
|
marshall-color
|
|
unmarshall-color))
|
|
|
|
(preferences:set-default
|
|
'drscheme:keybindings-window-size
|
|
(cons 200 400)
|
|
(λ (x) (and (pair? x)
|
|
(number? (car x))
|
|
(number? (cdr x)))))
|
|
|
|
(preferences:set-default
|
|
'drscheme:execute-warning-once
|
|
#f
|
|
(λ (x)
|
|
(or (eq? x #t)
|
|
(not x))))
|
|
|
|
(preferences:set-default
|
|
'drscheme:teachpacks
|
|
(drscheme:teachpack:new-teachpack-cache)
|
|
drscheme:teachpack:teachpack-cache?)
|
|
(preferences:set-un/marshall
|
|
'drscheme:teachpacks
|
|
drscheme:teachpack:marshall-teachpack-cache
|
|
drscheme:teachpack:unmarshall-teachpack-cache)
|
|
|
|
(drscheme:font:setup-preferences)
|
|
(color-prefs:add-background-preferences-panel)
|
|
(scheme:add-preferences-panel)
|
|
(scheme:add-coloring-preferences-panel)
|
|
(preferences:add-editor-checkbox-panel)
|
|
(preferences:add-warnings-checkbox-panel)
|
|
(preferences:add-scheme-checkbox-panel)
|
|
|
|
(let ([make-check-box
|
|
(λ (pref-sym string parent)
|
|
(let ([q (make-object check-box%
|
|
string
|
|
parent
|
|
(λ (checkbox evt)
|
|
(preferences:set
|
|
pref-sym
|
|
(send checkbox get-value))))])
|
|
(preferences:add-callback pref-sym (λ (p v) (send q set-value v)))
|
|
(send q set-value (preferences:get pref-sym))))])
|
|
(preferences:add-to-editor-checkbox-panel
|
|
(λ (editor-panel)
|
|
(make-check-box 'drscheme:open-in-tabs
|
|
(string-constant open-files-in-tabs)
|
|
editor-panel)
|
|
(make-check-box 'drscheme:show-interactions-on-execute
|
|
(string-constant show-interactions-on-execute)
|
|
editor-panel)
|
|
|
|
;; come back to this one.
|
|
#;
|
|
(letrec ([hp (new horizontal-panel%
|
|
(parent editor-panel)
|
|
(alignment '(left top))
|
|
(stretchable-height #f))]
|
|
[cb (new check-box%
|
|
(label (string-constant limit-interactions-size))
|
|
(parent hp)
|
|
(callback (λ (cb v) (cb-callback))))]
|
|
[sl (new slider%
|
|
(label #f)
|
|
(parent hp)
|
|
(min-value 1)
|
|
(max-value 10000)
|
|
(callback
|
|
(λ (sl _) (sl-callback))))]
|
|
[cb-callback
|
|
(λ ()
|
|
(preferences:set 'drscheme:repl-buffer-size
|
|
(cons (send cb get-value)
|
|
(cdr (preferences:get 'drscheme:repl-buffer-size)))))]
|
|
[sl-callback
|
|
(λ ()
|
|
(preferences:set 'drscheme:repl-buffer-size
|
|
(cons (car (preferences:get 'drscheme:repl-buffer-size))
|
|
(send sl get-value))))]
|
|
[update-controls
|
|
(λ (v)
|
|
(let ([on? (car v)])
|
|
(send sl enable on?)
|
|
(send cb set-value on?)
|
|
(send sl set-value (cdr v))))])
|
|
(preferences:add-callback 'drscheme:repl-buffer-size (λ (p v) (update-controls v)))
|
|
(update-controls (preferences:get 'drscheme:repl-buffer-size)))))
|
|
|
|
(preferences:add-to-warnings-checkbox-panel
|
|
(λ (warnings-panel)
|
|
(make-check-box 'drscheme:execute-warning-once
|
|
(string-constant only-warn-once)
|
|
warnings-panel)
|
|
(make-check-box 'drscheme:test-coverage-ask-about-clearing?
|
|
(string-constant test-coverage-ask?)
|
|
warnings-panel))))
|
|
(drscheme:debug:add-prefs-panel)
|
|
(install-help-browser-preference-panel)
|
|
|
|
(handler:current-create-new-window
|
|
(let ([drscheme-current-create-new-window
|
|
(λ (filename)
|
|
(drscheme:unit:open-drscheme-window filename))])
|
|
drscheme-current-create-new-window))
|
|
|
|
;; add a handler to open .plt files.
|
|
(handler:insert-format-handler
|
|
"PLT Files"
|
|
(λ (filename)
|
|
(and (equal? "plt" (filename-extension filename))
|
|
(gui-utils:get-choice
|
|
(format (string-constant install-plt-file) filename)
|
|
(string-constant install-plt-file/yes)
|
|
(string-constant install-plt-file/no))))
|
|
(λ (filename)
|
|
(run-installer filename)
|
|
#f))
|
|
|
|
(drscheme:tools:load/invoke-all-tools
|
|
(λ ()
|
|
(void))
|
|
(λ ()
|
|
(drscheme:language-configuration:add-built-in-languages)
|
|
(drscheme:module-language:add-module-language)
|
|
(drscheme:language-configuration:add-info-specified-languages)))
|
|
|
|
;; no more extension after this point
|
|
(drscheme:get/extend:get-interactions-canvas)
|
|
(drscheme:get/extend:get-definitions-canvas)
|
|
(drscheme:get/extend:get-unit-frame)
|
|
(drscheme:get/extend:get-interactions-text)
|
|
(drscheme:get/extend:get-definitions-text)
|
|
(drscheme:language-configuration:get-languages)
|
|
|
|
;; this default can only be set *after* the
|
|
;; languages have all be registered by tools
|
|
(preferences:set-default
|
|
drscheme:language-configuration:settings-preferences-symbol
|
|
(drscheme:language-configuration:get-default-language-settings)
|
|
drscheme:language-configuration:language-settings?)
|
|
|
|
;; if the unmarshaller returns #f, that will fail the
|
|
;; test for this preference, reverting back to the default.
|
|
;; In that case, the default is specified in the pref.ss file
|
|
;; of the default collection and may not be the default
|
|
;; specified below.
|
|
(preferences:set-un/marshall
|
|
drscheme:language-configuration:settings-preferences-symbol
|
|
(λ (x)
|
|
(let ([lang (drscheme:language-configuration:language-settings-language x)]
|
|
[settings (drscheme:language-configuration:language-settings-settings x)])
|
|
(list (send lang get-language-position)
|
|
(send lang marshall-settings settings))))
|
|
(λ (x)
|
|
(and (list? x)
|
|
(= 2 (length x))
|
|
(let* ([lang-position (first x)]
|
|
[marshalled-settings (second x)]
|
|
[lang (ormap
|
|
(λ (x)
|
|
(and (equal? lang-position
|
|
(send x get-language-position))
|
|
x))
|
|
(drscheme:language-configuration:get-languages))])
|
|
(and lang
|
|
(let ([settings (send lang unmarshall-settings marshalled-settings)])
|
|
(drscheme:language-configuration:make-language-settings
|
|
lang
|
|
(or settings (send lang default-settings)))))))))
|
|
|
|
(let ([drs-handler-recent-items-super%
|
|
(class (drscheme:frame:basics-mixin
|
|
(frame:standard-menus-mixin
|
|
frame:basic%))
|
|
(define/override (edit-menu:between-select-all-and-find menu)
|
|
(void))
|
|
(super-new))])
|
|
(handler:set-recent-items-frame-superclass drs-handler-recent-items-super%))
|
|
|
|
;;
|
|
;; Show expanded language dialog when version changes
|
|
;;
|
|
(preferences:set-default 'drscheme:last-version #f (λ (x) (or (string? x) (not x))))
|
|
(preferences:set-default 'drscheme:last-language #f (λ (x) (or (symbol? x) (not x))))
|
|
|
|
(cond
|
|
[(current-eventspace-has-menu-root?)
|
|
(drscheme:frame:create-root-menubar)
|
|
(preferences:set 'framework:exit-when-no-frames #f)]
|
|
[else
|
|
(preferences:set 'framework:exit-when-no-frames #t)])
|
|
|
|
|
|
(drscheme:app:check-new-version)
|
|
|
|
;;
|
|
;; Check for any files lost last time.
|
|
;; Ignore the framework's empty frames test, since
|
|
;; the autosave information window may appear and then
|
|
;; go away (leaving no frames temporarily) but we are
|
|
;; not going to be exiting yet.
|
|
(autosave:restore-autosave-files/gui)
|
|
|
|
;; install user's keybindings
|
|
(for-each keymap:add-user-keybindings-file (preferences:get 'drscheme:user-defined-keybindings))
|
|
|
|
;; the initial window doesn't set the
|
|
;; unit object's state correctly, yet.
|
|
(define (make-basic)
|
|
(let* ([frame (drscheme:unit:open-drscheme-window)]
|
|
[interactions-edit (send frame get-interactions-text)]
|
|
[definitions-edit (send frame get-interactions-text)]
|
|
[filename (send definitions-edit get-filename)])
|
|
(unless filename
|
|
(send frame update-shown)
|
|
(send (send frame get-interactions-canvas) focus))
|
|
(send frame show #t)))
|
|
|
|
(define (remove-duplicates files)
|
|
(let loop ([files files])
|
|
(cond
|
|
[(null? files) null]
|
|
[else (if (member (car files) (cdr files))
|
|
(loop (cdr files))
|
|
(cons (car files) (loop (cdr files))))])))
|
|
|
|
(let* ([files-to-open (reverse (vector->list argv))]
|
|
[normalized/filtered
|
|
(let loop ([files files-to-open])
|
|
(cond
|
|
[(null? files) null]
|
|
[else (let ([file (car files)])
|
|
(if (file-exists? file)
|
|
(cons (normalize-path file) (loop (cdr files)))
|
|
(begin
|
|
(message-box
|
|
(string-constant drscheme)
|
|
(format (string-constant cannot-open-because-dne) file))
|
|
(loop (cdr files)))))]))]
|
|
[no-dups (remove-duplicates normalized/filtered)]
|
|
[frames
|
|
(map (λ (f) (handler:edit-file
|
|
f
|
|
(λ () (drscheme:unit:open-drscheme-window f))))
|
|
no-dups)])
|
|
(when (null? (filter (λ (x) x) frames))
|
|
(make-basic))))))
|