diff --git a/collects/drscheme/private/language-configuration.ss b/collects/drscheme/private/language-configuration.ss index 84564d6f36..05936ea9f7 100644 --- a/collects/drscheme/private/language-configuration.ss +++ b/collects/drscheme/private/language-configuration.ss @@ -1,20 +1,17 @@ -#lang mzscheme - (require mzlib/unit +#lang scheme/base + (require scheme/unit mrlib/hierlist - mzlib/class - mzlib/contract - mzlib/kw - mzlib/string - mzlib/struct + scheme/class + scheme/contract + scheme/string + scheme/list "drsig.ss" string-constants mred framework - mzlib/list - mzlib/etc - mzlib/file setup/getinfo - syntax/toplevel) + syntax/toplevel + (only-in mzlib/struct make-->vector)) (define original-output (current-output-port)) (define (printfo . args) (apply fprintf original-output args)) @@ -59,7 +56,7 @@ ;; only allows addition on phase2 ;; effect: updates `languages' (define add-language - (opt-lambda (language [front? #f]) + (λ (language [front? #f]) (drscheme:tools:only-in-phase 'drscheme:language:add-language 'phase2) (for-each @@ -105,7 +102,7 @@ initial-language-position) x)) (get-languages)) - (first (get-languages)))]) + (list-ref (get-languages) 0))]) (make-language-settings lang (send lang default-settings)))) ;; type language-settings = (make-language-settings (instanceof language<%>) settings) @@ -138,7 +135,7 @@ ;; as the defaults in the dialog and the output language setting is the user's choice ;; todo: when button is clicked, ensure language is selected (define language-dialog - (opt-lambda (show-welcome? language-settings-to-show [parent #f]) + (λ (show-welcome? language-settings-to-show [parent #f]) (define ret-dialog% (class dialog% (define/override (on-subwindow-char receiver evt) @@ -250,7 +247,7 @@ ;; as the defaults in the dialog and the output language setting is the user's choice ;; if re-center is a dialog, when the show details button is clicked, the dialog is recenterd. (define fill-language-dialog - (opt-lambda (parent show-details-parent language-settings-to-show + (λ (parent show-details-parent language-settings-to-show [re-center #f] [ok-handler void]) ; en/disable button, execute it @@ -258,8 +255,8 @@ (let ([request-lang-to-show (language-settings-language language-settings-to-show)]) (cond [(equal? initial-language-position (send request-lang-to-show get-language-position)) - (values (first (get-languages)) - (send (first (get-languages)) default-settings)) + (values (list-ref (get-languages) 0) + (send (list-ref (get-languages) 0) default-settings)) (values #f #f)] [else (values request-lang-to-show (language-settings-settings language-settings-to-show))]))) @@ -390,7 +387,7 @@ [parent in-source-discussion-panel] [stretchable-width #f] [min-width 32])) - (define stupid-internal-definition-syntax1 (add-discussion in-source-discussion-panel)) + (define in-source-discussion-editor-canvas (add-discussion in-source-discussion-panel)) (define most-recent-languages-hier-list-selection #f) (define use-chosen-language-rb (new radio-box% @@ -423,7 +420,7 @@ (define no-details-panel (make-object vertical-panel% details-panel)) - (define languages-table (make-hash-table)) + (define languages-table (make-hasheq)) (define languages (get-languages)) ;; selected-language : (union (instanceof language<%>) #f) @@ -631,14 +628,14 @@ [else (let* ([position (car positions)] [number (car numbers)] [sub-ht/sub-hier-list - (hash-table-get + (hash-ref ht (string->symbol position) (λ () (if first? (let* ([item (send hier-list new-item number-mixin)] - [x (list (make-hash-table) hier-list item)]) - (hash-table-put! ht (string->symbol position) x) + [x (list (make-hasheq) hier-list item)]) + (hash-set! ht (string->symbol position) x) (send item set-number number) (send item set-allow-selection #f) (let* ([editor (send item get-editor)] @@ -653,14 +650,14 @@ (if second-number (compose second-number-mixin number-mixin) number-mixin))] - [x (list (make-hash-table) new-list #f)]) + [x (list (make-hasheq) new-list #f)]) (send new-list set-number number) (when second-number (send new-list set-second-number second-number)) (send new-list set-allow-selection #t) (send new-list open) (send (send new-list get-editor) insert position) - (hash-table-put! ht (string->symbol position) x) + (hash-set! ht (string->symbol position) x) x))))]) (cond [first? @@ -907,6 +904,7 @@ (do-construct-details)) (update-show/hide-details) (send languages-hier-list focus) + (size-discussion-canvas in-source-discussion-editor-canvas) (values (λ () selected-language) (λ () @@ -920,10 +918,8 @@ [horizontal-inset 0] [vertical-inset 0] [parent p] - [style '(no-border auto-vscroll no-hscroll transparent)] + [style '(no-border no-vscroll no-hscroll transparent)] [editor t])]) - (send c set-line-count 3) - (send t set-styles-sticky #f) (send t set-autowrap-bitmap #f) (let* ([size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size))] @@ -949,37 +945,18 @@ (send t hide-caret #t) (send t auto-wrap #t) - (send t lock #t))) + (send t lock #t) + c)) - (define panel-background-editor-canvas% - (class editor-canvas% - (inherit get-dc get-client-size) - (define/override (on-paint) - (let-values ([(cw ch) (get-client-size)]) - (let* ([dc (get-dc)] - [old-pen (send dc get-pen)] - [old-brush (send dc get-brush)]) - (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel)) - (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) - (send dc draw-rectangle 0 0 cw ch) - (send dc set-pen old-pen) - (send dc set-brush old-brush))) - (super on-paint)) - (super-new))) - - (define panel-background-text% - (class text% - (define/override (on-paint before? dc left top right bottom dx dy draw-caret) - (when before? - (let ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)]) - (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel)) - (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) - (send dc draw-rectangle (+ dx left) (+ dy top) (- right left) (- bottom top)) - (send dc set-pen old-pen) - (send dc set-brush old-brush))) - (super on-paint before? dc left top right bottom dx dy draw-caret)) - (super-new))) + (define (size-discussion-canvas canvas) + (let ([t (send canvas get-editor)]) + + (let ([by (box 0)]) + (send t position-location + (send t line-end-position (send t last-line)) + #f + by) + (send canvas min-height (+ (ceiling (inexact->exact (unbox by))) 24))))) (define section-style-delta (make-object style-delta% 'change-bold)) (send section-style-delta set-delta-foreground "medium blue") @@ -1236,9 +1213,9 @@ (format "uncaught exception: ~s" x))) read-syntax/namespace-introduce)]) (contract - (opt-> () - (any/c port?) - (or/c syntax? eof-object?)) + (->* () + (any/c port?) + (or/c syntax? eof-object?)) (dynamic-require (cond [(string? reader-spec) @@ -1291,7 +1268,7 @@ (regexp-split #rx"/" str)))) (define read-syntax/namespace-introduce - (opt-lambda (source-name-v [input-port (current-input-port)]) + (λ (source-name-v [input-port (current-input-port)]) (let ([v (read-syntax source-name-v input-port)]) (if (syntax? v) (namespace-syntax-introduce v) @@ -1417,7 +1394,7 @@ (run-in-user-thread (λ () (namespace-require 'errortrace/errortrace-key) - (namespace-transformer-require 'errortrace/errortrace-key)))) + (namespace-require '(for-syntax errortrace/errortrace-key))))) (super-new))) (define (r5rs-mixin %) @@ -1767,13 +1744,12 @@ 'normal 'normal)) - (define/kw (get-font #:key - (point-size (send default-font get-point-size)) - (family (send default-font get-family)) - (style (send default-font get-style)) - (weight (send default-font get-weight)) - (underlined (send default-font get-underlined)) - (smoothing (send default-font get-smoothing))) + (define (get-font #:point-size [point-size (send default-font get-point-size)] + #:family (family (send default-font get-family)) + #:style (style (send default-font get-style)) + #:weight (weight (send default-font get-weight)) + #:underlined (underlined (send default-font get-underlined)) + #:smoothing (smoothing (send default-font get-smoothing))) (send the-font-list find-or-create-font point-size family @@ -1824,7 +1800,7 @@ (new canvas-message% (parent panel2) (label (string-constant start-with-before))) (new canvas-message% (parent panel2) - (label (car (last-pair lang))) + (label (last lang)) (color (send the-color-database find-color "blue")) (callback (λ () (change-current-lang-to lang))) (font (get-font #:underlined #t)))