suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed PR 9140

Browse Source 
svn: r8374
This commit is contained in:
Robby Findler 2008-01-21 00:33:28 +00:00
parent 6018c35cc8
commit d219107a0a
4 changed files with 521 additions and 508 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/drscheme/private/debug.ss
View File

@ -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))

12
collects/drscheme/private/language.ss
View File

@ -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

222
collects/drscheme/private/main.ss
View File

@ -1,21 +1,17 @@
#lang scheme/unit
(require (lib "string-constant.ss" "string-constants")
(lib "cmdline.ss")
(require (lib "string-constant.ss" "string-constants")
(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^]
(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^]
@ -27,16 +23,16 @@
[prefix drscheme:font: drscheme:font^]
[prefix drscheme:modes: drscheme:modes^]
[prefix drscheme:help-desk: drscheme:help-desk^])
(export)
(export)
(application-file-handler
(application-file-handler
(let ([default (application-file-handler)])
(λ (name)
(if (null? (get-top-level-windows))
(handler:edit-file name)
(default name)))))
(application-quit-handler
(application-quit-handler
(let ([default (application-quit-handler)])
(λ ()
(if (null? (get-top-level-windows))
@ -44,20 +40,20 @@
(exit:exit))
(default)))))
(application-about-handler
(application-about-handler
(λ ()
(drscheme:app:about-drscheme)))
(drscheme:modes:add-initial-modes)
(drscheme:modes:add-initial-modes)
(namespace-set-variable-value! 'help-desk:frame-mixin drscheme:frame:basics-mixin)
(namespace-set-variable-value! 'help-desk:frame-mixin drscheme:frame:basics-mixin)
(finder:default-filters (list* '("Scheme (.scm)" "*.scm")
(finder:default-filters (list* '("Scheme (.scm)" "*.scm")
'("Scheme (.ss)" "*.ss")
(finder:default-filters)))
(application:current-app-name (string-constant drscheme))
(application:current-app-name (string-constant drscheme))
(preferences:set-default 'drscheme:htdp:last-set-teachpacks
(preferences:set-default 'drscheme:htdp:last-set-teachpacks
'()
(λ (x)
(and (list? x)
@ -67,20 +63,20 @@
(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
(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
(preferences:set-default 'drscheme:limit-memory #f
(λ (x) (or (boolean? x)
(integer? x)
(x . >= . (* 1024 1024 100)))))
(preferences:set-default 'drscheme:recent-language-names
(preferences:set-default 'drscheme:recent-language-names
null
(λ (x)
(and (list? x)
@ -89,16 +85,16 @@
(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
(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
(preferences:set-un/marshall
'drscheme:user-defined-keybindings
(λ (in) (map (λ (x) (if (path? x) (path->bytes x) x))
in))
@ -106,7 +102,7 @@
(map (λ (x) (if (bytes? x) (bytes->path x) x)) ex)
'())))
(let ([number-between-zero-and-one?
(let ([number-between-zero-and-one?
(λ (x) (and (number? x) (<= 0 x 1)))])
(preferences:set-default 'drscheme:unit-window-size-percentage
1/2
@ -114,10 +110,10 @@
(preferences:set-default 'drscheme:module-browser-size-percentage
1/5
number-between-zero-and-one?))
(preferences:set-default 'drscheme:module-browser:name-length 1
(preferences:set-default 'drscheme:module-browser:name-length 1
(λ (x) (memq x '(0 1 2))))
(let ([frame-width 600]
(let ([frame-width 600]
[frame-height 650]
[window-trimming-upper-bound-width 20]
[window-trimming-upper-bound-height 50])
@ -127,28 +123,28 @@
(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: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
(preferences:set-default 'drscheme:profile-how-to-count 'time
(λ (x)
(memq x '(time count))))
(preferences:set-default 'drscheme:profile:low-color
(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
(preferences:set-default 'drscheme:profile:high-color
(make-object color% 255 150 150)
(λ (x) (is-a? x color%)))
(preferences:set-default 'drscheme:profile:scale
(preferences:set-default 'drscheme:profile:scale
'linear
(λ (x) (memq x '(sqrt linear square))))
(preferences:set-default 'drscheme:test-coverage-ask-about-clearing? #t boolean?)
(preferences:set-default 'drscheme:test-coverage-ask-about-clearing? #t boolean?)
;; size is in editor positions
(preferences:set-default 'drscheme:repl-buffer-size
;; size is in editor positions
(preferences:set-default 'drscheme:repl-buffer-size
'(#t . 1000)
(λ (x)
(and (pair? x)
@ -156,7 +152,7 @@
(integer? (cdr x))
(<= 1 (cdr x) 10000))))
(let ([marshall-color
(let ([marshall-color
(λ (c)
(list (send c red) (send c green) (send c blue)))]
[unmarshall-color
@ -176,42 +172,42 @@
marshall-color
unmarshall-color))
(preferences:set-default
(preferences:set-default
'drscheme:keybindings-window-size
(cons 200 400)
(λ (x) (and (pair? x)
(number? (car x))
(number? (cdr x)))))
(preferences:set-default
(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:switch-to-module-language-automatically? #t boolean?)
(preferences:set-default
(preferences:set-default
'drscheme:default-tools-configuration
'load
(lambda (p)
(memq p '(load skip))))
(preferences:set-default
(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)
(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
(let ([make-check-box
(λ (pref-sym string parent)
(let ([q (make-object check-box%
string
@ -282,42 +278,42 @@
(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: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
(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
(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
(drscheme:language:register-capability 'drscheme:teachpack-menu-items
(or/c false/c (flat-contract drscheme:unit:teachpack-callbacks?))
#f)
(handler:current-create-new-window
(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
;; 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
;; add a handler to open .plt files.
(handler:insert-format-handler
"PLT Files"
(λ (filename)
(let ([ext (filename-extension filename)])
@ -332,34 +328,34 @@
(run-installer filename)
#f))
(drscheme:tools:load/invoke-all-tools
(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)
;; 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
;; 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
;; 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)]
@ -387,7 +383,7 @@
lang
(or settings (send lang default-settings)))))))))
(let ([drs-handler-recent-items-super%
(let ([drs-handler-recent-items-super%
(class (drscheme:frame:basics-mixin
(frame:standard-menus-mixin
frame:basic%))
@ -396,7 +392,7 @@
(super-new))])
(handler:set-recent-items-frame-superclass drs-handler-recent-items-super%))
(cond
(cond
[(current-eventspace-has-menu-root?)
(drscheme:frame:create-root-menubar)
(preferences:set 'framework:exit-when-no-frames #f)]
@ -404,7 +400,7 @@
(preferences:set 'framework:exit-when-no-frames #t)])
(let* ([sl (editor:get-standard-style-list)]
(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
@ -412,23 +408,23 @@
(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
(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
(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
(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
(color-prefs:add-to-preferences-panel
(string-constant repl-colors)
(λ (parent)
(color-prefs:build-color-selection-panel parent
@ -444,20 +440,20 @@
"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)
;; 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
;; 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)
;; 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)]
@ -467,7 +463,7 @@
(send (send frame get-interactions-canvas) focus))
(send frame show #t)))
(define (remove-duplicates files)
(define (remove-duplicates files)
(let loop ([files files])
(cond
[(null? files) null]
@ -475,9 +471,9 @@
(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
;; 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))))]

11
collects/mrlib/interactive-value-port.ss
View File

@ -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