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

some improvements to the new language dialog

Browse Source 
svn: r17886
This commit is contained in:
Robby Findler 2010-01-29 18:29:03 +00:00
parent d620177619
commit be5b6cd32e
6 changed files with 104 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/drscheme/private/drsig.ss
View File

@ -79,10 +79,11 @@
;show-syntax-error-context ;show-syntax-error-context
)) ))
(define-signature drscheme:module-langauge-cm^ (define-signature drscheme:module-language-cm^
(module-language<%>)) (module-language<%>))
(define-signature drscheme:module-language^ extends drscheme:module-langauge-cm^ (define-signature drscheme:module-language^ extends drscheme:module-language-cm^
(add-module-language (add-module-language
module-language-name
module-language-put-file-mixin)) module-language-put-file-mixin))
(define-signature drscheme:module-langauge-tools-cm^ (define-signature drscheme:module-langauge-tools-cm^

57
collects/drscheme/private/language-configuration.ss
View File

@ -22,7 +22,7 @@
(define sc-use-language-in-source "Use the language declared in the source") (define sc-use-language-in-source "Use the language declared in the source")
(define sc-choose-a-language "Choose a language") (define sc-choose-a-language "Choose a language")
(define sc-lang-in-source-discussion (define sc-lang-in-source-discussion
"Typically, a #lang line at the start of a program declares its language. This is the default and preferred mode for DrScheme.") "The #lang line at the start of a program declares its language. This is the default and preferred mode for DrScheme.")
(provide language-configuration@) (provide language-configuration@)
@ -33,7 +33,8 @@
[prefix drscheme:language: drscheme:language^] [prefix drscheme:language: drscheme:language^]
[prefix drscheme:app: drscheme:app^] [prefix drscheme:app: drscheme:app^]
[prefix drscheme:tools: drscheme:tools^] [prefix drscheme:tools: drscheme:tools^]
[prefix drscheme:help-desk: drscheme:help-desk^]) [prefix drscheme:help-desk: drscheme:help-desk^]
[prefix drscheme:module-language: drscheme:module-language^])
(export drscheme:language-configuration/internal^) (export drscheme:language-configuration/internal^)
;; settings-preferences-symbol : symbol ;; settings-preferences-symbol : symbol
@ -346,9 +347,11 @@
cached-fringe) cached-fringe)
(define/override (on-select i) (define/override (on-select i)
(if (and i (is-a? i hieritem-language<%>)) (cond
(something-selected i) [(and i (is-a? i hieritem-language<%>))
(nothing-selected))) (something-selected i)]
[else
(non-language-selected)]))
;; this is used only because we set `on-click-always' ;; this is used only because we set `on-click-always'
(define/override (on-click i) (define/override (on-click i)
(when (and i (is-a? i hierarchical-list-compound-item<%>)) (when (and i (is-a? i hierarchical-list-compound-item<%>))
@ -358,7 +361,7 @@
(when (and i (is-a? i hieritem-language<%>)) (when (and i (is-a? i hieritem-language<%>))
(something-selected i) (something-selected i)
(ok-handler 'execute))) (ok-handler 'execute)))
(super-instantiate (parent)) (super-new [parent parent])
;; do this so we can expand/collapse languages on a single click ;; do this so we can expand/collapse languages on a single click
(send this on-click-always #t))) (send this on-click-always #t)))
@ -398,7 +401,9 @@
[stretchable-width #f] [stretchable-width #f]
[min-width 24])) [min-width 24]))
(define languages-hier-list (make-object selectable-hierlist% languages-hier-list-panel)) (define languages-hier-list (new selectable-hierlist%
[parent languages-hier-list-panel]
[style '(no-border no-hscroll hide-vscroll transparent)]))
(define details-outer-panel (make-object vertical-pane% outermost-panel)) (define details-outer-panel (make-object vertical-pane% outermost-panel))
(define details/manual-parent-panel (make-object vertical-panel% details-outer-panel)) (define details/manual-parent-panel (make-object vertical-panel% details-outer-panel))
(define details-panel (make-object panel:single% details/manual-parent-panel)) (define details-panel (make-object panel:single% details/manual-parent-panel))
@ -435,8 +440,6 @@
(init-rest args) (init-rest args)
(public selected) (public selected)
(define (selected) (define (selected)
(send use-chosen-language-rb set-selection 0)
(send use-language-in-source-rb set-selection #f)
(update-gui-based-on-selected-language language get-language-details-panel get/set-settings)) (update-gui-based-on-selected-language language get-language-details-panel get/set-settings))
(apply super-make-object args)))) (apply super-make-object args))))
@ -454,6 +457,8 @@
;(send languages-hier-list select #f) ;(send languages-hier-list select #f)
(send use-chosen-language-rb set-selection #f) (send use-chosen-language-rb set-selection #f)
(send use-language-in-source-rb set-selection 0) (send use-language-in-source-rb set-selection 0)
(ok-handler 'enable)
(send details-button enable #t)
(update-gui-based-on-selected-language module-language*language (update-gui-based-on-selected-language module-language*language
module-language*get-language-details-panel module-language*get-language-details-panel
module-language*get/set-settings)) module-language*get/set-settings))
@ -462,10 +467,12 @@
(define module-language*get-language-details-panel 'module-language*-not-yet-set) (define module-language*get-language-details-panel 'module-language*-not-yet-set)
(define module-language*get/set-settings 'module-language*-not-yet-set) (define module-language*get/set-settings 'module-language*-not-yet-set)
;; nothing-selected : -> void ;; non-language-selected : -> void
;; updates the GUI and selected-language and get/set-selected-language-settings ;; updates the GUI and selected-language and get/set-selected-language-settings
;; for when no language is selected. ;; for when some non-language is selected in the hierlist
(define (nothing-selected) (define (non-language-selected)
(send use-chosen-language-rb set-selection 0)
(send use-language-in-source-rb set-selection #f)
(send revert-to-defaults-button enable #f) (send revert-to-defaults-button enable #f)
(send details-panel active-child no-details-panel) (send details-panel active-child no-details-panel)
(send one-line-summary-message set-label "") (send one-line-summary-message set-label "")
@ -476,6 +483,8 @@
;; something-selected : item -> void ;; something-selected : item -> void
(define (something-selected item) (define (something-selected item)
(send use-chosen-language-rb set-selection 0)
(send use-language-in-source-rb set-selection #f)
(ok-handler 'enable) (ok-handler 'enable)
(send details-button enable #t) (send details-button enable #t)
(send item selected)) (send item selected))
@ -507,7 +516,7 @@
positions numbers)) positions numbers))
(when (null? (cdr positions)) (when (null? (cdr positions))
(unless (equal? positions (list "Module")) (unless (equal? positions (list drscheme:module-language:module-language-name))
(error 'drscheme:language (error 'drscheme:language
"Only the module language may be at the top level. Other languages must have at least two levels"))) "Only the module language may be at the top level. Other languages must have at least two levels")))
@ -578,7 +587,7 @@
(get/set-settings (send language default-settings))]))))) (get/set-settings (send language default-settings))])))))
(cond (cond
[(equal? positions '("Module")) [(equal? positions (list drscheme:module-language:module-language-name))
(set! module-language*language language) (set! module-language*language language)
(set! module-language*get-language-details-panel get-language-details-panel) (set! module-language*get-language-details-panel get-language-details-panel)
(set! module-language*get/set-settings get/set-settings)] (set! module-language*get/set-settings get/set-settings)]
@ -909,15 +918,25 @@
(send t set-styles-sticky #f) (send t set-styles-sticky #f)
(send t set-autowrap-bitmap #f) (send t set-autowrap-bitmap #f)
(let ([do-insert (let* ([size-sd (make-object style-delta% 'change-size (send small-control-font get-point-size))]
(λ (str style) [do-insert
(λ (str tt-style?)
(let ([before (send t last-position)]) (let ([before (send t last-position)])
(send t insert str before before) (send t insert str before before)
(send t change-style style before (send t last-position))))]) (cond
[tt-style?
(send t change-style
(send (send t get-style-list) find-named-style "Standard")
before (send t last-position))]
[else
(send t change-style
(send (send t get-style-list) basic-style)
before (send t last-position))])
(send t change-style size-sd before (send t last-position))))])
(let loop ([strs (regexp-split #rx"#lang" sc-lang-in-source-discussion)]) (let loop ([strs (regexp-split #rx"#lang" sc-lang-in-source-discussion)])
(do-insert (car strs) (send (send t get-style-list) basic-style)) (do-insert (car strs) #f)
(unless (null? (cdr strs)) (unless (null? (cdr strs))
(do-insert "#lang" (send (send t get-style-list) find-named-style "standard")) (do-insert "#lang" #t)
(loop (cdr strs))))) (loop (cdr strs)))))
(send t hide-caret #t) (send t hide-caret #t)

15
collects/drscheme/private/module-language.ss
View File

@ -29,7 +29,7 @@
(define module-language<%> (define module-language<%>
(interface () (interface ()
)) get-users-language-name))
;; add-module-language : -> void ;; add-module-language : -> void
;; adds the special module-only language to drscheme ;; adds the special module-only language to drscheme
@ -53,10 +53,21 @@
(define default-full-trace? #t) (define default-full-trace? #t)
(define default-auto-text "#lang scheme\n") (define default-auto-text "#lang scheme\n")
(define module-language-name "Determine langauge from source")
;; module-mixin : (implements drscheme:language:language<%>) ;; module-mixin : (implements drscheme:language:language<%>)
;; -> (implements drscheme:language:language<%>) ;; -> (implements drscheme:language:language<%>)
(define (module-mixin %) (define (module-mixin %)
(class* % (drscheme:language:language<%> module-language<%>) (class* % (drscheme:language:language<%> module-language<%>)
(inherit get-language-name)
(define/public (get-users-language-name defs-text)
(let ([m (regexp-match "#lang (.*)$"
(send defs-text get-text 0 (send defs-text paragraph-end-position 1)))])
(if m
(list-ref m 1)
(get-language-name))))
(define/override (use-namespace-require/copy?) #f) (define/override (use-namespace-require/copy?) #f)
(define/augment (capability-value key) (define/augment (capability-value key)
@ -328,7 +339,7 @@
(super-new (super-new
[module #f] [module #f]
[language-position (list "Module")] [language-position (list module-language-name)]
[language-numbers (list -32768)]))) [language-numbers (list -32768)])))
;; can be called with #f to just kill the repl (in case we want to kill it ;; can be called with #f to just kill the repl (in case we want to kill it

15
collects/drscheme/private/rep.ss
View File

@ -89,7 +89,8 @@ TODO
(prefix drscheme:text: drscheme:text^) (prefix drscheme:text: drscheme:text^)
(prefix drscheme:help-desk: drscheme:help-desk^) (prefix drscheme:help-desk: drscheme:help-desk^)
(prefix drscheme:debug: drscheme:debug^) (prefix drscheme:debug: drscheme:debug^)
[prefix drscheme:eval: drscheme:eval^]) [prefix drscheme:eval: drscheme:eval^]
[prefix drscheme:module-language: drscheme:module-language^])
(export (rename drscheme:rep^ (export (rename drscheme:rep^
[-text% text%] [-text% text%]
[-text<%> text<%>])) [-text<%> text<%>]))
@ -402,9 +403,15 @@ TODO
default-settings? default-settings?
(drscheme:language-configuration:language-settings-settings language-settings))) (drscheme:language-configuration:language-settings-settings language-settings)))
(define (extract-language-name language-settings) (define (extract-language-name language-settings defs-text)
(cond
[(is-a? (drscheme:language-configuration:language-settings-language language-settings)
drscheme:module-language:module-language<%>)
(send (drscheme:language-configuration:language-settings-language language-settings) (send (drscheme:language-configuration:language-settings-language language-settings)
get-language-name)) get-users-language-name defs-text)]
[else
(send (drscheme:language-configuration:language-settings-language language-settings)
get-language-name)]))
(define (extract-language-style-delta language-settings) (define (extract-language-style-delta language-settings)
(send (drscheme:language-configuration:language-settings-language language-settings) (send (drscheme:language-configuration:language-settings-language language-settings)
get-style-delta)) get-style-delta))
@ -1587,7 +1594,7 @@ TODO
(let-values (((before after) (let-values (((before after)
(insert/delta (insert/delta
this this
(extract-language-name user-language-settings) (extract-language-name user-language-settings definitions-text)
dark-green-delta dark-green-delta
(extract-language-style-delta user-language-settings))) (extract-language-style-delta user-language-settings)))
((url) (extract-language-url user-language-settings))) ((url) (extract-language-url user-language-settings)))

27
collects/mrlib/hierlist/hierlist-unit.ss
View File

@ -10,10 +10,10 @@
(require (rename mzlib/list sort* sort) (require (rename mzlib/list sort* sort)
mzlib/etc) mzlib/etc)
(define turn-up (include-bitmap "../../icons/turn-up.png" 'png)) (define turn-up (include-bitmap "../../icons/turn-up.png" 'png/mask))
(define turn-down (include-bitmap "../../icons/turn-down.png" 'png)) (define turn-down (include-bitmap "../../icons/turn-down.png" 'png/mask))
(define turn-up-click (include-bitmap "../../icons/turn-up-click.png" 'png)) (define turn-up-click (include-bitmap "../../icons/turn-up-click.png" 'png/mask))
(define turn-down-click (include-bitmap "../../icons/turn-down-click.png" 'png)) (define turn-down-click (include-bitmap "../../icons/turn-down-click.png" 'png/mask))
(provide hierlist@) (provide hierlist@)
(define-unit hierlist@ (define-unit hierlist@
@ -93,7 +93,10 @@
(send dc draw-bitmap-section bitmap (send dc draw-bitmap-section bitmap
(+ x (max 0 (- (/ size 2) (/ bw 2)))) (+ x (max 0 (- (/ size 2) (/ bw 2))))
(+ y (max 0 (- (/ size 2) (/ bh 2)))) (+ y (max 0 (- (/ size 2) (/ bh 2))))
0 0 (min bw (+ size 2)) (min bh (+ size 2)))))] 0 0 (min bw (+ size 2)) (min bh (+ size 2))
'solid
(send the-color-database find-color "black")
(send bitmap get-loaded-mask))))]
[size-cache-invalid (lambda () (set! size-calculated? #f))] [size-cache-invalid (lambda () (set! size-calculated? #f))]
[on-event [on-event
(lambda (dc x y mediax mediay event) (lambda (dc x y mediax mediay event)
@ -340,7 +343,8 @@
[parent-snip parent-snp] [parent-snip parent-snp]
[children null] [children null]
[new-children null] [new-children null]
[no-sublists? #f]) [no-sublists? #f]
[transparent? #f])
(private (private
[append-children! (lambda () [append-children! (lambda ()
(unless (null? new-children) (unless (null? new-children)
@ -350,6 +354,7 @@
[insert-item [insert-item
(lambda (mixin snip% whitespace?) (lambda (mixin snip% whitespace?)
(let ([s (make-object snip% this top top-select (add1 depth) mixin)]) (let ([s (make-object snip% this top top-select (add1 depth) mixin)])
(send s use-style-background transparent?)
(begin-edit-sequence) (begin-edit-sequence)
(unless (and (null? children) (unless (and (null? children)
(null? new-children)) (null? new-children))
@ -361,6 +366,7 @@
(set! new-children (cons s new-children)) (set! new-children (cons s new-children))
(send s get-item)))]) (send s get-item)))])
(public (public
[set-transparent (λ (t?) (set! transparent? (and t? #t)))]
[get-parent-snip (lambda () parent-snip)] [get-parent-snip (lambda () parent-snip)]
[deselect-all [deselect-all
(lambda () (lambda ()
@ -583,8 +589,16 @@
[content-snip (make-object editor-snip% content-buffer #f 4 0 0 0 0 0 0 0)] [content-snip (make-object editor-snip% content-buffer #f 4 0 0 0 0 0 0 0)]
[arrow (make-object (get-arrow-snip%) (lambda (a) (on-arrow a)))] [arrow (make-object (get-arrow-snip%) (lambda (a) (on-arrow a)))]
[whitespace (make-object whitespace-snip%)]) [whitespace (make-object whitespace-snip%)])
(override
[use-style-background
(λ (x)
(super use-style-background x)
(send title-snip use-style-background x)
(send content-snip use-style-background x)
(send content-buffer set-transparent x))])
(public (public
[get-arrow-snip (lambda () arrow)]) [get-arrow-snip (lambda () arrow)])
(inherit style-background-used?)
(sequence (sequence
(super-init main-buffer #f 0 0 0 0 0 0 0 0) (super-init main-buffer #f 0 0 0 0 0 0 0 0)
(send main-buffer hide-caret #t) (send main-buffer hide-caret #t)
@ -854,6 +868,7 @@
[selected #f] [selected #f]
[selected-item #f]) [selected-item #f])
(sequence (sequence
(send top-buffer set-transparent (member 'transparent style))
(super-init parent top-buffer style) (super-init parent top-buffer style)
(allow-tab-exit #t) (allow-tab-exit #t)
(send top-buffer set-cursor arrow-cursor) (send top-buffer set-cursor arrow-cursor)

10
collects/mrlib/scribblings/hierlist/list.scrbl
View File

@ -16,7 +16,15 @@ Creates a hierarchical-list control.
'resize-corner 'deleted 'transparent)) 'resize-corner 'deleted 'transparent))
'(no-hscroll)])]{ '(no-hscroll)])]{
Creates the control.} Creates the control.
If the style @scheme['transparent] is passed, then the
@method[editor-snip% use-style-background] method will be
called with @scheme[#t] when editor snips are created as part of
the hierarchical list, ensuring that the entire control is
transparent.
}
@defmethod[(get-selected) (or/c (is-a?/c hierarchical-list-item<%>) @defmethod[(get-selected) (or/c (is-a?/c hierarchical-list-item<%>)