diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss index 88b8bf257e..4645b8a393 100644 --- a/collects/drscheme/private/drsig.ss +++ b/collects/drscheme/private/drsig.ss @@ -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^ diff --git a/collects/drscheme/private/language-configuration.ss b/collects/drscheme/private/language-configuration.ss index 637dd15f9b..d37019deeb 100644 --- a/collects/drscheme/private/language-configuration.ss +++ b/collects/drscheme/private/language-configuration.ss @@ -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,7 +483,9 @@ ;; something-selected : item -> void (define (something-selected item) - (ok-handler 'enable) + (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 ([before (send t last-position)]) - (send t insert str before before) - (send t change-style style before (send t last-position))))]) + (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) + (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) diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss index 1c56cc64f2..04c1c80799 100644 --- a/collects/drscheme/private/module-language.ss +++ b/collects/drscheme/private/module-language.ss @@ -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 diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index 9e4d84d01d..4c272b9644 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -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) - (send (drscheme:language-configuration:language-settings-language language-settings) - get-language-name)) + (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-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))) diff --git a/collects/mrlib/hierlist/hierlist-unit.ss b/collects/mrlib/hierlist/hierlist-unit.ss index 6a0b026aff..27b1cb6016 100644 --- a/collects/mrlib/hierlist/hierlist-unit.ss +++ b/collects/mrlib/hierlist/hierlist-unit.ss @@ -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,17 +354,19 @@ [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)) (insert #\newline (last-position))) (when whitespace? - (insert (make-whitespace) (last-position))) + (insert (make-whitespace) (last-position))) (insert s (last-position)) (end-edit-sequence) (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 () @@ -479,7 +485,7 @@ ;; Snip for a compound list item (define hierarchical-list-snip% - (class100 editor-snip% (prnt tp top-select depth mixin [title #f][content #f]) + (class100 editor-snip% (prnt tp top-select depth mixin [title #f][content #f]) (private-field [parent prnt] [top tp]) @@ -583,11 +589,19 @@ [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)]) - (sequence + (inherit style-background-used?) + (sequence (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) (send main-buffer insert arrow) (when title (send title-buffer insert title)) (when content (send content-buffer insert content)) @@ -637,7 +651,7 @@ (send list-keymap map-function "return" "toggle-open/closed") (define hierarchical-list% - (class100 editor-canvas% (parent [style '(no-hscroll)]) + (class100 editor-canvas% (parent [style '(no-hscroll)]) (inherit min-width min-height allow-tab-exit) (rename [super-on-char on-char] [super-on-focus on-focus]) @@ -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) diff --git a/collects/mrlib/scribblings/hierlist/list.scrbl b/collects/mrlib/scribblings/hierlist/list.scrbl index de9b6b0a3e..81a7b21562 100644 --- a/collects/mrlib/scribblings/hierlist/list.scrbl +++ b/collects/mrlib/scribblings/hierlist/list.scrbl @@ -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<%>)