(module main (lib "a-unit.ss") (require (lib "string-constant.ss" "string-constants") (lib "cmdline.ss") (lib "contract.ss") "drsig.ss" (lib "mred.ss" "mred") (lib "framework.ss" "framework") (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")) (import [prefix drscheme:app: drscheme:app^] [prefix drscheme:unit: drscheme:unit^] [prefix drscheme:get/extend: drscheme:get/extend^] [prefix drscheme:language-configuration: drscheme:language-configuration/internal^] [prefix drscheme:language: drscheme:language^] [prefix drscheme:teachpack: drscheme:teachpack^] [prefix drscheme:module-language: drscheme:module-language^] [prefix drscheme:tools: drscheme:tools^] [prefix drscheme:debug: drscheme:debug^] [prefix drscheme:frame: drscheme:frame^] [prefix drscheme:font: drscheme:font^] [prefix drscheme:modes: drscheme:modes^] [prefix drscheme:help-desk: drscheme:help-desk^]) (export) (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:recent-language-names null (λ (x) (and (list? x) (andmap (λ (x) (and (pair? x) (string? (car x)))) x)))) (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 (λ (x) (or (path? x) (drscheme:frame:planet-spec? x))) x)))) (preferences:set-un/marshall 'drscheme:user-defined-keybindings (λ (in) (map (λ (x) (if (path? x) (path->bytes x) x)) in)) (λ (ex) (if (list? ex) (map (λ (x) (if (bytes? x) (bytes->path x) x)) 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) (preferences:set-default 'drscheme:switch-to-module-language-automatically? #t boolean?) (drscheme:font:setup-preferences) (drscheme:help-desk:add-help-desk-font-prefs #t) (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) (make-check-box 'drscheme:switch-to-module-language-automatically? (string-constant switch-to-module-language-automatically) 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) (drscheme:language:register-capability 'drscheme:define-popup (or/c (cons/c string? string?) false/c) (cons "(define" "(define ...)")) (drscheme:language:register-capability 'drscheme:special:insert-fraction (flat-contract boolean?) #t) (drscheme:language:register-capability 'drscheme:special:insert-large-letters (flat-contract boolean?) #t) (drscheme:language:register-capability 'drscheme:special:insert-lambda (flat-contract boolean?) #t) (drscheme:language:register-capability 'drscheme:special:insert-image (flat-contract boolean?) #t) (drscheme:language:register-capability 'drscheme:special:insert-comment-box (flat-contract boolean?) #t) (drscheme:language:register-capability 'drscheme:language-menu-title (flat-contract string?) (string-constant scheme-menu-name)) (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 catch-all handler to open drscheme files (handler:insert-format-handler "Units" (λ (filename) #t) drscheme:unit:open-drscheme-window) ;; add a handler to open .plt files. (handler:insert-format-handler "PLT Files" (λ (filename) (let ([ext (filename-extension filename)]) (and ext (or (bytes=? #"PLT" ext) (bytes=? #"plt" ext)) (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 above (of course). (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-numbers) (send lang marshall-settings settings)))) (λ (x) (and (list? x) (= 2 (length x)) (let* ([lang-nums (first x)] [marshalled-settings (second x)] [lang (ormap (λ (x) (and (or (equal? (send x get-language-numbers) lang-nums) ;; this second branch of the `or' corresdponds ;; to preferences saved from earlier versions of ;; drscheme, for a sort of backwards compatibility (equal? (send x get-language-position) lang-nums)) 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%)) (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)]) (let* ([sl (editor:get-standard-style-list)] [sd (make-object style-delta%)]) (send sd set-delta-foreground (make-object color% 255 0 0)) (send sl new-named-style "drscheme:text:ports err" (send sl find-or-create-style (send sl find-named-style "text:ports err") sd))) (define repl-error-pref 'drscheme:read-eval-print-loop:error-color) (define repl-out-pref 'drscheme:read-eval-print-loop:out-color) (define repl-value-pref 'drscheme:read-eval-print-loop:value-color) (color-prefs:register-color-preference repl-value-pref "text:ports value" (make-object color% 0 0 175) (make-object color% 57 89 216)) (color-prefs:register-color-preference repl-error-pref "text:ports err" (let ([sd (make-object style-delta% 'change-italic)]) (send sd set-delta-foreground (make-object color% 255 0 0)) sd)) (color-prefs:register-color-preference repl-out-pref "text:ports out" (make-object color% 150 0 150) (make-object color% 192 46 214)) (color-prefs:add-to-preferences-panel (string-constant repl-colors) (λ (parent) (color-prefs:build-color-selection-panel parent repl-value-pref "text:ports value" (string-constant repl-value-color)) (color-prefs:build-color-selection-panel parent repl-error-pref "text:ports err" (string-constant repl-error-color)) (color-prefs:build-color-selection-panel parent repl-out-pref "text:ports out" (string-constant repl-out-color)))) ;; 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 drscheme:frame:add-keybindings-item (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))))]))) ;; NOTE: drscheme-normal.ss sets current-command-line-arguments to ;; the list of files to open, after parsing out flags like -h (let* ([files-to-open (reverse (vector->list (current-command-line-arguments)))] [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))))