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

Adjust DrRacket to better support #lang-line specific

Browse Source 
keybindings and then use that to add in an esc;q keybinding
for scribble
This commit is contained in:
Robby Findler 2014-02-24 21:11:33 -06:00
parent e7434e1997
commit 58e7d033f7
10 changed files with 265 additions and 189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/drracket-pkgs/drracket-plugin-lib/drracket/private/drsig.rkt
View File

@ -111,7 +111,8 @@
change-lang-surrogate-mixin change-lang-surrogate-mixin
default-surrogate% default-surrogate%
change-lang-host-mixin)) modes<%>
modes-mixin))
(define-signature drracket:module-language-tools-cm^ (define-signature drracket:module-language-tools-cm^
(frame-mixin (frame-mixin

153
pkgs/drracket-pkgs/drracket/drracket/private/get-extend.rkt
View File

@ -17,65 +17,63 @@
(define (allow-re-extension!) (set! re-extension-allowed? #t)) (define (allow-re-extension!) (set! re-extension-allowed? #t))
(define (disallow-re-extension!) (set! re-extension-allowed? #f)) (define (disallow-re-extension!) (set! re-extension-allowed? #f))
(define make-extender (define (make-extender get-base% name [final-mixin values])
(λ (get-base% name [final-mixin values]) (define extend-name (string->symbol (format "extend-~a" name)))
(define extend-name (string->symbol (format "extend-~a" name))) (define names-for-changes '())
(let ([names-for-changes '()] (define extensions '())
[extensions '()] (define built-yet? #f)
[built-yet? #f] (define built #f)
[built #f] (define ((verify f) %)
[verify (define new% (f %))
(λ (f) (if (and (class? new%)
(λ (%) (subclass? new% %))
(let ([new% (f %)]) new%
(if (and (class? new%) (error extend-name
(subclass? new% %)) "expected output of extension to create a subclass of its input, got: ~a"
new% new%)))
(error extend-name "expected output of extension to create a subclass of its input, got: ~a" (define (add-extender extension [before? #t] #:name-for-changes [name-for-changes #f])
new%)))))]) (cond
(define (add-extender extension [before? #t] #:name-for-changes [name-for-changes #f]) [(and (symbol? name-for-changes) (member name-for-changes names-for-changes))
(cond (cond
[(and (symbol? name-for-changes) (member name-for-changes names-for-changes)) [re-extension-allowed?
(cond (set! extensions
[re-extension-allowed? (for/list ([e-extension (in-list extensions)]
(set! extensions [e-name (in-list names-for-changes)])
(for/list ([e-extension (in-list extensions)] (if (equal? e-name name-for-changes)
[e-name (in-list names-for-changes)]) extension
(if (equal? e-name name-for-changes) e-extension)))
extension (set! built-yet? #f)
e-extension))) (set! built #f)]
(set! built-yet? #f) [else
(set! built #f)] (error extend-name
[else "attempted to use name ~s multiple times without first enabling re-extensions"
(error extend-name name-for-changes)])]
"attempted to use name ~s multiple times without first enabling re-extensions" [else
name-for-changes)])] (when built-yet?
[else (cond
(when built-yet? [re-extension-allowed?
(cond (set! built-yet? #f)
[re-extension-allowed? (set! built #f)]
(set! built-yet? #f) [else
(set! built #f)] (error extend-name
[else "cannot build a new extension of ~a after initialization"
(error extend-name name-for-changes)]))
"cannot build a new extension of ~a after initialization" (set! extensions
name-for-changes)])) (if before?
(set! extensions (cons (verify extension) extensions)
(if before? (append extensions (list (verify extension)))))
(cons (verify extension) extensions) (set! names-for-changes
(append extensions (list (verify extension))))) (if before?
(set! names-for-changes (cons name-for-changes names-for-changes)
(if before? (append names-for-changes (list name-for-changes))))]))
(cons name-for-changes names-for-changes) (define (get-built)
(append names-for-changes (list name-for-changes))))])) (unless built-yet?
(define (get-built) (set! built-yet? #t)
(unless built-yet? (set! built (final-mixin ((apply compose extensions) (get-base%)))))
(set! built-yet? #t) built)
(set! built (final-mixin ((apply compose extensions) (get-base%))))) (values
built) (procedure-rename add-extender extend-name)
(values (procedure-rename get-built (string->symbol (format "get-~a" name)))))
(procedure-rename add-extender extend-name)
(procedure-rename get-built (string->symbol (format "get-~a" name)))))))
(define (get-base-tab%) (define (get-base-tab%)
(drracket:module-language:module-language-online-expand-tab-mixin (drracket:module-language:module-language-online-expand-tab-mixin
@ -118,23 +116,26 @@
(make-extender get-base-interactions-text% 'interactions-text%)) (make-extender get-base-interactions-text% 'interactions-text%))
(define (get-base-definitions-text%) (define (get-base-definitions-text%)
(drracket:module-language:change-lang-host-mixin (drracket:module-language:module-language-online-expand-text-mixin
(drracket:module-language:module-language-online-expand-text-mixin (drracket:module-language-tools:definitions-text-mixin
(drracket:module-language-tools:definitions-text-mixin (drracket:module-language:module-language-big-defs/ints-definitions-text-mixin
(drracket:module-language:module-language-big-defs/ints-definitions-text-mixin (drracket:debug:test-coverage-definitions-text-mixin
(drracket:debug:test-coverage-definitions-text-mixin (drracket:debug:profile-definitions-text-mixin
(drracket:debug:profile-definitions-text-mixin (drracket:module-language:modes-mixin
(drracket:unit:get-definitions-text%)))))))) (drracket:unit:get-definitions-text%))))))))
(define-values (extend-definitions-text get-definitions-text) (define-values (extend-definitions-text get-definitions-text)
(make-extender get-base-definitions-text% (make-extender
'definitions-text% get-base-definitions-text%
(let ([add-on-paint-logging 'definitions-text%
(λ (%) (let ([add-on-paint-logging
(class % (λ (%)
(define/override (on-paint before? dc left top right bottom dx dy draw-caret) (class %
(log-timeline (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(format "on-paint method of ~a area: ~a" (object-name this) (* (- right left) (- bottom top))) (log-timeline
(super on-paint before? dc left top right bottom dx dy draw-caret))) (format "on-paint method of ~a area: ~a"
(super-new)))]) (object-name this)
add-on-paint-logging))) (* (- right left) (- bottom top)))
(super on-paint before? dc left top right bottom dx dy draw-caret)))
(super-new)))])
add-on-paint-logging)))

6
pkgs/drracket-pkgs/drracket/drracket/private/local-member-names.rkt
View File

@ -54,6 +54,12 @@
set-dep-paths set-dep-paths
set-dirty-if-dep) set-dirty-if-dep)
;; mode changing definitions text mixin
(define-local-member-name
maybe-change-language
change-mode-to-match)
(provide (struct-out drracket:language-configuration:language-settings)) (provide (struct-out drracket:language-configuration:language-settings))
;; type language-settings = (language-settings (instanceof language<%>) settings) ;; type language-settings = (language-settings (instanceof language<%>) settings)
(define-struct drracket:language-configuration:language-settings (language settings)) (define-struct drracket:language-configuration:language-settings (language settings))

7
pkgs/drracket-pkgs/drracket/drracket/private/modes.rkt
View File

@ -27,6 +27,13 @@
surrogate surrogate
repl-submit repl-submit
matches-language)]) matches-language)])
(for ([old-mode (in-list modes)])
(when (equal? (mode-name old-mode) name)
(raise-argument-error
'drracket:modes:add-mode
"name that is not already used by any other mode"
0
name surrogate repl-submit matches-language)))
(set! modes (cons new-mode modes)) (set! modes (cons new-mode modes))
new-mode)) new-mode))

63
pkgs/drracket-pkgs/drracket/drracket/private/module-language.rkt
View File

@ -91,6 +91,7 @@
[prefix drracket:rep: drracket:rep^] [prefix drracket:rep: drracket:rep^]
[prefix drracket:init: drracket:init^] [prefix drracket:init: drracket:init^]
[prefix drracket:module-language-tools: drracket:module-language-tools/int^] [prefix drracket:module-language-tools: drracket:module-language-tools/int^]
[prefix drracket:modes: drracket:modes^]
[prefix drracket: drracket:interface^]) [prefix drracket: drracket:interface^])
(export drracket:module-language/int^) (export drracket:module-language/int^)
@ -2595,15 +2596,60 @@
#:when v) #:when v)
v)) v))
(define modes<%> (interface ()
maybe-change-language
change-mode-to-match))
(define modes-mixin
(mixin ((class->interface text%)
mode:host-text<%>
drracket:unit:definitions-text<%>)
(modes<%>)
(define-local-member-name maybe-change-language) (inherit get-surrogate set-surrogate
get-next-settings get-tab)
(define change-lang-host<%> (interface () maybe-change-language)) (define/augment (after-set-next-settings next-settings)
(change-mode-to-match)
(inner (void) after-set-next-settings next-settings))
(define change-lang-host-mixin (define current-mode #f)
(mixin ((class->interface text%) mode:host-text<%>) (change-lang-host<%>)
(inherit set-surrogate) (define/public (set-current-mode mode)
(set! current-mode mode)
(define surrogate (drracket:modes:mode-surrogate mode))
(cond
[(is-a? surrogate default-surrogate%)
(update-surrogate)]
[else
(set-surrogate surrogate)])
(define interactions-text (send (get-tab) get-ints))
(when interactions-text
(send interactions-text set-surrogate surrogate)
(send interactions-text set-submit-predicate
(drracket:modes:mode-repl-submit mode))))
(define/public (is-current-mode? mode)
(and current-mode
(equal? (drracket:modes:mode-name current-mode)
(drracket:modes:mode-name mode))))
(define/public (change-mode-to-match)
(let* ([language-settings (get-next-settings)]
[language-name
(and language-settings
(send (drracket:language-configuration:language-settings-language
language-settings)
get-language-position))])
(let loop ([modes (drracket:modes:get-modes)])
(cond
[(null? modes) (error 'change-mode-to-match
"didn't find a matching mode")]
[else (let ([mode (car modes)])
(if ((drracket:modes:mode-matches-language mode) language-name)
(unless (is-current-mode? mode)
(set-current-mode mode))
(loop (cdr modes))))]))))
(define current-surrogate-mod #f) (define current-surrogate-mod #f)
(define current-language-end #f) (define current-language-end #f)
@ -2628,7 +2674,8 @@
(and get-info (and get-info
(get-info 'definitions-text-surrogate #f))) (get-info 'definitions-text-surrogate #f)))
(set! current-language-end pos) (set! current-language-end pos)
(unless (equal? current-surrogate-mod new-surrogate-mod) (unless (and current-surrogate-mod
(equal? current-surrogate-mod new-surrogate-mod))
(set! current-surrogate-mod new-surrogate-mod) (set! current-surrogate-mod new-surrogate-mod)
(define new-surrogate (define new-surrogate
(and new-surrogate-mod (and new-surrogate-mod
@ -2651,12 +2698,12 @@
(mixin (mode:surrogate-text<%>) () (mixin (mode:surrogate-text<%>) ()
(define/override (after-insert ths supr start len) (define/override (after-insert ths supr start len)
(super after-insert ths supr start len) (super after-insert ths supr start len)
(when (is-a? ths change-lang-host<%>) (when (is-a? ths modes<%>)
(send ths maybe-change-language start))) (send ths maybe-change-language start)))
(define/override (after-delete ths supr start len) (define/override (after-delete ths supr start len)
(super after-delete ths supr start len) (super after-delete ths supr start len)
(when (is-a? ths change-lang-host<%>) (when (is-a? ths modes<%>)
(send ths maybe-change-language start))) (send ths maybe-change-language start)))
(super-new))) (super-new)))

160
pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt
View File

@ -217,7 +217,7 @@
(let ([ext (filename-extension fn)]) (let ([ext (filename-extension fn)])
(and ext (and ext
(let ([sym (string->symbol (bytes->string/utf-8 ext))]) (let ([sym (string->symbol (bytes->string/utf-8 ext))])
(ormap (λ (pr) (and (eq? sym (car pr)) (cadr pr))) (ormap (λ (pr) (and (equal? sym (car pr)) (cadr pr)))
allowed-extensions))))) allowed-extensions)))))
(define allowed-extensions '((png png) (define allowed-extensions '((png png)
@ -253,11 +253,11 @@
(define tokens (get-tokens start end)) (define tokens (get-tokens start end))
(for/or ([tok tokens]) (for/or ([tok tokens])
(define type (list-ref tok 0)) (define type (list-ref tok 0))
(cond [(or (eq? type 'symbol) (cond [(or (equal? type 'symbol)
(eq? type 'hash-colon-keyword) (equal? type 'hash-colon-keyword)
;; The token may have been categorized as a keyword due to ;; The token may have been categorized as a keyword due to
;; its presence in the tabification preferences: ;; its presence in the tabification preferences:
(eq? type 'keyword)) (equal? type 'keyword))
tok] tok]
[else [else
#f]))) #f])))
@ -538,8 +538,8 @@
text:info%))))))))))))]) text:info%))))))))))))])
((get-program-editor-mixin) ((get-program-editor-mixin)
(class* definitions-super% (drracket:unit:definitions-text<%>) (class* definitions-super% (drracket:unit:definitions-text<%>)
(inherit get-top-level-window is-locked? lock while-unlocked highlight-first-line (inherit get-top-level-window is-locked? lock while-unlocked
is-printing?) highlight-first-line is-printing?)
(define interactions-text #f) (define interactions-text #f)
(define/public (set-interactions-text it) (define/public (set-interactions-text it)
@ -549,36 +549,6 @@
(define/public (get-tab) tab) (define/public (get-tab) tab)
(define/public (set-tab t) (set! tab t)) (define/public (set-tab t) (set! tab t))
(inherit get-surrogate set-surrogate)
(define/public (set-current-mode mode)
(let ([surrogate (drracket:modes:mode-surrogate mode)])
(set-surrogate surrogate)
(when interactions-text
(send interactions-text set-surrogate surrogate)
(send interactions-text set-submit-predicate
(drracket:modes:mode-repl-submit mode)))))
(define/public (is-current-mode? mode)
(let ([surrogate (drracket:modes:mode-surrogate mode)])
(eq? surrogate (get-surrogate))))
(define/public (change-mode-to-match)
(let* ([language-settings (get-next-settings)]
[language-name
(and language-settings
(send (drracket:language-configuration:language-settings-language
language-settings)
get-language-position))])
(let loop ([modes (drracket:modes:get-modes)])
(cond
[(null? modes) (error 'change-mode-to-match
"didn't find a matching mode")]
[else (let ([mode (car modes)])
(if ((drracket:modes:mode-matches-language mode) language-name)
(unless (is-current-mode? mode)
(set-current-mode mode))
(loop (cdr modes))))]))))
(inherit begin-edit-sequence end-edit-sequence (inherit begin-edit-sequence end-edit-sequence
delete insert last-position paragraph-start-position delete insert last-position paragraph-start-position
get-character) get-character)
@ -729,7 +699,6 @@
get-reader-module)) get-reader-module))
(set-modified #t)) (set-modified #t))
(set! next-settings _next-settings) (set! next-settings _next-settings)
(change-mode-to-match)
(let ([f (get-top-level-window)]) (let ([f (get-top-level-window)])
(when (and f (when (and f
(is-a? f drracket:unit:frame<%>)) (is-a? f drracket:unit:frame<%>))
@ -968,8 +937,10 @@
(let ([prefs-setting (preferences:get (let ([prefs-setting (preferences:get
drracket:language-configuration:settings-preferences-symbol)]) drracket:language-configuration:settings-preferences-symbol)])
(cond (cond
[(eq? (drracket:language-configuration:language-settings-language prefs-setting) [(and module-language
module-language) (object=? (drracket:language-configuration:language-settings-language
prefs-setting)
module-language))
(drracket:language-configuration:language-settings-settings prefs-setting)] (drracket:language-configuration:language-settings-settings prefs-setting)]
[else [else
(and module-language (and module-language
@ -1346,7 +1317,7 @@
(set! running? b?) (set! running? b?)
(send frame update-running b?)) (send frame update-running b?))
(define/public-final (is-current-tab?) (eq? this (send frame get-current-tab))) (define/public-final (is-current-tab?) (object=? this (send frame get-current-tab)))
(define log-visible? #f) (define log-visible? #f)
(define/public-final (toggle-log) (define/public-final (toggle-log)
@ -1845,9 +1816,9 @@
'(yes-no) '(yes-no)
#:dialog-mixin frame:focus-table-mixin)]) #:dialog-mixin frame:focus-table-mixin)])
(cond (cond
[(eq? query 'no) [(equal? query 'no)
#f] #f]
[(eq? query 'yes) [(equal? query 'yes)
(with-handlers ([exn:fail:filesystem? (with-handlers ([exn:fail:filesystem?
(λ (exn) (λ (exn)
(message-box (message-box
@ -1965,20 +1936,20 @@
(car (preferences:get 'drracket:toolbar-state))) (car (preferences:get 'drracket:toolbar-state)))
(define/private (toolbar-is-top?) (define/private (toolbar-is-top?)
(and (not (toolbar-is-hidden?)) (and (not (toolbar-is-hidden?))
(eq? (cdr (preferences:get 'drracket:toolbar-state)) (equal? (cdr (preferences:get 'drracket:toolbar-state))
'top))) 'top)))
(define/private (toolbar-is-right?) (define/private (toolbar-is-right?)
(and (not (toolbar-is-hidden?)) (and (not (toolbar-is-hidden?))
(eq? (cdr (preferences:get 'drracket:toolbar-state)) (equal? (cdr (preferences:get 'drracket:toolbar-state))
'right))) 'right)))
(define/private (toolbar-is-left?) (define/private (toolbar-is-left?)
(and (not (toolbar-is-hidden?)) (and (not (toolbar-is-hidden?))
(eq? (cdr (preferences:get 'drracket:toolbar-state)) (equal? (cdr (preferences:get 'drracket:toolbar-state))
'left))) 'left)))
(define/private (toolbar-is-top-no-label?) (define/private (toolbar-is-top-no-label?)
(and (not (toolbar-is-hidden?)) (and (not (toolbar-is-hidden?))
(eq? (cdr (preferences:get 'drracket:toolbar-state)) (equal? (cdr (preferences:get 'drracket:toolbar-state))
'top-no-label))) 'top-no-label)))
(define/private (orient/show bar-at-beginning?) (define/private (orient/show bar-at-beginning?)
(let ([vertical? (or (toolbar-is-left?) (toolbar-is-right?))]) (let ([vertical? (or (toolbar-is-left?) (toolbar-is-right?))])
@ -2176,7 +2147,7 @@
(define was-locked? #f) (define was-locked? #f)
(define/public-final (disable-evaluation-in-tab tab) (define/public-final (disable-evaluation-in-tab tab)
(when (eq? tab current-tab) (when (object=? tab current-tab)
(disable-evaluation))) (disable-evaluation)))
(define/pubment (disable-evaluation) (define/pubment (disable-evaluation)
@ -2186,7 +2157,7 @@
(inner (void) disable-evaluation)) (inner (void) disable-evaluation))
(define/public-final (enable-evaluation-in-tab tab) (define/public-final (enable-evaluation-in-tab tab)
(when (eq? tab current-tab) (when (object=? tab current-tab)
(enable-evaluation))) (enable-evaluation)))
(define/pubment (enable-evaluation) (define/pubment (enable-evaluation)
@ -2201,7 +2172,7 @@
(let ([mod? (send definitions-text is-modified?)]) (let ([mod? (send definitions-text is-modified?)])
(modified mod?) (modified mod?)
(if save-button (if save-button
(unless (eq? mod? (send save-button is-shown?)) (unless (equal? mod? (send save-button is-shown?))
(send save-button show mod?)) (send save-button show mod?))
(set! save-init-shown? mod?)) (set! save-init-shown? mod?))
(update-tab-label current-tab))) (update-tab-label current-tab)))
@ -2265,7 +2236,7 @@
(define tab-index (define tab-index
(for/or ([i (in-list tabs)] (for/or ([i (in-list tabs)]
[n (in-naturals 1)]) [n (in-naturals 1)])
(and (eq? i tab) n))) (and (object=? i tab) n)))
(define i-prefix (define i-prefix
(cond (cond
[(not tab-index) ""] [(not tab-index) ""]
@ -2350,11 +2321,11 @@
(toggle-show/hide-definitions) (toggle-show/hide-definitions)
(update-shown))) (update-shown)))
(define/public (ensure-rep-shown rep) (define/public (ensure-rep-shown rep)
(unless (eq? rep interactions-text) (unless (object=? rep interactions-text)
(let loop ([tabs tabs]) (let loop ([tabs tabs])
(unless (null? tabs) (unless (null? tabs)
(let ([tab (car tabs)]) (let ([tab (car tabs)])
(if (eq? (send tab get-ints) rep) (if (object=? (send tab get-ints) rep)
(change-to-tab tab) (change-to-tab tab)
(loop (cdr tabs))))))) (loop (cdr tabs)))))))
(unless interactions-shown? (unless interactions-shown?
@ -2427,23 +2398,22 @@
(define/private (add-modes-submenu edit-menu) (define/private (add-modes-submenu edit-menu)
(new menu% (new menu%
(parent edit-menu) [parent edit-menu]
(label (string-constant mode-submenu-label)) [label (string-constant mode-submenu-label)]
(demand-callback [demand-callback
(λ (menu) (λ (menu)
(for-each (λ (item) (send item delete)) (for ([item (in-list (send menu get-items))])
(send menu get-items)) (send item delete))
(for-each (λ (mode) (for ([mode (in-list (drracket:modes:get-modes))])
(let* ([item (define item
(new checkable-menu-item% (new checkable-menu-item%
(label (drracket:modes:mode-name mode)) (label (drracket:modes:mode-name mode))
(parent menu) (parent menu)
(callback (callback
(λ (_1 _2) (send definitions-text set-current-mode (λ (_1 _2) (send definitions-text set-current-mode
mode))))]) mode)))))
(when (send definitions-text is-current-mode? mode) (when (send definitions-text is-current-mode? mode)
(send item check #t)))) (send item check #t))))]))
(drracket:modes:get-modes))))))
@ -2507,7 +2477,7 @@
[(null? canvases) (error 'split "couldn't split; didn't find canvas")] [(null? canvases) (error 'split "couldn't split; didn't find canvas")]
[else [else
(let ([canvas (car canvases)]) (let ([canvas (car canvases)])
(if (eq? canvas canvas-to-be-split) (if (object=? canvas canvas-to-be-split)
(list* new-canvas (list* new-canvas
canvas canvas
(cdr canvases)) (cdr canvases))
@ -2529,7 +2499,7 @@
orig-percentages orig-percentages
(send resizable-panel get-children))] (send resizable-panel get-children))]
[else (let ([canvas (car canvases)]) [else (let ([canvas (car canvases)])
(if (eq? canvas-to-be-split canvas) (if (object=? canvas-to-be-split canvas)
(list* (/ (car percentages) 2) (list* (/ (car percentages) 2)
(/ (car percentages) 2) (/ (car percentages) 2)
(cdr percentages)) (cdr percentages))
@ -2649,7 +2619,7 @@
(let* ([old-percentages (send resizable-panel get-percentages)] (let* ([old-percentages (send resizable-panel get-percentages)]
[soon-to-be-bigger-canvas #f] [soon-to-be-bigger-canvas #f]
[percentages [percentages
(if (eq? (car (get-canvases)) target) (if (and target (object=? (car (get-canvases)) target))
(begin (begin
(set! soon-to-be-bigger-canvas (cadr (get-canvases))) (set! soon-to-be-bigger-canvas (cadr (get-canvases)))
(cons (+ (car old-percentages) (cons (+ (car old-percentages)
@ -2665,7 +2635,7 @@
[(null? percentages) [(null? percentages)
(error 'collapse "internal error.2")] (error 'collapse "internal error.2")]
[else [else
(if (eq? (car canvases) target) (if (and target (object=? (car canvases) target))
(begin (begin
(set! soon-to-be-bigger-canvas prev-canvas) (set! soon-to-be-bigger-canvas prev-canvas)
(cons (+ (car percentages) (cons (+ (car percentages)
@ -2740,7 +2710,8 @@
(define (immediate child) (define (immediate child)
(let loop ([child child]) (let loop ([child child])
(define immediate-parent (send child get-parent)) (define immediate-parent (send child get-parent))
(if (eq? immediate-parent parent) (if (and immediate-parent
(object=? immediate-parent parent))
child child
(loop immediate-parent)))) (loop immediate-parent))))
(for/list ([child children]) (for/list ([child children])
@ -2829,7 +2800,7 @@
(define/augment (can-close?) (define/augment (can-close?)
(and (andmap (lambda (tab) (and (andmap (lambda (tab)
(or (eq? tab current-tab) (or (object=? tab current-tab)
(and (send (send tab get-defs) can-close?) (and (send (send tab get-defs) can-close?)
(send (send tab get-ints) can-close?)))) (send (send tab get-ints) can-close?))))
tabs) tabs)
@ -2838,11 +2809,11 @@
(define/augment (on-close) (define/augment (on-close)
(inner (void) on-close) (inner (void) on-close)
(for-each (lambda (tab) (for-each (lambda (tab)
(unless (eq? tab current-tab) (unless (object=? tab current-tab)
(send (send tab get-defs) on-close) (send (send tab get-defs) on-close)
(send (send tab get-ints) on-close))) (send (send tab get-ints) on-close)))
tabs) tabs)
(when (eq? this newest-frame) (when (object=? this newest-frame)
(set! newest-frame #f)) (set! newest-frame #f))
(when transcript (when transcript
(stop-transcript)) (stop-transcript))
@ -2994,7 +2965,7 @@
;; to be the nth tab. Also updates the GUI to show the new tab ;; to be the nth tab. Also updates the GUI to show the new tab
(inherit begin-container-sequence end-container-sequence) (inherit begin-container-sequence end-container-sequence)
(define/public (change-to-tab tab) (define/public (change-to-tab tab)
(unless (eq? current-tab tab) (unless (object=? current-tab tab)
(let ([old-tab current-tab]) (let ([old-tab current-tab])
(save-visible-tab-regions) (save-visible-tab-regions)
(set! current-tab tab) (set! current-tab tab)
@ -3016,7 +2987,8 @@
(send definitions-text update-frame-filename) (send definitions-text update-frame-filename)
(update-running (send current-tab is-running?)) (update-running (send current-tab is-running?))
(when (eq? this (get-top-level-focus-window)) (when (let ([tlw (get-top-level-focus-window)])
(and tlw (object=? this tlw)))
(send current-tab touched)) (send current-tab touched))
(on-tab-change old-tab current-tab) (on-tab-change old-tab current-tab)
(send tab update-log) (send tab update-log)
@ -3043,7 +3015,7 @@
(define/pubment (on-tab-change from-tab to-tab) (define/pubment (on-tab-change from-tab to-tab)
(let ([old-enabled (send from-tab get-enabled)] (let ([old-enabled (send from-tab get-enabled)]
[new-enabled (send to-tab get-enabled)]) [new-enabled (send to-tab get-enabled)])
(unless (eq? old-enabled new-enabled) (unless (object=? old-enabled new-enabled)
(if new-enabled (if new-enabled
(enable-evaluation) (enable-evaluation)
(disable-evaluation)))) (disable-evaluation))))
@ -3111,7 +3083,7 @@
[(null? l-tabs) (error 'close-current-tab "uh oh.3")] [(null? l-tabs) (error 'close-current-tab "uh oh.3")]
[else [else
(let ([tab (car l-tabs)]) (let ([tab (car l-tabs)])
(if (eq? tab current-tab) (if (object=? tab current-tab)
(when (close-tab tab) (when (close-tab tab)
(for-each (lambda (t) (send t set-i (- (send t get-i) 1))) (for-each (lambda (t) (send t set-i (- (send t get-i) 1)))
(cdr l-tabs)) (cdr l-tabs))
@ -3271,7 +3243,7 @@
(define/private (update-close-menu-item-shortcut item) (define/private (update-close-menu-item-shortcut item)
(cond (cond
[(eq? (system-type) 'unix) [(equal? (system-type) 'unix)
(send item set-label (string-constant close-menu-item))] (send item set-label (string-constant close-menu-item))]
[else [else
(define just-one? (and (pair? tabs) (null? (cdr tabs)))) (define just-one? (and (pair? tabs) (null? (cdr tabs))))
@ -3285,7 +3257,7 @@
(define/override (file-menu:close-callback item control) (define/override (file-menu:close-callback item control)
(define just-one? (and (pair? tabs) (null? (cdr tabs)))) (define just-one? (and (pair? tabs) (null? (cdr tabs))))
(if (and (eq? (system-type) 'unix) (if (and (equal? (system-type) 'unix)
(not just-one?)) (not just-one?))
(close-current-tab) (close-current-tab)
(super file-menu:close-callback item control))) (super file-menu:close-callback item control)))
@ -3299,10 +3271,10 @@
(when tab-to-save (when tab-to-save
(let ([defs-to-save (send tab-to-save get-defs)]) (let ([defs-to-save (send tab-to-save get-defs)])
(when (send defs-to-save is-modified?) (when (send defs-to-save is-modified?)
(unless (eq? tab-to-save original-tab) (unless (object=? tab-to-save original-tab)
(change-to-tab tab-to-save)) (change-to-tab tab-to-save))
(send defs-to-save user-saves-or-not-modified? #f) (send defs-to-save user-saves-or-not-modified? #f)
(unless (eq? tab-to-save original-tab) (unless (object=? tab-to-save original-tab)
(change-to-tab original-tab))))))) (change-to-tab original-tab)))))))
@ -3503,7 +3475,7 @@
(let ([split (let ([split
(new menu:can-restore-menu-item% (new menu:can-restore-menu-item%
(shortcut (if (eq? (system-type) 'macosx) #f #\m)) (shortcut (if (equal? (system-type) 'macosx) #f #\m))
(label (string-constant split-menu-item-label)) (label (string-constant split-menu-item-label))
(parent (get-show-menu)) (parent (get-show-menu))
(callback (λ (x y) (split))) (callback (λ (x y) (split)))
@ -3789,7 +3761,7 @@
(make-object separator-menu-item% file-menu))] (make-object separator-menu-item% file-menu))]
(define close-tab-menu-item #f) (define close-tab-menu-item #f)
(define/override (file-menu:between-close-and-quit file-menu) (define/override (file-menu:between-close-and-quit file-menu)
(unless (eq? (system-type) 'unix) (unless (equal? (system-type) 'unix)
(set! close-tab-menu-item (set! close-tab-menu-item
(new (get-menu-item%) (new (get-menu-item%)
(label (string-constant close-tab)) (label (string-constant close-tab))
@ -4161,7 +4133,7 @@
(floor (/ limit 1024 1024)))))]) (floor (/ limit 1024 1024)))))])
(when num (when num
(cond (cond
[(eq? num #t) [(equal? num #t)
(preferences:set 'drracket:child-only-memory-limit #f) (preferences:set 'drracket:child-only-memory-limit #f)
(send interactions-text set-custodian-limit #f)] (send interactions-text set-custodian-limit #f)]
[else [else
@ -4201,8 +4173,8 @@
(new menu:can-restore-menu-item% (new menu:can-restore-menu-item%
(label (string-constant jump-to-prev-error-highlight-menu-item-label)) (label (string-constant jump-to-prev-error-highlight-menu-item-label))
(parent language-specific-menu) (parent language-specific-menu)
(shortcut (if (eq? (system-type) 'macosx) #\. #\,)) (shortcut (if (equal? (system-type) 'macosx) #\. #\,))
(shortcut-prefix (if (eq? (system-type) 'macosx) (shortcut-prefix (if (equal? (system-type) 'macosx)
(cons 'shift (get-default-shortcut-prefix)) (cons 'shift (get-default-shortcut-prefix))
(get-default-shortcut-prefix))) (get-default-shortcut-prefix)))
(callback (λ (_1 _2) (jump-to-previous-error-loc))) (callback (λ (_1 _2) (jump-to-previous-error-loc)))
@ -5303,7 +5275,7 @@
(cond (cond
[(and newest-frame [(and newest-frame
name name
(not (eq? newest-frame 'nothing-yet)) (not (equal? newest-frame 'nothing-yet))
(send newest-frame still-untouched?)) (send newest-frame still-untouched?))
(send newest-frame change-to-file name) (send newest-frame change-to-file name)
(send newest-frame show #t) (send newest-frame show #t)

7
pkgs/drracket-pkgs/drracket/drracket/tool-lib.rkt
View File

@ -1131,6 +1131,13 @@ all of the names in the tools library, for use defining keybindings
() ()
@{Returns all of the modes currently added to DrRacket. @{Returns all of the modes currently added to DrRacket.
Note that the @racket[_surrogate] field of the
mode corresponding to the module language does not
take into account the
@language-info-ref[definitions-text-surrogate], so it
may not be the actual class used directly in DrRacket,
even when the mode is active.
See also See also
@racket[drracket:modes:add-mode].}) @racket[drracket:modes:add-mode].})

36
pkgs/gui-pkgs/gui-lib/scribble/private/indentation.rkt
View File

@ -1,5 +1,30 @@
#lang racket #lang racket/base
(require framework) (require racket/class
racket/gui/base
framework)
(define surrogate%
(class (racket:text-mode-mixin
(color:text-mode-mixin
mode:surrogate-text%))
(define/override (on-enable-surrogate txt)
(send (send txt get-keymap) chain-to-keymap at-exp-keymap #f)
(super on-enable-surrogate txt))
(define/override (on-disable-surrogate txt)
(keymap:remove-chained-keymap txt at-exp-keymap)
(super on-disable-surrogate txt))
(super-new)))
(define at-exp-keymap (new keymap:aug-keymap%))
(define (reindent-paragraph t evt)
(unless (send t is-stopped?)
(define sp (send t get-start-position))
(when (= sp (send t get-end-position))
(paragraph-indentation t sp 60))))
(send at-exp-keymap add-function "reindent-paragraph" reindent-paragraph)
(send at-exp-keymap map-function "esc;q" "reindent-paragraph")
(send at-exp-keymap map-function "?:a:q" "reindent-paragraph")
;;(paragraph-indentation a-racket:text posi width) → void? ;;(paragraph-indentation a-racket:text posi width) → void?
;; posi : exact-integer? = current given position ;; posi : exact-integer? = current given position
@ -102,7 +127,7 @@
[nxt-para-start (send txt paragraph-start-position nxt-para-num)] [nxt-para-start (send txt paragraph-start-position nxt-para-num)]
[nxt-para-end (send txt paragraph-end-position nxt-para-num)] [nxt-para-end (send txt paragraph-end-position nxt-para-num)]
[nxt-para-classify (txt-position-classify txt nxt-para-start nxt-para-end)]) [nxt-para-classify (txt-position-classify txt nxt-para-start nxt-para-end)])
(when (equal? 'text (first nxt-para-classify)) (when (equal? 'text (car nxt-para-classify))
;now text ;now text
(send txt delete nxt-para-start 'back) (send txt delete nxt-para-start 'back)
(send txt insert #\space (sub1 nxt-para-start))))) (send txt insert #\space (sub1 nxt-para-start)))))
@ -284,7 +309,7 @@
;;test cases ;;test cases
(module+ test (module+ test
(require rackunit) (require rackunit framework)
;test start-skip-spaces ;test start-skip-spaces
(check-equal? (let ([t (new racket:text%)]) (check-equal? (let ([t (new racket:text%)])
@ -475,4 +500,5 @@
(send t get-text))) "aaaa\nbbbb") (send t get-text))) "aaaa\nbbbb")
) )
(provide determine-spaces adjust-para-width paragraph-indentation) (provide determine-spaces adjust-para-width paragraph-indentation
surrogate%)

11
pkgs/racket-pkgs/at-exp-lib/at-exp/lang/reader.rkt
View File

@ -30,7 +30,14 @@
wrap-reader wrap-reader
(lambda (proc) (lambda (proc)
(lambda (key defval) (lambda (key defval)
(define (fallback) (if proc (proc key defval) defval))
(define (try-dynamic-require mod export)
(or (with-handlers ([exn:fail? (λ (x) #f)])
(dynamic-require mod export))
(fallback)))
(case key (case key
[(color-lexer) [(color-lexer)
(dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)] (try-dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)]
[else (if proc (proc key defval) defval)])))))) [(definitions-text-surrogate)
'scribble/private/indentation]
[else (fallback)]))))))

2
pkgs/racket-pkgs/at-exp-lib/scribble/base/reader.rkt
View File

@ -26,6 +26,8 @@
(case key (case key
[(color-lexer) [(color-lexer)
(dynamic-require 'syntax-color/scribble-lexer 'scribble-inside-lexer)] (dynamic-require 'syntax-color/scribble-lexer 'scribble-inside-lexer)]
[(definitions-text-surrogate)
'scribble/private/indentation]
[else (default key defval)]))) [else (default key defval)])))
;; Settings that apply to Scribble-renderable docs: ;; Settings that apply to Scribble-renderable docs: