added language status and menu at bottom right of drscheme window
svn: r5633
This commit is contained in:
Robby Findler
parent
144796ec6d
commit
38da856255
|
|
@ -58,6 +58,15 @@
|
|||
(finder:default-filters)))
|
||||
(application:current-app-name (string-constant drscheme))
|
||||
|
||||
(preferences:set-default 'drscheme:recent-language-names
|
||||
null
|
||||
(λ (x)
|
||||
(and (list? x)
|
||||
(andmap
|
||||
(λ (x)
|
||||
(and (pair? x)
|
||||
(string? (car x))))
|
||||
x))))
|
||||
(preferences:set-default 'drscheme:show-interactions-on-execute #t boolean?)
|
||||
(preferences:set-default 'drscheme:open-in-tabs #f boolean?)
|
||||
(preferences:set-default 'drscheme:toolbar-shown #t boolean?)
|
||||
|
|
|
|||
|
|
@ -551,6 +551,26 @@ module browser threading seems wrong.
|
|||
(set-modified #t))
|
||||
(set! next-settings _next-settings)
|
||||
(change-mode-to-match)
|
||||
|
||||
(let ([f (get-top-level-window)])
|
||||
(when (and f
|
||||
(is-a? f -frame<%>))
|
||||
(send f language-changed)))
|
||||
|
||||
(let ([lang (drscheme:language-configuration:language-settings-language next-settings)]
|
||||
[sets (drscheme:language-configuration:language-settings-settings next-settings)])
|
||||
(preferences:set
|
||||
'drscheme:recent-language-names
|
||||
(limit-length
|
||||
(remove-duplicates
|
||||
(cons (cons (send lang get-language-name)
|
||||
(send lang marshall-settings sets))
|
||||
(preferences:get 'drscheme:recent-language-names)))
|
||||
10)))
|
||||
(preferences:set
|
||||
drscheme:language-configuration:settings-preferences-symbol
|
||||
next-settings)
|
||||
|
||||
(after-set-next-settings _next-settings))
|
||||
|
||||
(define/pubment (after-set-next-settings s)
|
||||
|
|
@ -948,22 +968,22 @@ module browser threading seems wrong.
|
|||
(inner (void) after-percentage-change))
|
||||
(super-new)))
|
||||
|
||||
(define super-frame%
|
||||
(drscheme:frame:mixin
|
||||
(drscheme:frame:basics-mixin
|
||||
(frame:searchable-text-mixin
|
||||
(frame:searchable-mixin
|
||||
(frame:text-info-mixin
|
||||
(frame:delegate-mixin
|
||||
(frame:status-line-mixin
|
||||
(frame:info-mixin
|
||||
(frame:text-mixin
|
||||
(frame:open-here-mixin
|
||||
(frame:editor-mixin
|
||||
(frame:standard-menus-mixin
|
||||
(frame:register-group-mixin
|
||||
(frame:basic-mixin
|
||||
frame%)))))))))))))))
|
||||
(define super-frame%
|
||||
(drscheme:frame:mixin
|
||||
(drscheme:frame:basics-mixin
|
||||
(frame:searchable-text-mixin
|
||||
(frame:searchable-mixin
|
||||
(frame:text-info-mixin
|
||||
(frame:delegate-mixin
|
||||
(frame:status-line-mixin
|
||||
(frame:info-mixin
|
||||
(frame:text-mixin
|
||||
(frame:open-here-mixin
|
||||
(frame:editor-mixin
|
||||
(frame:standard-menus-mixin
|
||||
(frame:register-group-mixin
|
||||
(frame:basic-mixin
|
||||
frame%)))))))))))))))
|
||||
|
||||
(define tab%
|
||||
(class* object% (drscheme:rep:context<%> tab<%>)
|
||||
|
|
@ -1360,11 +1380,11 @@ module browser threading seems wrong.
|
|||
(set! save-init-shown? mod?))
|
||||
(update-tab-label current-tab)))
|
||||
|
||||
(define/private (language-changed)
|
||||
(define/public (language-changed)
|
||||
(let* ([settings (send definitions-text get-next-settings)]
|
||||
[language (drscheme:language-configuration:language-settings-language settings)])
|
||||
(send func-defs-canvas language-changed language)
|
||||
|
||||
(send language-message set-lang (send language get-language-name))
|
||||
(let ([label (send scheme-menu get-label)]
|
||||
[new-label (send language capability-value 'drscheme:language-menu-title)])
|
||||
(unless (equal? label new-label)
|
||||
|
|
@ -2736,6 +2756,14 @@ module browser threading seems wrong.
|
|||
(define special-menu 'special-menu-not-yet-init)
|
||||
(define/public (get-special-menu) special-menu)
|
||||
|
||||
(define/public (choose-language-callback)
|
||||
(let ([new-settings (drscheme:language-configuration:language-dialog
|
||||
#f
|
||||
(send definitions-text get-next-settings)
|
||||
this)])
|
||||
(when new-settings
|
||||
(send definitions-text set-next-settings new-settings))))
|
||||
|
||||
(define/private (initialize-menus)
|
||||
(let* ([mb (get-menu-bar)]
|
||||
[language-menu-on-demand
|
||||
|
|
@ -2763,17 +2791,7 @@ module browser threading seems wrong.
|
|||
(make-object menu:can-restore-menu-item%
|
||||
(string-constant choose-language-menu-item-label)
|
||||
language-menu
|
||||
(λ (_1 _2)
|
||||
(let ([new-settings (drscheme:language-configuration:language-dialog
|
||||
#f
|
||||
(send definitions-text get-next-settings)
|
||||
this)])
|
||||
(when new-settings
|
||||
(send definitions-text set-next-settings new-settings)
|
||||
(language-changed)
|
||||
(preferences:set
|
||||
drscheme:language-configuration:settings-preferences-symbol
|
||||
new-settings))))
|
||||
(λ (_1 _2) (choose-language-callback))
|
||||
#\l)
|
||||
(make-object separator-menu-item% language-menu)
|
||||
(make-object menu:can-restore-menu-item%
|
||||
|
|
@ -3185,11 +3203,28 @@ module browser threading seems wrong.
|
|||
(set-save-init-shown?
|
||||
(and m (send m is-modified?))))
|
||||
|
||||
(define language-message
|
||||
(let* ([info-panel (get-info-panel)]
|
||||
[vp (new vertical-panel%
|
||||
[parent info-panel]
|
||||
[alignment '(left center)]
|
||||
[stretchable-width #f]
|
||||
[stretchable-height #f])]
|
||||
[spacer (new horizontal-panel% [parent info-panel])]
|
||||
[l-m-label (new language-label-message% [parent vp] [frame this])]
|
||||
[language-message (new language-message% [parent vp])])
|
||||
(send info-panel change-children
|
||||
(λ (l)
|
||||
(list* vp
|
||||
spacer
|
||||
(remq* (list spacer vp) l))))
|
||||
language-message))
|
||||
|
||||
(update-save-message)
|
||||
(update-save-button)
|
||||
(language-changed)
|
||||
|
||||
(cond
|
||||
(cond
|
||||
[filename
|
||||
(set! definitions-shown? #t)
|
||||
(set! interactions-shown? #f)]
|
||||
|
|
@ -3208,8 +3243,104 @@ module browser threading seems wrong.
|
|||
(update-toolbar-visiblity)
|
||||
(set! newest-frame this)
|
||||
(send definitions-canvas focus)))
|
||||
|
||||
(define -frame% (frame-mixin super-frame%))
|
||||
|
||||
(define (limit-length l n)
|
||||
(let loop ([l l]
|
||||
[n n])
|
||||
(cond
|
||||
[(or (null? l) (zero? n)) null]
|
||||
[else (cons (car l) (loop (cdr l) (- n 1)))])))
|
||||
(define (remove-duplicates l)
|
||||
(reverse
|
||||
(let loop ([l (reverse l)])
|
||||
(cond
|
||||
[(null? l) l]
|
||||
[else
|
||||
(if (member (car l) (cdr l))
|
||||
(loop (cdr l))
|
||||
(cons (car l) (loop (cdr l))))]))))
|
||||
|
||||
(define programming-language-label (string-constant programming-language-label))
|
||||
(define second-line-indent 6)
|
||||
(define language-message%
|
||||
(class canvas%
|
||||
(inherit get-dc get-client-size refresh)
|
||||
(define message "")
|
||||
(define/public (set-lang l)
|
||||
(set! message l)
|
||||
(update-min-widths)
|
||||
(refresh))
|
||||
|
||||
(define/override (on-paint)
|
||||
(let ([dc (get-dc)])
|
||||
(let-values ([(w h) (get-client-size)])
|
||||
(send dc set-pen (get-panel-background) 1 'transparent)
|
||||
(send dc set-brush (get-panel-background) 'transparent)
|
||||
(send dc draw-rectangle 0 0 w h)
|
||||
(send dc set-font small-control-font)
|
||||
(send dc draw-text message (get-left-side-padding) 0))))
|
||||
|
||||
(super-new [style '(transparent)])
|
||||
(inherit stretchable-width stretchable-height)
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f)
|
||||
|
||||
(inherit min-width min-height)
|
||||
(define (update-min-widths)
|
||||
(let ([dc (get-dc)])
|
||||
(let-values ([(w2 h2 _3 _4) (send dc get-text-extent message small-control-font)])
|
||||
(min-width (inexact->exact (floor (+ (get-left-side-padding) w2))))
|
||||
(min-height (inexact->exact (floor h2))))))))
|
||||
|
||||
(define language-label-message%
|
||||
(class name-message%
|
||||
(init-field frame)
|
||||
(define/override (fill-popup menu reset)
|
||||
(let ([added-one? #f])
|
||||
(for-each
|
||||
(λ (name/settings)
|
||||
(let* ([name (car name/settings)]
|
||||
[marshalled-settings (cdr name/settings)]
|
||||
[lang (ormap
|
||||
(λ (l) (and (equal? (send l get-language-name) name) l))
|
||||
(drscheme:language-configuration:get-languages))]
|
||||
[settings (send lang unmarshall-settings marshalled-settings)])
|
||||
(when lang
|
||||
(unless added-one?
|
||||
(send (new menu-item%
|
||||
[label (string-constant recent-languages)]
|
||||
[callback void]
|
||||
[parent menu])
|
||||
enable #f))
|
||||
(set! added-one? #t)
|
||||
(new menu-item%
|
||||
[parent menu]
|
||||
[label (string-append " "
|
||||
(send lang get-language-name)
|
||||
(if (send lang default-settings? settings)
|
||||
""
|
||||
(string-append " " (string-constant custom))))]
|
||||
[callback
|
||||
(λ (x y)
|
||||
(send (send frame get-definitions-text)
|
||||
set-next-settings
|
||||
(drscheme:language-configuration:make-language-settings
|
||||
lang
|
||||
settings)))]))))
|
||||
(preferences:get 'drscheme:recent-language-names))
|
||||
(when added-one?
|
||||
(new separator-menu-item% [parent menu])))
|
||||
(new menu-item%
|
||||
[label (string-constant choose-language-menu-item-label)]
|
||||
[parent menu]
|
||||
[callback
|
||||
(λ (x y)
|
||||
(send frame choose-language-callback))]))
|
||||
|
||||
(super-new [label programming-language-label]
|
||||
[font tiny-control-font])))
|
||||
|
||||
(define -frame% (frame-mixin super-frame%))
|
||||
|
||||
(define module-browser-dragable-panel%
|
||||
(class panel:horizontal-dragable%
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@
|
|||
(define (min-h w) (flat-named-contract "draw-button-label-height" (lambda (h) (h . > . (* 2 border-inset)))))
|
||||
|
||||
(provide/contract
|
||||
[get-left-side-padding (-> number?)]
|
||||
(pad-xywh (number? number? (>=/c 0) (>=/c 0) . -> . (values number? number? (>=/c 0) (>=/c 0))))
|
||||
(draw-button-label
|
||||
(->r ([dc (is-a?/c dc<%>)]
|
||||
|
|
@ -22,13 +23,13 @@
|
|||
[w (and/c number? (min-w h))]
|
||||
[h (and/c number? (min-h w))]
|
||||
[mouse-over? boolean?]
|
||||
[grabbed? boolean?])
|
||||
[grabbed? boolean?]
|
||||
[button-label-font (is-a?/c font%)])
|
||||
void?))
|
||||
|
||||
(calc-button-min-sizes
|
||||
(->*
|
||||
((is-a?/c dc<%>) string?)
|
||||
(number? number?))))
|
||||
(->* ((is-a?/c dc<%>) string? (is-a?/c font%))
|
||||
(number? number?))))
|
||||
|
||||
(provide name-message%)
|
||||
|
||||
|
|
@ -47,7 +48,8 @@
|
|||
(define paths #f)
|
||||
|
||||
;; label : string
|
||||
(init-field [label (string-constant untitled)])
|
||||
(init-field [label (string-constant untitled)]
|
||||
[font small-control-font])
|
||||
|
||||
(define full-name-window #f)
|
||||
|
||||
|
|
@ -131,7 +133,7 @@
|
|||
|
||||
(inherit get-parent)
|
||||
(define/private (update-min-sizes)
|
||||
(let-values ([(w h) (calc-button-min-sizes (get-dc) label)])
|
||||
(let-values ([(w h) (calc-button-min-sizes (get-dc) label font)])
|
||||
(min-width w)
|
||||
(min-height h)
|
||||
(send (get-parent) reflow-container)))
|
||||
|
|
@ -152,15 +154,14 @@
|
|||
(send dc set-brush brush))]
|
||||
[else
|
||||
(when (and (> w 5) (> h 5))
|
||||
(draw-button-label dc label 0 0 w h mouse-over? mouse-grabbed?))]))))
|
||||
(draw-button-label dc label 0 0 w h mouse-over? mouse-grabbed? font))]))))
|
||||
|
||||
(super-new [style '(transparent)])
|
||||
(update-min-sizes)
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f)))
|
||||
|
||||
(define button-label-font small-control-font)
|
||||
|
||||
(define (get-left-side-padding) (+ button-label-inset circle-spacer))
|
||||
(define button-label-inset 1)
|
||||
(define black-color (make-object color% "BLACK"))
|
||||
|
||||
|
|
@ -185,7 +186,7 @@
|
|||
(define mouse-grabbed-color (make-object color% 100 100 100))
|
||||
(define grabbed-fg-color (make-object color% 220 220 220))
|
||||
|
||||
(define (calc-button-min-sizes dc label)
|
||||
(define (calc-button-min-sizes dc label button-label-font)
|
||||
(let-values ([(w h a d) (send dc get-text-extent label button-label-font)])
|
||||
(let-values ([(px py pw ph) (pad-xywh 0 0 w h)])
|
||||
(values pw ph))))
|
||||
|
|
@ -214,7 +215,7 @@
|
|||
ans-w
|
||||
ans-h)))
|
||||
|
||||
(define (draw-button-label dc label dx dy w h mouse-over? grabbed?)
|
||||
(define (draw-button-label dc label dx dy w h mouse-over? grabbed? button-label-font)
|
||||
(when (or mouse-over? grabbed?)
|
||||
(let ([color (if grabbed?
|
||||
mouse-grabbed-color
|
||||
|
|
|
|||
|
|
@ -921,6 +921,13 @@ please adhere to these guidelines:
|
|||
(use-repeating-decimals "Repeating decimals")
|
||||
(decimal-notation-for-rationals "Use decimal notation for rationals")
|
||||
|
||||
; used in the bottom left of the drscheme frame as the label
|
||||
; above the programming language's name
|
||||
(programming-language-label "Programming language:")
|
||||
; used the popup menu from the just above; greyed out and only
|
||||
; visible when some languages are in the history
|
||||
(recent-languages "Recent languages:")
|
||||
|
||||
;; startup wizard screen language selection section
|
||||
(please-select-a-language "Please select a language")
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user