From c1350ef9d8b1eac3ae653239af1c83dc2ba9d6dd Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 5 Oct 2006 21:32:58 +0000 Subject: [PATCH] improved magic square bracket stuff svn: r4496 --- collects/framework/private/main.ss | 17 ++ collects/framework/private/scheme.ss | 278 +++++++++++------- .../english-string-constants.ss | 5 +- 3 files changed, 194 insertions(+), 106 deletions(-) diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index 3ceeeaa11b..8297c8212f 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -29,6 +29,23 @@ '("case-lambda" "cond" "field" "provide/contract") (λ (x) (and (list? x) (andmap string? x)))) + + (preferences:set-default 'framework:square-bracket:cond/offset + '(("case-lambda" 0) + ("cond" 0) + ("field" 0) + ("provide/contract" 0) + ("new" 1) + ("case" 1) + ("syntax-case" 2) + ("syntax-case*" 3)) + (λ (x) (and (list? x) (andmap (λ (x) (and (pair? x) + (string? (car x)) + (pair? (cdr x)) + (number? (cadr x)) + (null? (cddr x)))) + x)))) + (preferences:set-default 'framework:square-bracket:letrec '("let" "let*" "let-values" "let*-values" diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index b99b0af874..12ba5ddea3 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -13,7 +13,8 @@ (lib "thread.ss") (lib "etc.ss") (lib "surrogate.ss") - (lib "scheme-lexer.ss" "syntax-color")) + (lib "scheme-lexer.ss" "syntax-color") + "../gui-utils.ss") (provide scheme@) @@ -1235,94 +1236,103 @@ (set! real-char c))] [start-pos (send text get-start-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) (let* ([before-whitespace-pos (send text skip-whitespace pos 'backward #t)] - [backward-match (send text backward-match before-whitespace-pos 0)]) - (let ([b-m-char (and (number? backward-match) (send text get-character backward-match))]) - (cond - [backward-match - ;; there is an expression before this, at this layer - (let* ([before-whitespace-pos2 (send text skip-whitespace backward-match 'backward #t)] - [backward-match2 (send text backward-match before-whitespace-pos2 0)]) - - (cond - ;; 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)) - case-like-forms)) - (void)] - [(member b-m-char '(#\( #\[ #\{)) - ;; found a "sibling" parenthesized sequence. use the parens it uses. - (change-to 1 b-m-char)] - [else - ;; there is a sexp before this, but it isn't parenthesized. - ;; if it is the `cond' keyword, we get a square bracket. otherwise not. - (unless (and (beginning-of-sequence? text backward-match) - (ormap - (λ (x) - (text-between-equal? x text backward-match before-whitespace-pos)) - cond-like-forms)) - (change-to 2 #\())]))] - [(not (zero? before-whitespace-pos)) - ;; this is the first thing in the sequence - ;; pop out one layer and look for a keyword. - (let ([b-w-p-char (send text get-character (- before-whitespace-pos 1))]) - (cond - [(equal? b-w-p-char #\() - (let* ([second-before-whitespace-pos (send text skip-whitespace - (- before-whitespace-pos 1) - 'backward - #t)] - [second-backwards-match (send text backward-match - second-before-whitespace-pos - 0)]) - (cond - [(not second-backwards-match) - (change-to 3 #\()] - [(and (beginning-of-sequence? text second-backwards-match) - (ormap (λ (x) (text-between-equal? x - text - second-backwards-match - second-before-whitespace-pos)) - 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' / 'case' pattern - (let* ([second-before-whitespace-pos2 (send text skip-whitespace - second-backwards-match - 'backward - #t)] - [second-backwards-match2 (send text backward-match - second-before-whitespace-pos2 - 0)]) - (cond - [(and second-backwards-match2 - (eq? (send text classify-position second-backwards-match) - ;;; otherwise, this isn't a `let loop', it is a regular let! - 'symbol) - (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 - ;; otherwise, round. - (change-to 4 #\()]))]))] - [else - (change-to 5 #\()]))] - [else - (change-to 6 #\()])))) + [matched-cond-like-keyword + ;; searches backwards for the keyword in the sequence at this level. + ;; if found, it counts how many sexps back it was and then uses that to + ;; check the preferences. + (let loop ([pos before-whitespace-pos] + [n 0]) + (let ([backward-match (send text backward-match pos 0)]) + (cond + [backward-match + (let ([before-whitespace-pos (send text skip-whitespace backward-match 'backward #t)]) + (loop before-whitespace-pos + (+ n 1)))] + [else + (let* ([afterwards (send text forward-match pos (send text last-position))] + [keyword + (and afterwards + (send text get-text pos afterwards))]) + (and keyword + (member (list keyword (- n 1)) + (preferences:get 'framework:square-bracket:cond/offset))))])))]) + (cond + [matched-cond-like-keyword + ;; just leave the square backet in, in this case + (void)] + [else + (let* ([backward-match (send text backward-match before-whitespace-pos 0)] + [b-m-char (and (number? backward-match) (send text get-character backward-match))]) + (cond + [backward-match + ;; there is an expression before this, at this layer + (let* ([before-whitespace-pos2 (send text skip-whitespace backward-match 'backward #t)] + [backward-match2 (send text backward-match before-whitespace-pos2 0)]) + + (cond + [(member b-m-char '(#\( #\[ #\{)) + ;; found a "sibling" parenthesized sequence. use the parens it uses. + (change-to 1 b-m-char)] + [else + ;; otherwise, we switch to ( + (change-to 2 #\()]))] + [(not (zero? before-whitespace-pos)) + ;; this is the first thing in the sequence + ;; pop out one layer and look for a keyword. + (let ([b-w-p-char (send text get-character (- before-whitespace-pos 1))]) + (cond + [(equal? b-w-p-char #\() + (let* ([second-before-whitespace-pos (send text skip-whitespace + (- before-whitespace-pos 1) + 'backward + #t)] + [second-backwards-match (send text backward-match + second-before-whitespace-pos + 0)]) + (cond + [(not second-backwards-match) + (change-to 3 #\()] + [(and (beginning-of-sequence? text second-backwards-match) + (ormap (λ (x) (text-between-equal? x + text + second-backwards-match + second-before-whitespace-pos)) + 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 + (let* ([second-before-whitespace-pos2 (send text skip-whitespace + second-backwards-match + 'backward + #t)] + [second-backwards-match2 (send text backward-match + second-before-whitespace-pos2 + 0)]) + (cond + [(and second-backwards-match2 + (eq? (send text classify-position second-backwards-match) + ;;; otherwise, this isn't a `let loop', it is a regular let! + 'symbol) + (member "let" letrec-like-forms) + (text-between-equal? "let" + text + second-backwards-match2 + second-before-whitespace-pos2)) + ;; found the `(let loop (' so we keep the [ + (void)] + [else + ;; otherwise, round. + (change-to 4 #\()]))]))] + [else + (change-to 5 #\()]))] + [else + (change-to 6 #\()]))]))) (send text delete pos (+ pos 1) #f) (send text end-edit-sequence) (send text insert real-char start-pos end-pos))) @@ -1381,7 +1391,7 @@ 'framework:square-bracket:letrec)) (define pref-prefixes '("Case" "Cond" "Letrec")) - (define (mk-list-box sym keyword-type) + (define (mk-list-box sym keyword-type pref->string get-new-one) (letrec ([vp (new vertical-panel% [parent boxes-panel])] [_ (new message% [label (format (string-constant x-like-keywords) keyword-type)] @@ -1390,7 +1400,7 @@ (new list-box% [label #f] [parent vp] - [choices (preferences:get sym)] + [choices (map pref->string (preferences:get sym))] [callback (λ (lb evt) (send remove-button enable (pair? (send lb get-selections))))])] @@ -1401,43 +1411,101 @@ [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))))]) + (let ([new-one (get-new-one)]) (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))))))))])] + (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))) + (let ([n (send lb get-selections)]) + (when (pair? n) + (preferences:set + sym + (let loop ([i 0] + [prefs (preferences:get sym)]) + (cond + [(= i (car n)) (cdr prefs)] + [else (cons (car prefs) + (loop (+ i 1) + (cdr prefs)))]))) (cond [(= 0 (send lb get-number)) (send remove-button enable #f)] [else (send lb set-selection - (max (- (send lb get-number) 1) - (car n)))]))))])]) + (if (= (car n) (send lb get-number)) + (- (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))))) + (for-each (λ (x) (send lb append (pref->string x))) v))))) + + (define (get-new-letrec-keyword) + (let ([new-one + (keymap:call/text-keymap-initializer + (λ () + (get-text-from-user + (format (string-constant enter-new-keyword) "Letrec") + (format (string-constant x-keyword) "Letrec"))))]) + (and new-one + (let ([parsed (with-handlers ((exn:fail:read? (λ (x) #f))) + (read (open-input-string new-one)))]) + parsed)))) + + (define (get-new-cond-keyword) + (define f (new dialog% [label (format (string-constant enter-new-keyword) "Cond")])) + (define tb (keymap:call/text-keymap-initializer + (λ () + (new text-field% + [parent f] + [label #f])))) + (define number-panel (new horizontal-panel% [parent f] [stretchable-height #f])) + (define number-label (new message% [parent number-panel] [label (string-constant skip-subexpressions)])) + (define number + (keymap:call/text-keymap-initializer + (λ () + (new text-field% + [parent number-panel] + [init-value "1"] + [min-width 50] + [label #f])))) + + (define answers #f) + (define bp (new horizontal-panel% + [parent f] + [stretchable-height #f] + [alignment '(right center)])) + (define (confirm-callback b e) + (let ([n (string->number (send number get-value))] + [sym (with-handlers ([exn:fail:read? (λ (x) #f)]) + (read (open-input-string (send tb get-value))))]) + (when (and (number? n) + (symbol? sym)) + (set! answers (list (symbol->string sym) n))) + (send f show #f))) + + (define (cancel-callback b e) + (send f show #f)) + + (define-values (ok-button cancel-button) + (gui-utils:ok/cancel-buttons bp confirm-callback cancel-callback (string-constant ok) (string-constant cancel))) + (send f show #t) + answers) + (define stupid-internal-definition-syntax1 - (for-each mk-list-box pref-syms pref-prefixes)) + (mk-list-box 'framework:square-bracket:letrec "Letrec" values get-new-letrec-keyword)) + (define stupid-internal-definition-syntax2 + (mk-list-box 'framework:square-bracket:cond/offset + "Cond" + (λ (l) (format "~a (~a)" (car l) (cadr l))) + get-new-cond-keyword)) (define check-box (new check-box% [parent main-panel] diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index 9e5c44d6c5..f94533ae68 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -452,13 +452,16 @@ please adhere to these guidelines: (indenting-prefs-panel-label "Indenting") (indenting-prefs-extra-regexp "Extra regexp") - (square-bracket-prefs-panel-label "Square bracket") + (square-bracket-prefs-panel-label "Square Bracket") ; filled with define, lambda, or begin (enter-new-keyword "Enter new ~a-like keyword:") (x-keyword "~a Keyword") (x-like-keywords "~a-like Keywords") + ; used in Square bracket panel + (skip-subexpressions "Number of sub-expressions to skip") + (expected-a-symbol "expected a symbol, found: ~a") (already-used-keyword "\"~a\" is already a specially indented keyword") (add-keyword "Add")