From d219107a0a2f0a54ea7746209f78e8273d43561f Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 21 Jan 2008 00:33:28 +0000 Subject: [PATCH] fixed PR 9140 svn: r8374 --- collects/drscheme/private/debug.ss | 4 +- collects/drscheme/private/language.ss | 12 +- collects/drscheme/private/main.ss | 1002 +++++++++++----------- collects/mrlib/interactive-value-port.ss | 11 +- 4 files changed, 521 insertions(+), 508 deletions(-) diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index 311f793299..fd9eebb54b 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -275,7 +275,7 @@ profile todo: (let ([note (new note%)]) (send note set-callback (λ () (show-backtrace-window msg cms))) (write-special note (current-error-port)) - (display #\space (current-error-port))))))) + (display #\space (current-error-port)) ))))) (define (show-error-and-highlight msg exn highlight-errors) (let ([cms @@ -285,10 +285,8 @@ profile todo: (when (and cms (pair? cms)) (print-bug-to-stderr msg cms)) - (let ([srcs-to-display (find-src-to-display exn cms)]) (for-each display-srcloc-in-error srcs-to-display) - (display msg (current-error-port)) (when (exn:fail:syntax? exn) (show-syntax-error-context (current-error-port) exn)) diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss index 68e7919d27..bd78d64ff7 100644 --- a/collects/drscheme/private/language.ss +++ b/collects/drscheme/private/language.ss @@ -351,7 +351,17 @@ (exact? x) (real? x) (not (integer? x))))]) - (parameterize ([pretty-print-columns width] + (parameterize ( + ;; these three handlers aren't used, but are set to override the user's settings + [pretty-print-print-line (λ (line-number op old-line dest-columns) + (when (and (not (equal? line-number 0)) + (not (equal? dest-columns 'infinity))) + (newline op)) + 0)] + [pretty-print-pre-print-hook (λ (val port) (void))] + [pretty-print-post-print-hook (λ (val port) (void))] + + [pretty-print-columns width] [pretty-print-size-hook (λ (value display? port) (cond diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index 19c525da2e..c05c2ff8d0 100644 --- a/collects/drscheme/private/main.ss +++ b/collects/drscheme/private/main.ss @@ -1,506 +1,502 @@ - #lang scheme/unit - (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-in pretty-print: (lib "pretty.ss")) - (prefix-in print-convert: (lib "pconvert.ss")) - (lib "include.ss") - (lib "list.ss") - scheme/path - (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: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:htdp:last-set-teachpacks - '() - (λ (x) - (and (list? x) - (andmap (λ (x) - (and (list? x) - (pair? x) - (eq? (car x) 'lib) - (andmap string? (cdr x)))) - x)))) - (preferences:set-default 'drscheme:defs/ints-horizontal #f boolean?) - (preferences:set-default 'drscheme:unit-window-max? #f boolean?) - (preferences:set-default 'drscheme:frame:initial-position #f - (λ (x) (or (not x) - (and (pair? x) - (number? (car x)) - (number? (cdr x)))))) - - (preferences:set-default 'drscheme:limit-memory #f - (λ (x) (or (boolean? x) - (integer? x) - (x . >= . (* 1024 1024 100))))) - - (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:switch-to-module-language-automatically? #t boolean?) - (preferences:set-default - 'drscheme:default-tools-configuration - 'load - (lambda (p) - (memq p '(load skip)))) +(require (lib "string-constant.ss" "string-constants") + (lib "contract.ss") + "drsig.ss" + (lib "mred.ss" "mred") + (lib "framework.ss" "framework") + (lib "class.ss") + (lib "list.ss") + scheme/path + (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: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:htdp:last-set-teachpacks + '() + (λ (x) + (and (list? x) + (andmap (λ (x) + (and (list? x) + (pair? x) + (eq? (car x) 'lib) + (andmap string? (cdr x)))) + x)))) +(preferences:set-default 'drscheme:defs/ints-horizontal #f boolean?) +(preferences:set-default 'drscheme:unit-window-max? #f boolean?) +(preferences:set-default 'drscheme:frame:initial-position #f + (λ (x) (or (not x) + (and (pair? x) + (number? (car x)) + (number? (cdr x)))))) + +(preferences:set-default 'drscheme:limit-memory #f + (λ (x) (or (boolean? x) + (integer? x) + (x . >= . (* 1024 1024 100))))) + +(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:switch-to-module-language-automatically? #t boolean?) + +(preferences:set-default + 'drscheme:default-tools-configuration + 'load + (lambda (p) + (memq p '(load skip)))) + +(preferences:set-default + 'drscheme:tools-configuration + null + list?) + +(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) + + (make-check-box 'drscheme:switch-to-module-language-automatically? + (string-constant switch-to-module-language-automatically) + editor-panel) + + (make-check-box 'drscheme:defs/ints-horizontal + (string-constant interactions-beside-definitions) + 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:set-default - 'drscheme:tools-configuration - null - list?) - - (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) - - (make-check-box 'drscheme:switch-to-module-language-automatically? - (string-constant switch-to-module-language-automatically) - editor-panel) - - (make-check-box 'drscheme:defs/ints-horizontal - (string-constant interactions-beside-definitions) - 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:tools:add-prefs-panel) - - (drscheme:language:register-capability 'drscheme:autocomplete-words (listof string?) '()) - (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)) - - (drscheme:language:register-capability 'drscheme:teachpack-menu-items - (or/c false/c (flat-contract drscheme:unit:teachpack-callbacks?)) - #f) - - (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 - (if (preferences:get 'drscheme:open-in-tabs) - (vector->list (current-command-line-arguments)) - (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)) - (when (and (preferences:get 'drscheme:open-in-tabs) - (not (null? no-dups))) - (handler:edit-file (car no-dups)))) + (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:tools:add-prefs-panel) + +(drscheme:language:register-capability 'drscheme:autocomplete-words (listof string?) '()) +(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)) + +(drscheme:language:register-capability 'drscheme:teachpack-menu-items + (or/c false/c (flat-contract drscheme:unit:teachpack-callbacks?)) + #f) + +(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 + (if (preferences:get 'drscheme:open-in-tabs) + (vector->list (current-command-line-arguments)) + (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)) + (when (and (preferences:get 'drscheme:open-in-tabs) + (not (null? no-dups))) + (handler:edit-file (car no-dups)))) diff --git a/collects/mrlib/interactive-value-port.ss b/collects/mrlib/interactive-value-port.ss index 6092fd35e8..9c76fedc9a 100644 --- a/collects/mrlib/interactive-value-port.ss +++ b/collects/mrlib/interactive-value-port.ss @@ -41,7 +41,16 @@ (not (integer? x)))) (define (do-printing pretty value port) - (parameterize ([pretty-print-columns 'infinity] + (parameterize (;; these three handlers aren't used, but are set to override the user's settings + [pretty-print-print-line (λ (line-number op old-line dest-columns) + (when (and (not (equal? line-number 0)) + (not (equal? dest-columns 'infinity))) + (newline op)) + 0)] + [pretty-print-pre-print-hook (λ (val port) (void))] + [pretty-print-post-print-hook (λ (val port) (void))] + [pretty-print-columns 'infinity] + [pretty-print-size-hook (λ (value display? port) (cond