b972a0940d
being edited in DrRacket (via places) Added an API to let tools have access to that information (and compute more stuff) Used that to make an online version of Check Syntax which led to a separately callable Check Syntax API.
777 lines
32 KiB
Racket
777 lines
32 KiB
Racket
#lang racket/unit
|
|
|
|
(require string-constants
|
|
mzlib/contract
|
|
"drsig.rkt"
|
|
mred
|
|
framework
|
|
mzlib/class
|
|
racket/list
|
|
racket/path
|
|
racket/file
|
|
racket/dict
|
|
browser/external
|
|
setup/plt-installer)
|
|
|
|
(import [prefix drracket:app: drracket:app^]
|
|
[prefix drracket:unit: drracket:unit^]
|
|
[prefix drracket:get/extend: drracket:get/extend^]
|
|
[prefix drracket:language-configuration: drracket:language-configuration/internal^]
|
|
[prefix drracket:language: drracket:language^]
|
|
[prefix drracket:module-language: drracket:module-language/int^]
|
|
[prefix drracket:tools: drracket:tools^]
|
|
[prefix drracket:debug: drracket:debug^]
|
|
[prefix drracket:frame: drracket:frame^]
|
|
[prefix drracket:font: drracket:font^]
|
|
[prefix drracket:modes: drracket:modes^]
|
|
[prefix drracket:help-desk: drracket:help-desk^]
|
|
[prefix drracket:multi-file-search: drracket:multi-file-search^])
|
|
(export)
|
|
|
|
(define (drr:set-default name val predicate)
|
|
(preferences:set-default
|
|
name val predicate
|
|
#:aliases (list (string->symbol (regexp-replace #rx"^drracket:" (symbol->string name) "drscheme:")))))
|
|
|
|
(when (eq? (system-type) 'unix)
|
|
(let ()
|
|
;; avoid building the mask unless we use it
|
|
(define todays-icon
|
|
(make-object bitmap%
|
|
(collection-file-path
|
|
(case (date-week-day (seconds->date (current-seconds)))
|
|
[(6 0) "plt-logo-red-shiny.png"]
|
|
[else "plt-logo-red-diffuse.png"])
|
|
"icons")
|
|
'png/mask))
|
|
|
|
(define todays-icon-bw-mask
|
|
(and (send todays-icon ok?)
|
|
(send todays-icon get-loaded-mask)
|
|
(let* ([w (send todays-icon get-width)]
|
|
[h (send todays-icon get-height)]
|
|
[bm (make-object bitmap% w h #t)]
|
|
[color-mask (send todays-icon get-loaded-mask)]
|
|
[src-bytes (make-bytes (* w h 4) 0)]
|
|
[dest-bits (make-bytes (* w h 4) 255)]
|
|
[bdc (make-object bitmap-dc% bm)]
|
|
[black (send the-color-database find-color "black")]
|
|
[white (send the-color-database find-color "white")])
|
|
(send color-mask get-argb-pixels 0 0 w h src-bytes #t)
|
|
(for ([i (in-range 0 w)])
|
|
(for ([j (in-range 0 h)])
|
|
(let ([b (= (bytes-ref src-bytes (* 4 (+ i (* j h)))) 0)])
|
|
(send bdc set-pixel i j (if b white black)))))
|
|
(send bdc set-bitmap #f)
|
|
bm)))
|
|
|
|
(send todays-icon set-loaded-mask todays-icon-bw-mask)
|
|
(frame:current-icon todays-icon)))
|
|
|
|
(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
|
|
(λ ()
|
|
(drracket:app:about-drscheme)))
|
|
|
|
(drracket:modes:add-initial-modes)
|
|
|
|
(finder:default-filters
|
|
`(["Racket Sources" "*.rkt;*.scrbl;*.rktl;*.rktd;*.ss;*.scm"]
|
|
,@(finder:default-filters)))
|
|
|
|
(application:current-app-name (string-constant drscheme))
|
|
|
|
(drr:set-default 'drracket:language-dialog:hierlist-default #f (λ (x) (or (not x) (and (list? x) (andmap string? x)))))
|
|
|
|
(drr:set-default 'drracket:create-executable-gui-type 'stand-alone (λ (x) (memq x '(launcher stand-alone distribution))))
|
|
(drr:set-default 'drracket:create-executable-gui-base 'racket (λ (x) (memq x '(racket gracket))))
|
|
|
|
(drr:set-default 'drracket:logger-gui-tab-panel-level 0 (λ (x) (and (exact-integer? x) (<= 0 x 5))))
|
|
|
|
(drr:set-default 'drracket:saved-bug-reports
|
|
'()
|
|
(λ (ll)
|
|
(and (list? ll)
|
|
(andmap
|
|
(λ (l)
|
|
(and (list? l)
|
|
(andmap (λ (x) (and (pair? x)
|
|
(symbol? (car x))
|
|
(string? (cdr x))))
|
|
l)))
|
|
ll))))
|
|
|
|
(drr:set-default 'drracket:module-language-first-line-special? #t boolean?)
|
|
|
|
(drr:set-default 'drracket:defns-popup-sort-by-name? #f boolean?)
|
|
(drr:set-default 'drracket:show-line-numbers? #f boolean?)
|
|
|
|
(drr:set-default 'drracket:toolbar-state
|
|
'(#f . top)
|
|
(λ (x) (and (pair? x)
|
|
(boolean? (car x))
|
|
(memq (cdr x) '(left top right)))))
|
|
|
|
(drr:set-default 'drracket:htdp:last-set-teachpacks
|
|
'()
|
|
(λ (x)
|
|
(and (list? x)
|
|
(andmap (λ (x)
|
|
(and (list? x)
|
|
(pair? x)
|
|
(eq? (car x) 'lib)
|
|
(andmap string? (cdr x))))
|
|
x))))
|
|
(drr:set-default 'drracket:defs/ints-horizontal #f boolean?)
|
|
|
|
(drr:set-default 'drracket:child-only-memory-limit (* 1024 1024 128)
|
|
(λ (x) (or (boolean? x)
|
|
(integer? x)
|
|
(x . >= . (* 1024 1024 1)))))
|
|
|
|
(drr:set-default 'drracket:recent-language-names
|
|
null
|
|
(λ (x)
|
|
(and (list? x)
|
|
(andmap
|
|
(λ (x)
|
|
(and (pair? x)
|
|
(string? (car x))))
|
|
x))))
|
|
(drr:set-default 'drracket:show-interactions-on-execute #t boolean?)
|
|
(drr:set-default 'drracket:open-in-tabs #f boolean?)
|
|
(drr:set-default 'drracket:toolbar-shown #t boolean?)
|
|
(drr:set-default 'drracket:user-defined-keybindings
|
|
'()
|
|
(λ (x) (and (list? x)
|
|
(andmap (λ (x) (or (path? x) (drracket:frame:planet-spec? x)))
|
|
x))))
|
|
(drr:set-default 'drracket:install-plt-dialog
|
|
'(#t "" "") ; url-selected?, url string, file string
|
|
(λ (x) (and (list? x) (= 3 (length x))
|
|
(boolean? (car x))
|
|
(andmap string? (cdr x)))))
|
|
|
|
(preferences:set-un/marshall
|
|
'drracket: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)))])
|
|
(drr:set-default 'drracket:unit-window-size-percentage
|
|
1/2
|
|
number-between-zero-and-one?)
|
|
(drr:set-default 'drracket:module-browser-size-percentage
|
|
1/5
|
|
number-between-zero-and-one?)
|
|
(drr:set-default 'drracket:logging-size-percentage
|
|
3/4
|
|
number-between-zero-and-one?))
|
|
|
|
(drr:set-default 'drracket:module-browser:name-length 1
|
|
(λ (x) (memq x '(0 1 2 3))))
|
|
|
|
(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))))
|
|
(frame:setup-size-pref 'drracket:unit-window-size
|
|
frame-width
|
|
frame-height
|
|
#:position-preferences
|
|
'drracket:unit-window-position))
|
|
|
|
(drr:set-default 'drracket:backtrace-window-width 400 number?)
|
|
(drr:set-default 'drracket:backtrace-window-height 300 number?)
|
|
(drr:set-default 'drracket:backtrace-window-x 0 number?)
|
|
(drr:set-default 'drracket:backtrace-window-y 0 number?)
|
|
|
|
(drr:set-default 'drracket:profile-how-to-count 'time
|
|
(λ (x)
|
|
(memq x '(time count))))
|
|
(drr:set-default 'drracket:profile:low-color
|
|
(make-object color% 150 255 150)
|
|
(λ (x) (is-a? x color%)))
|
|
(drr:set-default 'drracket:profile:high-color
|
|
(make-object color% 255 150 150)
|
|
(λ (x) (is-a? x color%)))
|
|
(drr:set-default 'drracket:profile:scale
|
|
'linear
|
|
(λ (x) (memq x '(sqrt linear square))))
|
|
|
|
(drr:set-default 'drracket:test-coverage-ask-about-clearing? #t boolean?)
|
|
|
|
;; size is in editor positions
|
|
(drr:set-default 'drracket: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
|
|
'drracket:profile:low-color
|
|
marshall-color
|
|
unmarshall-color)
|
|
(preferences:set-un/marshall
|
|
'drracket:profile:high-color
|
|
marshall-color
|
|
unmarshall-color))
|
|
|
|
(drr:set-default
|
|
'drracket:keybindings-window-size
|
|
(cons 400 600)
|
|
(λ (x) (and (pair? x)
|
|
(number? (car x))
|
|
(number? (cdr x)))))
|
|
|
|
(drr:set-default
|
|
'drracket:execute-warning-once
|
|
#f
|
|
(λ (x)
|
|
(or (eq? x #t)
|
|
(not x))))
|
|
|
|
(drr:set-default 'drracket:switch-to-module-language-automatically? #t boolean?)
|
|
|
|
(drr:set-default
|
|
'drracket:default-tools-configuration
|
|
'load
|
|
(lambda (p)
|
|
(memq p '(load skip))))
|
|
|
|
(drr:set-default
|
|
'drracket:tools-configuration
|
|
null
|
|
list?)
|
|
|
|
(drr:set-default 'drracket:module-overview:label-font-size 12 number?)
|
|
(drr:set-default 'drracket:module-overview:window-height 500 number?)
|
|
(drr:set-default 'drracket:module-overview:window-width 500 number?)
|
|
(drr:set-default 'drracket:module-browser:hide-paths '(lib)
|
|
(λ (x)
|
|
(and (list? x)
|
|
(andmap symbol? x))))
|
|
|
|
|
|
(drracket: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)
|
|
(preferences:add-general-checkbox-panel)
|
|
|
|
(let ([make-check-box
|
|
(λ (pref-sym string parent [extra-functionality #f])
|
|
(let ([q (make-object check-box%
|
|
string
|
|
parent
|
|
(λ (checkbox evt)
|
|
(define value (send checkbox get-value))
|
|
(preferences:set pref-sym value)
|
|
(when extra-functionality
|
|
(extra-functionality value))))])
|
|
(preferences:add-callback pref-sym (λ (p v) (send q set-value v)))
|
|
(send q set-value (preferences:get pref-sym))))])
|
|
(preferences:add-to-general-checkbox-panel
|
|
(λ (editor-panel)
|
|
(make-check-box 'drracket:open-in-tabs
|
|
(string-constant open-files-in-tabs)
|
|
editor-panel)
|
|
|
|
|
|
(make-check-box 'drracket:show-interactions-on-execute
|
|
(string-constant show-interactions-on-execute)
|
|
editor-panel)
|
|
|
|
(make-check-box 'drracket:switch-to-module-language-automatically?
|
|
(string-constant switch-to-module-language-automatically)
|
|
editor-panel)
|
|
|
|
(make-check-box 'drracket:defs/ints-horizontal
|
|
(string-constant interactions-beside-definitions)
|
|
editor-panel)
|
|
|
|
(make-check-box 'drracket:module-language-first-line-special?
|
|
(string-constant ml-always-show-#lang-line)
|
|
editor-panel)))
|
|
|
|
(preferences:add-to-editor-checkbox-panel
|
|
(λ (editor-panel)
|
|
(make-check-box 'drracket:show-line-numbers?
|
|
(string-constant show-line-numbers)
|
|
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 'drracket:repl-buffer-size
|
|
(cons (send cb get-value)
|
|
(cdr (preferences:get 'drracket:repl-buffer-size)))))]
|
|
[sl-callback
|
|
(λ ()
|
|
(preferences:set 'drracket:repl-buffer-size
|
|
(cons (car (preferences:get 'drracket: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 'drracket:repl-buffer-size (λ (p v) (update-controls v)))
|
|
(update-controls (preferences:get 'drracket:repl-buffer-size)))))
|
|
|
|
(preferences:add-to-warnings-checkbox-panel
|
|
(λ (warnings-panel)
|
|
(make-check-box 'drracket:execute-warning-once
|
|
(string-constant only-warn-once)
|
|
warnings-panel)
|
|
(make-check-box 'drracket:test-coverage-ask-about-clearing?
|
|
(string-constant test-coverage-ask?)
|
|
warnings-panel))))
|
|
(drracket:debug:add-prefs-panel)
|
|
(install-help-browser-preference-panel)
|
|
(drracket:tools:add-prefs-panel)
|
|
|
|
(drracket:language:register-capability 'drscheme:tabify-menu-callback
|
|
(or/c false/c (-> (is-a?/c text%) number? number? void?))
|
|
(λ (t a b) (send t tabify-selection a b)))
|
|
(drracket:language:register-capability 'drscheme:autocomplete-words (listof string?) '())
|
|
(drracket:language:register-capability 'drscheme:define-popup
|
|
(or/c (cons/c string? string?)
|
|
(list/c string? string? string?)
|
|
#f)
|
|
(list "(define" "(define ...)" "δ"))
|
|
|
|
;; The default is #f to keep whatever the user chose as their context.
|
|
;; If it's "", then we will kill the user's choice.
|
|
(drracket:language:register-capability 'drscheme:help-context-term
|
|
(or/c false/c string?)
|
|
#f)
|
|
|
|
(drracket:language:register-capability 'drscheme:special:insert-fraction (flat-contract boolean?) #t)
|
|
(drracket:language:register-capability 'drscheme:special:insert-large-letters (flat-contract boolean?) #t)
|
|
(drracket:language:register-capability 'drscheme:special:insert-lambda (flat-contract boolean?) #t)
|
|
(drracket:language:register-capability 'drscheme:special:insert-image (flat-contract boolean?) #t)
|
|
(drracket:language:register-capability 'drscheme:special:insert-comment-box (flat-contract boolean?) #t)
|
|
(drracket:language:register-capability 'drscheme:language-menu-title
|
|
(flat-contract string?)
|
|
(string-constant scheme-menu-name))
|
|
|
|
(drracket:language:register-capability 'drscheme:teachpack-menu-items
|
|
(or/c false/c (flat-contract drracket:unit:teachpack-callbacks?))
|
|
#f)
|
|
|
|
(handler:current-create-new-window
|
|
(let ([drscheme-current-create-new-window
|
|
(λ (filename)
|
|
(drracket: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)
|
|
drracket: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))
|
|
|
|
;; trim old console-previous-exprs preferences to compenstate
|
|
;; for a bug that let it grow without bound
|
|
(let* ([max-len 30]
|
|
[trim (λ (exprs save)
|
|
(when (list? exprs)
|
|
(let ([len (length exprs)])
|
|
(when (> len max-len)
|
|
(save (drop exprs (- len max-len)))))))])
|
|
(let ([framework-prefs (get-preference 'plt:framework-prefs #:timeout-lock-there (λ (x) #f))])
|
|
(when (and (list? framework-prefs)
|
|
(andmap pair? framework-prefs))
|
|
(let ([exprs-pref (assq 'drscheme:console-previous-exprs framework-prefs)])
|
|
(when exprs-pref
|
|
(trim (second exprs-pref)
|
|
(λ (trimmed)
|
|
(put-preferences (list 'plt:framework-prefs)
|
|
(list (dict-set framework-prefs 'drscheme:console-previous-exprs (list trimmed)))
|
|
void)))))))
|
|
(trim (get-preference 'plt:framework-pref:drscheme:console-previous-exprs #:timeout-lock-there (λ (x) #f))
|
|
(λ (trimmed)
|
|
(put-preferences (list 'plt:framework-pref:drscheme:console-previous-exprs)
|
|
(list trimmed)
|
|
void))))
|
|
|
|
(drracket:tools:load/invoke-all-tools
|
|
(λ () (void))
|
|
(λ ()
|
|
(drracket:language-configuration:add-built-in-languages)
|
|
(drracket:module-language:add-module-language)
|
|
(drracket:language-configuration:add-info-specified-languages)))
|
|
|
|
;; no more extension after this point
|
|
(drracket:get/extend:get-interactions-canvas)
|
|
(drracket:get/extend:get-definitions-canvas)
|
|
(drracket:get/extend:get-unit-frame)
|
|
(drracket:get/extend:get-interactions-text)
|
|
(drracket:get/extend:get-definitions-text)
|
|
(drracket:language-configuration:get-languages)
|
|
|
|
;; this default can only be set *after* the
|
|
;; languages have all be registered by tools
|
|
(drr:set-default
|
|
drracket:language-configuration:settings-preferences-symbol
|
|
(drracket:language-configuration:get-default-language-settings)
|
|
drracket: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.rkt file
|
|
;; of the default collection and may not be the default
|
|
;; specified above (of course).
|
|
(preferences:set-un/marshall
|
|
drracket:language-configuration:settings-preferences-symbol
|
|
(λ (x)
|
|
(let ([lang (drracket:language-configuration:language-settings-language x)]
|
|
[settings (drracket: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))
|
|
(drracket:language-configuration:get-languages))])
|
|
(and lang
|
|
(let ([settings (send lang unmarshall-settings marshalled-settings)])
|
|
(drracket:language-configuration:language-settings
|
|
lang
|
|
(or settings (send lang default-settings)))))))))
|
|
|
|
;; preferences initialization
|
|
|
|
(preferences:set-default 'drracket:online-compilation #t boolean?)
|
|
|
|
(drr:set-default 'drracket:multi-file-search:recur? #t boolean?)
|
|
(drr:set-default 'drracket:multi-file-search:filter? #t boolean?)
|
|
(drr:set-default 'drracket:multi-file-search:filter-regexp "\\.(rkt.?|scrbl|ss|scm)$" string?)
|
|
(drr:set-default 'drracket:multi-file-search:search-string "" string?)
|
|
(drr:set-default 'drracket:multi-file-search:search-type
|
|
1
|
|
(λ (x)
|
|
(and (number? x)
|
|
(exact? x)
|
|
(integer? x)
|
|
(<= 0 x)
|
|
(< x (length drracket:multi-file-search:search-types)))))
|
|
|
|
;; drracket:mult-file-search:search-check-boxes : (listof (listof boolean))
|
|
(drr:set-default 'drracket:multi-file-search:search-check-boxes
|
|
(map (λ (x) (map cdr (drracket:multi-file-search:search-type-params x)))
|
|
drracket:multi-file-search:search-types)
|
|
(λ (x)
|
|
(and (list? x)
|
|
(andmap (λ (x)
|
|
(and (list? x)
|
|
(andmap boolean? x)))
|
|
x))))
|
|
|
|
(drr:set-default 'drracket:multi-file-search:percentages
|
|
'(1/3 2/3)
|
|
(λ (x) (and (list? x)
|
|
(= 2 (length x))
|
|
(= 1 (apply + x)))))
|
|
|
|
(drr:set-default 'drracket:multi-file-search:frame-size '(300 . 400)
|
|
(λ (x) (and (pair? x)
|
|
(number? (car x))
|
|
(number? (cdr x)))))
|
|
(drr:set-default 'drracket:multi-file-search:directory
|
|
;; The default is #f because
|
|
;; filesystem-root-list is expensive under Windows
|
|
#f
|
|
(lambda (x) (or (not x) (path? x))))
|
|
(preferences:set-un/marshall
|
|
'drracket:multi-file-search:directory
|
|
(λ (v) (and v (path->string v)))
|
|
(λ (p) (if (path-string? p)
|
|
(string->path p)
|
|
#f)))
|
|
|
|
(drr:set-default 'drracket:large-letters-font #f (λ (x)
|
|
(or (and (pair? x)
|
|
(string? (car x))
|
|
(let ([i (cdr x)])
|
|
(and (integer? i)
|
|
(<= 1 i 255))))
|
|
(not x))))
|
|
|
|
(let ([drs-handler-recent-items-super%
|
|
(class (drracket: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?)
|
|
(drracket:frame:create-root-menubar)
|
|
(preferences:set 'framework:exit-when-no-frames #f)]
|
|
[else
|
|
(preferences:set 'framework:exit-when-no-frames #t)])
|
|
|
|
|
|
(define repl-error-pref 'drracket:read-eval-print-loop:error-color)
|
|
(define repl-out-pref 'drracket:read-eval-print-loop:out-color)
|
|
(define repl-value-pref 'drracket: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))))
|
|
|
|
|
|
(define test-coverage-on-style-pref (string->symbol drracket:debug:test-coverage-on-style-name))
|
|
(define test-coverage-off-style-pref (string->symbol drracket:debug:test-coverage-off-style-name))
|
|
|
|
(color-prefs:register-color-preference test-coverage-on-style-pref
|
|
drracket:debug:test-coverage-on-style-name
|
|
(send the-color-database find-color "forest green"))
|
|
(color-prefs:register-color-preference test-coverage-off-style-pref
|
|
drracket:debug:test-coverage-off-style-name
|
|
(send the-color-database find-color "maroon"))
|
|
(color-prefs:add-to-preferences-panel
|
|
"Module Language"
|
|
(λ (parent)
|
|
(color-prefs:build-color-selection-panel parent
|
|
test-coverage-on-style-pref
|
|
drracket:debug:test-coverage-on-style-name
|
|
(string-constant test-coverage-on))
|
|
(color-prefs:build-color-selection-panel parent
|
|
test-coverage-off-style-pref
|
|
drracket:debug:test-coverage-off-style-name
|
|
(string-constant test-coverage-off))))
|
|
|
|
|
|
|
|
(let* ([find-frame
|
|
(λ (item)
|
|
(let loop ([item item])
|
|
(cond
|
|
[(is-a? item top-level-window<%>)
|
|
(and (is-a? item drracket:unit:frame%)
|
|
item)]
|
|
[(is-a? item menu-item<%>)
|
|
(loop (send item get-parent))]
|
|
[(is-a? item menu-bar%)
|
|
(loop (send item get-frame))]
|
|
[else #f])))]
|
|
[dc
|
|
(λ (item)
|
|
(let ([frame (find-frame item)])
|
|
(send item enable (and frame (> (length (send frame get-tabs)) 1)))))])
|
|
(group:add-to-windows-menu
|
|
(λ (windows-menu)
|
|
(define sprefix (if (eq? (system-type) 'windows)
|
|
(cons 'shift (get-default-shortcut-prefix))
|
|
(get-default-shortcut-prefix)))
|
|
(new menu-item%
|
|
[parent windows-menu]
|
|
[label (string-constant prev-tab)]
|
|
[shortcut #\[]
|
|
[shortcut-prefix sprefix]
|
|
[demand-callback dc]
|
|
[callback (λ (item _)
|
|
(let ([frame (find-frame item)])
|
|
(when frame
|
|
(send frame prev-tab))))])
|
|
(new menu-item%
|
|
[parent windows-menu]
|
|
[label (string-constant next-tab)]
|
|
[shortcut #\]]
|
|
[shortcut-prefix sprefix]
|
|
[demand-callback dc]
|
|
[callback (λ (item _)
|
|
(let ([frame (find-frame item)])
|
|
(when frame
|
|
(send frame next-tab))))])
|
|
|
|
(let ([frame (find-frame windows-menu)])
|
|
(unless (or (not frame) (= 1 (send frame get-tab-count)))
|
|
(unless (eq? (system-type) 'macosx)
|
|
(new separator-menu-item% [parent windows-menu]))
|
|
(for ([i (in-range 0 (send frame get-tab-count))]
|
|
#:when (< i 9))
|
|
(new menu-item%
|
|
[parent windows-menu]
|
|
[label (format (string-constant tab-i)
|
|
(+ i 1)
|
|
(send frame get-tab-filename i))]
|
|
[shortcut (integer->char (+ (char->integer #\1) i))]
|
|
[callback
|
|
(λ (a b)
|
|
(send frame change-to-nth-tab i))]))))
|
|
|
|
(when (eq? (system-type) 'macosx)
|
|
(new separator-menu-item% [parent windows-menu])))))
|
|
|
|
;; 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 drracket:frame:add-keybindings-item
|
|
(preferences:get 'drracket:user-defined-keybindings))
|
|
|
|
;; the initial window doesn't set the
|
|
;; unit object's state correctly, yet.
|
|
(define (make-basic)
|
|
(let* ([frame (drracket: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)))
|
|
|
|
;; FIXME: get this from racket/list ?
|
|
(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.rkt 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 'drracket: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
|
|
(λ () (drracket:unit:open-drscheme-window f))))
|
|
no-dups)])
|
|
(when (null? (filter (λ (x) x) frames))
|
|
(make-basic))
|
|
(when (and (preferences:get 'drracket:open-in-tabs)
|
|
(not (null? no-dups)))
|
|
(handler:edit-file (car no-dups))))
|