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
))
(define-signature drscheme:module-langauge-cm^
(define-signature drscheme:module-language-cm^
(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
module-language-name
module-language-put-file-mixin))
(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-choose-a-language "Choose a language")
(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@)
@ -33,7 +33,8 @@
[prefix drscheme:language: drscheme:language^]
[prefix drscheme:app: drscheme:app^]
[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^)
;; settings-preferences-symbol : symbol
@ -346,9 +347,11 @@
cached-fringe)
(define/override (on-select i)
(if (and i (is-a? i hieritem-language<%>))
(something-selected i)
(nothing-selected)))
(cond
[(and i (is-a? i hieritem-language<%>))
(something-selected i)]
[else
(non-language-selected)]))
;; this is used only because we set `on-click-always'
(define/override (on-click i)
(when (and i (is-a? i hierarchical-list-compound-item<%>))
@ -358,7 +361,7 @@
(when (and i (is-a? i hieritem-language<%>))
(something-selected i)
(ok-handler 'execute)))
(super-instantiate (parent))
(super-new [parent parent])
;; do this so we can expand/collapse languages on a single click
(send this on-click-always #t)))
@ -398,7 +401,9 @@
[stretchable-width #f]
[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/manual-parent-panel (make-object vertical-panel% details-outer-panel))
(define details-panel (make-object panel:single% details/manual-parent-panel))
@ -435,8 +440,6 @@
(init-rest args)
(public 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))
(apply super-make-object args))))
@ -454,6 +457,8 @@
;(send languages-hier-list select #f)
(send use-chosen-language-rb set-selection #f)
(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
module-language*get-language-details-panel
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/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
;; for when no language is selected.
(define (nothing-selected)
;; for when some non-language is selected in the hierlist
(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 details-panel active-child no-details-panel)
(send one-line-summary-message set-label "")
@ -476,6 +483,8 @@
;; something-selected : item -> void
(define (something-selected item)
(send use-chosen-language-rb set-selection 0)
(send use-language-in-source-rb set-selection #f)
(ok-handler 'enable)
(send details-button enable #t)
(send item selected))
@ -507,7 +516,7 @@
positions numbers))
(when (null? (cdr positions))
(unless (equal? positions (list "Module"))
(unless (equal? positions (list drscheme:module-language:module-language-name))
(error 'drscheme:language
"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))])))))
(cond
[(equal? positions '("Module"))
[(equal? positions (list drscheme:module-language:module-language-name))
(set! module-language*language language)
(set! module-language*get-language-details-panel get-language-details-panel)
(set! module-language*get/set-settings get/set-settings)]
@ -909,15 +918,25 @@
(send t set-styles-sticky #f)
(send t set-autowrap-bitmap #f)
(let ([do-insert
(λ (str style)
(let* ([size-sd (make-object style-delta% 'change-size (send small-control-font get-point-size))]
[do-insert
(λ (str tt-style?)
(let ([before (send t last-position)])
(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)])
(do-insert (car strs) (send (send t get-style-list) basic-style))
(do-insert (car strs) #f)
(unless (null? (cdr strs))
(do-insert "#lang" (send (send t get-style-list) find-named-style "standard"))
(do-insert "#lang" #t)
(loop (cdr strs)))))
(send t hide-caret #t)

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

@ -29,7 +29,7 @@
(define module-language<%>
(interface ()
))
get-users-language-name))
;; add-module-language : -> void
;; adds the special module-only language to drscheme
@ -53,10 +53,21 @@
(define default-full-trace? #t)
(define default-auto-text "#lang scheme\n")
(define module-language-name "Determine langauge from source")
;; module-mixin : (implements drscheme:language:language<%>)
;; -> (implements drscheme:language:language<%>)
(define (module-mixin %)
(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/augment (capability-value key)
@ -328,7 +339,7 @@
(super-new
[module #f]
[language-position (list "Module")]
[language-position (list module-language-name)]
[language-numbers (list -32768)])))
;; 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:help-desk: drscheme:help-desk^)
(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^
[-text% text%]
[-text<%> text<%>]))
@ -402,9 +403,15 @@ TODO
default-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)
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)
(send (drscheme:language-configuration:language-settings-language language-settings)
get-style-delta))
@ -1587,7 +1594,7 @@ TODO
(let-values (((before after)
(insert/delta
this
(extract-language-name user-language-settings)
(extract-language-name user-language-settings definitions-text)
dark-green-delta
(extract-language-style-delta 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)
mzlib/etc)
(define turn-up (include-bitmap "../../icons/turn-up.png" 'png))
(define turn-down (include-bitmap "../../icons/turn-down.png" 'png))
(define turn-up-click (include-bitmap "../../icons/turn-up-click.png" 'png))
(define turn-down-click (include-bitmap "../../icons/turn-down-click.png" 'png))
(define turn-up (include-bitmap "../../icons/turn-up.png" 'png/mask))
(define turn-down (include-bitmap "../../icons/turn-down.png" 'png/mask))
(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/mask))
(provide hierlist@)
(define-unit hierlist@
@ -93,7 +93,10 @@
(send dc draw-bitmap-section bitmap
(+ x (max 0 (- (/ size 2) (/ bw 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))]
[on-event
(lambda (dc x y mediax mediay event)
@ -340,7 +343,8 @@
[parent-snip parent-snp]
[children null]
[new-children null]
[no-sublists? #f])
[no-sublists? #f]
[transparent? #f])
(private
[append-children! (lambda ()
(unless (null? new-children)
@ -350,6 +354,7 @@
[insert-item
(lambda (mixin snip% whitespace?)
(let ([s (make-object snip% this top top-select (add1 depth) mixin)])
(send s use-style-background transparent?)
(begin-edit-sequence)
(unless (and (null? children)
(null? new-children))
@ -361,6 +366,7 @@
(set! new-children (cons s new-children))
(send s get-item)))])
(public
[set-transparent (λ (t?) (set! transparent? (and t? #t)))]
[get-parent-snip (lambda () parent-snip)]
[deselect-all
(lambda ()
@ -583,8 +589,16 @@
[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)))]
[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
[get-arrow-snip (lambda () arrow)])
(inherit style-background-used?)
(sequence
(super-init main-buffer #f 0 0 0 0 0 0 0 0)
(send main-buffer hide-caret #t)
@ -854,6 +868,7 @@
[selected #f]
[selected-item #f])
(sequence
(send top-buffer set-transparent (member 'transparent style))
(super-init parent top-buffer style)
(allow-tab-exit #t)
(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))
'(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<%>)