diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index 4b894ba4..3ceeeaa1 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -21,6 +21,23 @@ (application-preferences-handler (λ () (preferences:show-dialog))) + (preferences:set-default 'framework:square-bracket:case + '("new" "case") + (λ (x) (and (list? x) (andmap string? x)))) + + (preferences:set-default 'framework:square-bracket:cond + '("case-lambda" "cond" "field" "provide/contract") + (λ (x) (and (list? x) (andmap string? x)))) + + (preferences:set-default 'framework:square-bracket:letrec + '("let" + "let*" "let-values" "let*-values" + "let-syntax" "let-struct" "let-syntaxes" + "letrec" + "letrec-syntaxes" "letrec-syntaxes+values" "letrec-values" + "parameterize") + (λ (x) (and (list? x) (andmap string? x)))) + (preferences:set-default 'framework:case-sensitive-search? #f boolean?) diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 754b2da5..80d06b46 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -660,7 +660,7 @@ for the last one, need a global "no more initialization can happen" flag. values values) (make-check scheme-panel 'framework:fixup-open-parens - (string-constant fixup-open-parens) + (string-constant fixup-open-brackets) values values) (make-check scheme-panel 'framework:paren-match diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 53d25eb1..b99b0af8 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -1234,7 +1234,10 @@ ;(printf "change-to, case ~a\n" i) (set! real-char c))] [start-pos (send text get-start-position)] - [end-pos (send text get-end-position)]) + [end-pos (send text get-end-position)] + [case-like-forms (preferences:get 'framework:square-bracket:case)] + [cond-like-forms (preferences:get 'framework:square-bracket:cond)] + [letrec-like-forms (preferences:get 'framework:square-bracket:letrec)]) (send text begin-edit-sequence #f #f) (send text insert "[" start-pos 'same #f) (when (eq? (send text classify-position pos) 'parenthesis) @@ -1248,13 +1251,13 @@ [backward-match2 (send text backward-match before-whitespace-pos2 0)]) (cond - ;; we found a new expression, two steps back, so we don't use the sibling + ;; we found a 'case'-like expression, two steps back, so we don't use the sibling ;; check here -- we just go with square brackets. [(and backward-match2 (ormap (λ (x) (text-between-equal? x text backward-match2 before-whitespace-pos2)) - '("new" "case"))) + case-like-forms)) (void)] [(member b-m-char '(#\( #\[ #\{)) ;; found a "sibling" parenthesized sequence. use the parens it uses. @@ -1266,7 +1269,7 @@ (ormap (λ (x) (text-between-equal? x text backward-match before-whitespace-pos)) - '("case-lambda" "cond" "field" "provide/contract"))) + cond-like-forms)) (change-to 2 #\())]))] [(not (zero? before-whitespace-pos)) ;; this is the first thing in the sequence @@ -1289,16 +1292,11 @@ text second-backwards-match second-before-whitespace-pos)) - '("let" - "let*" "let-values" "let*-values" - "let-syntax" "let-struct" "let-syntaxes" - "letrec" - "letrec-syntaxes" "letrec-syntaxes+values" "letrec-values" - "parameterize"))) + letrec-like-forms)) ;; we found a let keyword, so we get a square bracket (void)] [else - ;; go back one more sexp in the same row, looking for `let loop' pattern + ;; go back one more sexp in the same row, looking for `let loop' / 'case' pattern (let* ([second-before-whitespace-pos2 (send text skip-whitespace second-backwards-match 'backward @@ -1311,12 +1309,11 @@ (eq? (send text classify-position second-backwards-match) ;;; otherwise, this isn't a `let loop', it is a regular let! 'symbol) - (ormap (λ (x) - (text-between-equal? x - text - second-backwards-match2 - second-before-whitespace-pos2)) - '("let"))) + (member "let" letrec-like-forms) + (text-between-equal? "let" + text + second-backwards-match2 + second-before-whitespace-pos2)) ;; found the `(let loop (' or `case' so we keep the [ (void)] [else @@ -1370,123 +1367,210 @@ (preferences:add-panel (list (string-constant editor-prefs-panel-label) (string-constant indenting-prefs-panel-label)) - (λ (p) - (define get-keywords - (λ (hash-table) - (letrec ([all-keywords (hash-table-map hash-table list)] - [pick-out (λ (wanted in out) - (cond - [(null? in) (sort out string<=?)] - [else (if (eq? wanted (cadr (car in))) - (pick-out wanted (cdr in) (cons (symbol->string (car (car in))) out)) - (pick-out wanted (cdr in) out))]))]) - (values (pick-out 'begin all-keywords null) - (pick-out 'define all-keywords null) - (pick-out 'lambda all-keywords null))))) - (define-values (begin-keywords define-keywords lambda-keywords) - (get-keywords (car (preferences:get 'framework:tabify)))) - (define add-button-callback - (λ (keyword-type keyword-symbol list-box) - (λ (button command) - (let ([new-one - (keymap:call/text-keymap-initializer - (λ () - (get-text-from-user - (format (string-constant enter-new-keyword) keyword-type) - (format (string-constant x-keyword) keyword-type))))]) - (when new-one - (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) - (read (open-input-string new-one)))]) - (cond - [(and (symbol? parsed) - (hash-table-get (car (preferences:get 'framework:tabify)) - parsed - (λ () #f))) - (message-box (string-constant error) - (format (string-constant already-used-keyword) parsed))] - [(symbol? parsed) - (let ([ht (car (preferences:get 'framework:tabify))]) - (hash-table-put! ht parsed keyword-symbol) - (update-list-boxes ht))] - [else (message-box - (string-constant error) - (format (string-constant expected-a-symbol) new-one))]))))))) - (define delete-callback - (λ (list-box) - (λ (button command) - (let* ([selections (send list-box get-selections)] - [symbols (map (λ (x) (string->symbol (send list-box get-string x))) selections)]) - (for-each (λ (x) (send list-box delete x)) (reverse selections)) - (let ([ht (car (preferences:get 'framework:tabify))]) - (for-each (λ (x) (hash-table-remove! ht x)) symbols)))))) - (define main-panel (make-object horizontal-panel% p)) - (define make-column - (λ (string symbol keywords bang-regexp) - (let* ([vert (make-object vertical-panel% main-panel)] - [_ (make-object message% (format (string-constant x-like-keywords) string) vert)] - [box (make-object list-box% #f keywords vert void '(multiple))] - [button-panel (make-object horizontal-panel% vert)] - [text (new text-field% - (label (string-constant indenting-prefs-extra-regexp)) - (callback (λ (tf evt) - (let ([str (send tf get-value)]) - (cond - [(equal? str "") - (bang-regexp #f)] - [else - (with-handlers ([exn:fail? - (λ (x) - (color-yellow (send tf get-editor)))]) - (bang-regexp (regexp str)) - (clear-color (send tf get-editor)))])))) - (parent vert))] - [add-button (make-object button% (string-constant add-keyword) - button-panel (add-button-callback string symbol box))] - [delete-button (make-object button% (string-constant remove-keyword) - button-panel (delete-callback box))]) - (send* button-panel - (set-alignment 'center 'center) - (stretchable-height #f)) - (send add-button min-width (send delete-button get-width)) - (values box text)))) - (define (color-yellow text) - (let ([sd (make-object style-delta%)]) - (send sd set-delta-background "yellow") - (send text change-style sd 0 (send text last-position)))) - (define (clear-color text) - (let ([sd (make-object style-delta%)]) - (send sd set-delta-background "white") - (send text change-style sd 0 (send text last-position)))) - (define-values (begin-list-box begin-regexp-text) - (make-column "Begin" - 'begin - begin-keywords - (λ (x) (set-car! (cdr (preferences:get 'framework:tabify)) x)))) - (define-values (define-list-box define-regexp-text) - (make-column "Define" - 'define - define-keywords - (λ (x) (set-car! (cddr (preferences:get 'framework:tabify)) x)))) - (define-values (lambda-list-box lambda-regexp-text) - (make-column "Lambda" - 'lambda - lambda-keywords - (λ (x) (set-car! (cdddr (preferences:get 'framework:tabify)) x)))) - (define update-list-boxes - (λ (hash-table) - (let-values ([(begin-keywords define-keywords lambda-keywords) (get-keywords hash-table)] - [(reset) (λ (list-box keywords) - (send list-box clear) - (for-each (λ (x) (send list-box append x)) keywords))]) - (reset begin-list-box begin-keywords) - (reset define-list-box define-keywords) - (reset lambda-list-box lambda-keywords) - #t))) - (define update-gui - (λ (pref) - (update-list-boxes (car pref)) - (send begin-regexp-text set-value (or (object-name (cadr pref)) "")) - (send define-regexp-text set-value (or (object-name (caddr pref)) "")) - (send lambda-regexp-text set-value (or (object-name (cadddr pref)) "")))) - (preferences:add-callback 'framework:tabify (λ (p v) (update-gui v))) - main-panel)))))) + make-indenting-prefs-panel) + (preferences:add-panel + (list (string-constant editor-prefs-panel-label) + (string-constant square-bracket-prefs-panel-label)) + make-square-bracket-prefs-panel)) + + (define (make-square-bracket-prefs-panel p) + (define main-panel (make-object vertical-panel% p)) + (define boxes-panel (new horizontal-panel% [parent main-panel])) + (define pref-syms (list 'framework:square-bracket:case + 'framework:square-bracket:cond + 'framework:square-bracket:letrec)) + (define pref-prefixes '("Case" "Cond" "Letrec")) + + (define (mk-list-box sym keyword-type) + (letrec ([vp (new vertical-panel% [parent boxes-panel])] + [_ (new message% + [label (format (string-constant x-like-keywords) keyword-type)] + [parent vp])] + [lb + (new list-box% + [label #f] + [parent vp] + [choices (preferences:get sym)] + [callback + (λ (lb evt) + (send remove-button enable (pair? (send lb get-selections))))])] + [bp (new horizontal-panel% [parent vp] [stretchable-height #f])] + [add + (new button% + [label (string-constant add-keyword)] + [parent bp] + [callback + (λ (x y) + (let ([new-one + (keymap:call/text-keymap-initializer + (λ () + (get-text-from-user + (format (string-constant enter-new-keyword) keyword-type) + (format (string-constant x-keyword) keyword-type))))]) + (when new-one + (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) + (read (open-input-string new-one)))]) + (when parsed + (preferences:set sym (append (preferences:get sym) + (list new-one))))))))])] + [remove-button + (new button% + [label (string-constant remove-keyword)] + [parent bp] + [callback + (λ (x y) + (let ([s (send lb get-string-selection)] + [n (send lb get-selections)]) + (when s + (preferences:set sym (remove s (preferences:get sym))) + (cond + [(= 0 (send lb get-number)) + (send remove-button enable #f)] + [else + (send lb set-selection + (max (- (send lb get-number) 1) + (car n)))]))))])]) + (unless (pair? (send lb get-selections)) + (send remove-button enable #f)) + (preferences:add-callback sym + (λ (p v) + (send lb clear) + (for-each (λ (x) (send lb append x)) v))))) + (define stupid-internal-definition-syntax1 + (for-each mk-list-box pref-syms pref-prefixes)) + + (define check-box (new check-box% + [parent main-panel] + [label (string-constant fixup-open-brackets)] + [callback + (λ (x y) + (preferences:set 'framework:fixup-open-parens (send check-box get-value)))])) + (preferences:add-callback + 'framework:fixup-open-parens + (λ (p v) + (send check-box set-value v))) + + main-panel) + + (define (make-indenting-prefs-panel p) + (define get-keywords + (λ (hash-table) + (letrec ([all-keywords (hash-table-map hash-table list)] + [pick-out (λ (wanted in out) + (cond + [(null? in) (sort out string<=?)] + [else (if (eq? wanted (cadr (car in))) + (pick-out wanted (cdr in) (cons (symbol->string (car (car in))) out)) + (pick-out wanted (cdr in) out))]))]) + (values (pick-out 'begin all-keywords null) + (pick-out 'define all-keywords null) + (pick-out 'lambda all-keywords null))))) + (define-values (begin-keywords define-keywords lambda-keywords) + (get-keywords (car (preferences:get 'framework:tabify)))) + (define add-button-callback + (λ (keyword-type keyword-symbol list-box) + (λ (button command) + (let ([new-one + (keymap:call/text-keymap-initializer + (λ () + (get-text-from-user + (format (string-constant enter-new-keyword) keyword-type) + (format (string-constant x-keyword) keyword-type))))]) + (when new-one + (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) + (read (open-input-string new-one)))]) + (cond + [(and (symbol? parsed) + (hash-table-get (car (preferences:get 'framework:tabify)) + parsed + (λ () #f))) + (message-box (string-constant error) + (format (string-constant already-used-keyword) parsed))] + [(symbol? parsed) + (let ([ht (car (preferences:get 'framework:tabify))]) + (hash-table-put! ht parsed keyword-symbol) + (update-list-boxes ht))] + [else (message-box + (string-constant error) + (format (string-constant expected-a-symbol) new-one))]))))))) + (define delete-callback + (λ (list-box) + (λ (button command) + (let* ([selections (send list-box get-selections)] + [symbols (map (λ (x) (string->symbol (send list-box get-string x))) selections)]) + (for-each (λ (x) (send list-box delete x)) (reverse selections)) + (let ([ht (car (preferences:get 'framework:tabify))]) + (for-each (λ (x) (hash-table-remove! ht x)) symbols)))))) + (define main-panel (make-object horizontal-panel% p)) + (define make-column + (λ (string symbol keywords bang-regexp) + (let* ([vert (make-object vertical-panel% main-panel)] + [_ (make-object message% (format (string-constant x-like-keywords) string) vert)] + [box (make-object list-box% #f keywords vert void '(multiple))] + [button-panel (make-object horizontal-panel% vert)] + [text (new text-field% + (label (string-constant indenting-prefs-extra-regexp)) + (callback (λ (tf evt) + (let ([str (send tf get-value)]) + (cond + [(equal? str "") + (bang-regexp #f)] + [else + (with-handlers ([exn:fail? + (λ (x) + (color-yellow (send tf get-editor)))]) + (bang-regexp (regexp str)) + (clear-color (send tf get-editor)))])))) + (parent vert))] + [add-button (make-object button% (string-constant add-keyword) + button-panel (add-button-callback string symbol box))] + [delete-button (make-object button% (string-constant remove-keyword) + button-panel (delete-callback box))]) + (send* button-panel + (set-alignment 'center 'center) + (stretchable-height #f)) + (send add-button min-width (send delete-button get-width)) + (values box text)))) + (define (color-yellow text) + (let ([sd (make-object style-delta%)]) + (send sd set-delta-background "yellow") + (send text change-style sd 0 (send text last-position)))) + (define (clear-color text) + (let ([sd (make-object style-delta%)]) + (send sd set-delta-background "white") + (send text change-style sd 0 (send text last-position)))) + (define-values (begin-list-box begin-regexp-text) + (make-column "Begin" + 'begin + begin-keywords + (λ (x) (set-car! (cdr (preferences:get 'framework:tabify)) x)))) + (define-values (define-list-box define-regexp-text) + (make-column "Define" + 'define + define-keywords + (λ (x) (set-car! (cddr (preferences:get 'framework:tabify)) x)))) + (define-values (lambda-list-box lambda-regexp-text) + (make-column "Lambda" + 'lambda + lambda-keywords + (λ (x) (set-car! (cdddr (preferences:get 'framework:tabify)) x)))) + (define update-list-boxes + (λ (hash-table) + (let-values ([(begin-keywords define-keywords lambda-keywords) (get-keywords hash-table)] + [(reset) (λ (list-box keywords) + (send list-box clear) + (for-each (λ (x) (send list-box append x)) keywords))]) + (reset begin-list-box begin-keywords) + (reset define-list-box define-keywords) + (reset lambda-list-box lambda-keywords) + #t))) + (define update-gui + (λ (pref) + (update-list-boxes (car pref)) + (send begin-regexp-text set-value (or (object-name (cadr pref)) "")) + (send define-regexp-text set-value (or (object-name (caddr pref)) "")) + (send lambda-regexp-text set-value (or (object-name (cadddr pref)) "")))) + (preferences:add-callback 'framework:tabify (λ (p v) (update-gui v))) + main-panel) + + )))