From d47be726d16b5fdd23bac12d2b6e10bf93fbabd7 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 11 Apr 2006 23:20:57 +0000
Subject: [PATCH] added automatic remapping of [ to ( in many cases; see docs
 for details

svn: r2662

original commit: 6638f46c759632de38a490284399391e1fc1c950
---
 collects/framework/private/scheme.ss |  86 +++++++++-
 collects/tests/framework/keys.ss     | 244 ++++++++++++++-------------
 collects/tests/framework/main.ss     |  71 ++++----
 3 files changed, 244 insertions(+), 157 deletions(-)

diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss
index a92d0367..ee5034f3 100644
--- a/collects/framework/private/scheme.ss
+++ b/collects/framework/private/scheme.ss
@@ -403,7 +403,7 @@
           (inherit get-styles-fixed)
           (inherit has-focus? find-snip split-snip)
           
-          (public get-limit balance-parens tabify-on-return? tabify
+          (public get-limit tabify-on-return? tabify
                   tabify-all insert-return calc-last-para 
                   box-comment-out-selection comment-out-selection uncomment-selection
                   get-forward-sexp remove-sexp forward-sexp flash-forward-sexp get-backward-sexp
@@ -411,7 +411,7 @@
                   remove-parens-forward)
           (define (get-limit pos) 0)
           
-          (define (balance-parens key-event)
+          (define/public (balance-parens key-event)
             (insert-close-paren (get-start-position) 
                                 (send key-event get-key-code)
                                 (preferences:get 'framework:paren-match)
@@ -972,6 +972,15 @@
           [define get-tab-size (λ () tab-size)]
           [define set-tab-size (λ (s) (set! tab-size s))]
                     
+          (inherit is-frozen? is-stopped?)
+          (define/public (rewrite-square-paren)
+            (insert (cond
+                      [(or (is-frozen?) (is-stopped?))
+                       #\[]
+                      [else (choose-paren this (get-start-position))])
+                    (get-start-position)
+                    (get-end-position)))
+          
           (super-instantiate ())))
 
       (define -text-mode<%>
@@ -1109,7 +1118,9 @@
             (add-edit-function "box-comment-out"  
                                (λ (x) (send x box-comment-out-selection)))
             (add-edit-function "uncomment"  
-                               (λ (x) (send x uncomment-selection))))
+                               (λ (x) (send x uncomment-selection)))
+            (add-edit-function "rewrite-square-paren"  
+                               (λ (x) (send x rewrite-square-paren))))
           
           (send keymap add-function "balance-parens"
                 (λ (edit event)
@@ -1131,6 +1142,8 @@
           (send keymap map-function "]" "balance-parens")
           (send keymap map-function "}" "balance-parens")
           
+          (send keymap map-function "[" "rewrite-square-paren")
+          
           (let ([map-meta
                  (λ (key func)
                    (keymap:send-map-function-meta keymap key func))]
@@ -1197,6 +1210,73 @@
       (setup-keymap keymap)
       (define (get-keymap) keymap)
       
+      ;; choose-paren : scheme-text number -> character
+      ;; returns the character to replace a #\[ with, based
+      ;; on the context where it is typed in.
+      (define (choose-paren text pos)
+        (if (memq (send text classify-position pos) '(string error comment symbol))
+            #\[
+            (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
+                  [(member b-m-char '(#\( #\[ #\{))
+                   ;; found a "sibling" parenthesized sequence. use the parens it uses.
+                   b-m-char]
+                  [backward-match
+                   ;; there is a sexp before this, but it isn't parenthesized.
+                   ;; if it is the `cond' keyword, we get a square bracket. otherwise not.
+                   (if (and (beginning-of-sequence? text backward-match)
+                            (text-between-equal? "cond" text backward-match before-whitespace-pos))
+                       #\[
+                       #\()]
+                  [(not (zero? before-whitespace-pos))
+                   ;; this is the first thing in the sequence
+                   ;; pop out one layer and look for a keyword.
+                   ;; if we find a let<mumble> keyword, we get a square bracket, 
+                   ;; otherwise a round paren
+                   (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)
+                             #\(]
+                            [(and (beginning-of-sequence? text second-backwards-match)
+                                  (ormap (λ (x) (text-between-equal? x
+                                                                     text
+                                                                     second-backwards-match
+                                                                     second-before-whitespace-pos))
+                                         '("let" 
+                                           "let*" "let-values" "let-syntax" "let-struct" "let-syntaxes"
+                                           "letrec"
+                                           "letrec-syntaxes" "letrec-syntaxes+values" "letrec-values")))
+                             #\[]
+                            [else
+                             #\(]))]
+                       [else 
+                        #\(]))]
+                  [else #\(])))))
+      
+      (define (beginning-of-sequence? text start)
+        (let ([before-space (send text skip-whitespace start 'backward #t)])
+          (cond
+            [(zero? before-space) #t]
+            [else
+             (member (send text get-character (- before-space 1))
+                     '(#\( #\[ #\{))])))
+      
+      (define (text-between-equal? str text start end)
+        (and (= (string-length str) (- end start))
+             (let loop ([i (string-length str)])
+               (cond
+                 [(= i 0) #t]
+                 [else
+                  (and (char=? (string-ref str (- i 1))
+                               (send text get-character (+ i start -1)))
+                       (loop (- i 1)))]))))
+      
                                                                              
                         ;;;                                            ;;;   
                        ;                                                 ;   
diff --git a/collects/tests/framework/keys.ss b/collects/tests/framework/keys.ss
index 2b5c8182..4caa31d3 100644
--- a/collects/tests/framework/keys.ss
+++ b/collects/tests/framework/keys.ss
@@ -1,129 +1,131 @@
 (module keys mzscheme
   (require "test-suite-utils.ss")
   (require (lib "include.ss"))
-
-(test
- 'keymap:aug-keymap%/get-table
- (lambda (x)
-   (equal? '((c:k "abc")) x))
- (lambda ()
-   (send-sexp-to-mred
-    '(let ([k (make-object keymap:aug-keymap%)])
-       (send k add-function "abc" void)
-       (send k map-function "c:k" "abc")
-       (hash-table-map (send k get-map-function-table) list)))))
-
-(test
- 'keymap:aug-keymap%/get-table/ht
- (lambda (x)
-   (equal? x '((c:k "def"))))
- (lambda ()
-   (send-sexp-to-mred
-    '(let ([k (make-object keymap:aug-keymap%)]
-	   [ht (make-hash-table)])
-       (send k add-function "abc" void)
-       (send k map-function "c:k" "abc")
-       (hash-table-put! ht 'c:k "def")
-       (hash-table-map (send k get-map-function-table/ht ht) list)))))
-
-(test
- 'keymap:aug-keymap%/get-table/chain1
- (lambda (x)
-   (equal? x '((c:k "abc-k2"))))
- (lambda ()
-   (send-sexp-to-mred
-    '(let ([k (make-object keymap:aug-keymap%)]
-	   [k1 (make-object keymap:aug-keymap%)]
-	   [k2 (make-object keymap:aug-keymap%)])
-       (send k1 add-function "abc-k1" void)
-       (send k1 map-function "c:k" "abc-k1")
-       (send k2 add-function "abc-k2" void)
-       (send k2 map-function "c:k" "abc-k2")
-       (send k chain-to-keymap k1 #t)
-       (send k chain-to-keymap k2 #t)
-       (hash-table-map (send k get-map-function-table) list)))))
-
-(test
- 'keymap:aug-keymap%/get-table/chain/2
- (lambda (x)
-   (equal? x '((c:k "abc-k"))))
- (lambda ()
-   (send-sexp-to-mred
-    '(let ([k (make-object keymap:aug-keymap%)]
-	   [k1 (make-object keymap:aug-keymap%)])
-       (send k1 add-function "abc-k1" void)
-       (send k1 map-function "c:k" "abc-k1")
-       (send k add-function "abc-k" void)
-       (send k map-function "c:k" "abc-k")
-       (send k chain-to-keymap k1 #t)
-       (hash-table-map (send k get-map-function-table) list)))))
-
-(define (test-canonicalize name str1 str2)
+  
   (test
-   (string->symbol (format "keymap:canonicalize-keybinding-string/~a" name))
+   'keymap:aug-keymap%/get-table
    (lambda (x)
-     (string=? x str2))
+     (equal? '((c:k "abc")) x))
    (lambda ()
      (send-sexp-to-mred
-      `(keymap:canonicalize-keybinding-string ,str2)))))
+      '(let ([k (make-object keymap:aug-keymap%)])
+         (send k add-function "abc" void)
+         (send k map-function "c:k" "abc")
+         (hash-table-map (send k get-map-function-table) list)))))
+  
+  (test
+   'keymap:aug-keymap%/get-table/ht
+   (lambda (x)
+     (equal? x '((c:k "def"))))
+   (lambda ()
+     (send-sexp-to-mred
+      '(let ([k (make-object keymap:aug-keymap%)]
+             [ht (make-hash-table)])
+         (send k add-function "abc" void)
+         (send k map-function "c:k" "abc")
+         (hash-table-put! ht 'c:k "def")
+         (hash-table-map (send k get-map-function-table/ht ht) list)))))
+  
+  (test
+   'keymap:aug-keymap%/get-table/chain1
+   (lambda (x)
+     (equal? x '((c:k "abc-k2"))))
+   (lambda ()
+     (send-sexp-to-mred
+      '(let ([k (make-object keymap:aug-keymap%)]
+             [k1 (make-object keymap:aug-keymap%)]
+             [k2 (make-object keymap:aug-keymap%)])
+         (send k1 add-function "abc-k1" void)
+         (send k1 map-function "c:k" "abc-k1")
+         (send k2 add-function "abc-k2" void)
+         (send k2 map-function "c:k" "abc-k2")
+         (send k chain-to-keymap k1 #t)
+         (send k chain-to-keymap k2 #t)
+         (hash-table-map (send k get-map-function-table) list)))))
+  
+  (test
+   'keymap:aug-keymap%/get-table/chain/2
+   (lambda (x)
+     (equal? x '((c:k "abc-k"))))
+   (lambda ()
+     (send-sexp-to-mred
+      '(let ([k (make-object keymap:aug-keymap%)]
+             [k1 (make-object keymap:aug-keymap%)])
+         (send k1 add-function "abc-k1" void)
+         (send k1 map-function "c:k" "abc-k1")
+         (send k add-function "abc-k" void)
+         (send k map-function "c:k" "abc-k")
+         (send k chain-to-keymap k1 #t)
+         (hash-table-map (send k get-map-function-table) list)))))
+  
+  (define (test-canonicalize name str1 str2)
+    (test
+     (string->symbol (format "keymap:canonicalize-keybinding-string/~a" name))
+     (lambda (x)
+       (string=? x str2))
+     (lambda ()
+       (send-sexp-to-mred
+        `(keymap:canonicalize-keybinding-string ,str2)))))
+  
+  (test-canonicalize 1 "c:a" "c:a")
+  (test-canonicalize 2 "d:a" "d:a")
+  (test-canonicalize 3 "m:a" "m:a")
+  (test-canonicalize 4 "a:a" "a:a")
+  (test-canonicalize 5 "s:a" "s:a")
+  (test-canonicalize 6 "c:a" "c:a")
+  (test-canonicalize 7 "s:m:d:c:a:a" "a:c:d:m:s:a")
+  (test-canonicalize 8 "~s:~m:~d:~c:~a:a" "~a:~c:~d:~m:~s:a")
+  (test-canonicalize 9 ":a" "~a:~c:~d:~m:~s:a")
+  (test-canonicalize 10 ":d:a" "~a:~c:d:~m:~s:a")
+  (test-canonicalize 11 "esc;s:a" "esc;s:a")
+  (test-canonicalize 12 "s:a;esc" "s:a;esc")
+  
+  (include "key-specs.ss")
+  
+  (send-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t))
+  (wait-for-frame "dummy to trick frame group")
+  
+  (define (test-key key-spec)
+    (let* ([keys ((case (system-type)
+                    [(macos macosx) key-spec-macos]
+                    [(unix) key-spec-unix]
+                    [(windows) key-spec-windows])
+                  key-spec)]
+           [before (key-spec-before key-spec)]
+           [after (key-spec-after key-spec)]
+           [process-key
+            (lambda (key)
+              (printf "process-key.1 ~s\n" key)
+              (let ([text-expect (buff-spec-string after)]
+                    [start-expect (buff-spec-start after)]
+                    [end-expect (buff-spec-end after)])
+                (test key
+                      (lambda (x) (equal? x (vector text-expect start-expect end-expect)))
+                      `(let* ([text (send (get-top-level-focus-window) get-editor)])
+                         (send text erase)
+                         (send text insert ,(buff-spec-string before))
+                         (send text set-position ,(buff-spec-start before) ,(buff-spec-end before))
+                         (test:keystroke ',(car key) ',(cdr key))
+                         (vector (send text get-text)
+                                 (send text get-start-position)
+                                 (send text get-end-position))))))])
+      (for-each process-key keys)))
+  
+  (define (test-specs frame-name frame-class specs)
+    (printf "test-specs.1\n")
+    (send-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t))
+    (printf "test-specs.2\n")
+    (wait-for-frame frame-name)
+    (printf "test-specs.3\n")
+    (for-each test-key specs)
+    (printf "test-specs.4\n")
+    (send-sexp-to-mred `(send (get-top-level-focus-window) close))
+    (printf "test-specs.5\n"))
+  
+  (test-specs "global keybingings test" 'frame:text% global-specs)
+  (test-specs "scheme mode keybindings test" 
+              '(class frame:editor%
+                 (define/override (get-editor%) scheme:text%)
+                 (super-new))
+              scheme-specs))
 
-(test-canonicalize 1 "c:a" "c:a")
-(test-canonicalize 2 "d:a" "d:a")
-(test-canonicalize 3 "m:a" "m:a")
-(test-canonicalize 4 "a:a" "a:a")
-(test-canonicalize 5 "s:a" "s:a")
-(test-canonicalize 6 "c:a" "c:a")
-(test-canonicalize 7 "s:m:d:c:a:a" "a:c:d:m:s:a")
-(test-canonicalize 8 "~s:~m:~d:~c:~a:a" "~a:~c:~d:~m:~s:a")
-(test-canonicalize 9 ":a" "~a:~c:~d:~m:~s:a")
-(test-canonicalize 10 ":d:a" "~a:~c:d:~m:~s:a")
-(test-canonicalize 11 "esc;s:a" "esc;s:a")
-(test-canonicalize 12 "s:a;esc" "s:a;esc")
-
-(include "key-specs.ss")
-
-(send-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t))
-(wait-for-frame "dummy to trick frame group")
-
-(define (test-key key-spec)
-  (let* ([keys ((case (system-type)
-		  [(macos) key-spec-macos]
-		  [(unix) key-spec-unix]
-		  [(windows) key-spec-windows])
-		key-spec)]
-	 [before (key-spec-before key-spec)]
-	 [after (key-spec-after key-spec)]
-	 [process-key
-	  (lambda (key)
-	    (let ([text-expect (buff-spec-string after)]
-		  [start-expect (buff-spec-start after)]
-		  [end-expect (buff-spec-end after)])
-	      (test key
-		    (lambda (x) (equal? x (vector text-expect start-expect end-expect)))
-		    `(let* ([text (send (get-top-level-focus-window) get-editor)])
-		       (send text erase)
-		       (send text insert ,(buff-spec-string before))
-		       (send text set-position ,(buff-spec-start before) ,(buff-spec-end before))
-		       (test:keystroke ',(car key) ',(cdr key))
-		       (vector (send text get-text)
-			       (send text get-start-position)
-			       (send text get-end-position))))))])
-    (for-each process-key keys)))
-
-(define (test-specs frame-name frame-class specs)
-  (send-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t))
-  (wait-for-frame frame-name)
-  (for-each test-key specs)
-  (send-sexp-to-mred `(send (get-top-level-focus-window) close)))
-
-(test-specs "global keybingings test" 'frame:text% global-specs)
-(test-specs "scheme mode keybindings test" 
-	    '(class frame:editor% (name)
-	       (override
-		[get-editor%
-		 (lambda ()
-		   (scheme:text-mixin text:basic%))])
-	       (sequence (super-init name)))
-	    scheme-specs)
-
-)
diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss
index 19a17053..485d81fc 100644
--- a/collects/tests/framework/main.ss
+++ b/collects/tests/framework/main.ss
@@ -1,7 +1,8 @@
 (module main mzscheme 
   (require (lib "launcher.ss" "launcher")
 	   (lib "cmdline.ss")
-	   (lib "unitsig.ss")
+	   (lib "list.ss")
+           (lib "unitsig.ss")
 	   "debug.ss"
 	   "test-suite-utils.ss")
 
@@ -50,31 +51,33 @@
 	(debug-printf admin "  backup preferences file exists, using that one~n")
 	(begin (copy-file preferences-file old-preferences-file)
 	       (debug-printf admin "  saved preferences file~n"))))
-      
-  (with-handlers ([(lambda (x) #f)
-		   (lambda (x) (display (exn-message x)) (newline))])
-    (for-each
-     (lambda (x)
-       (when (member x all-files)
-	 (shutdown-mred)
-         (load-framework-automatically #t)
-	 (let/ec k
-	   (dynamic-wind
-	    (lambda ()
-	      (set-section-name! x)
-	      (set-section-jump! k))
-	    (lambda ()
-	      (with-handlers ([(lambda (x) #t)
-			       (lambda (exn)
-				 (debug-printf schedule "~a~n" (if (exn? exn) (exn-message exn) exn)))])
-
-		(debug-printf schedule "beginning ~a test suite~n" x)
-		(dynamic-require `(lib ,x "tests" "framework") #f)
-		(debug-printf schedule "PASSED ~a test suite~n" x)))
-	    (lambda ()
-	      (reset-section-name!)
-	      (reset-section-jump!))))))
-     files-to-process))
+    
+  (define jumped-out-tests '())
+  
+  (for-each
+   (lambda (x)
+     (when (member x all-files)
+       (shutdown-mred)
+       (load-framework-automatically #t)
+       (let/ec k
+         (dynamic-wind
+          (lambda ()
+            (set! jumped-out-tests (cons x jumped-out-tests))
+            (set-section-name! x)
+            (set-section-jump! k))
+          (lambda ()
+            (with-handlers ([(lambda (x) #t)
+                             (lambda (exn)
+                               (debug-printf schedule "~a~n" (if (exn? exn) (exn-message exn) exn)))])
+              
+              (debug-printf schedule "beginning ~a test suite~n" x)
+              (dynamic-require `(lib ,x "tests" "framework") #f)
+              (set! jumped-out-tests (remq x jumped-out-tests))
+              (debug-printf schedule "PASSED ~a test suite~n" x)))
+          (lambda ()
+            (reset-section-name!)
+            (reset-section-jump!))))))
+   files-to-process)
 
   (debug-printf admin "  restoring preferences file ~s to ~s~n" old-preferences-file preferences-file)
   (when (file-exists? preferences-file)
@@ -88,10 +91,12 @@
   (shutdown-listener)
 
   (cond
-   [(null? failed-tests)
-    (printf "All tests passed.~n")]
-   [else
-    (debug-printf schedule "FAILED tests:~n")
-    (for-each (lambda (failed-test)
-		(debug-printf schedule "  ~a // ~a~n" (car failed-test) (cdr failed-test)))
-	      failed-tests)]))
+    [(not (null? jumped-out-tests))
+     (printf "Test suites ended with exns ~s\n" jumped-out-tests)]
+    [(null? failed-tests)
+     (printf "All tests passed.~n")]
+    [else
+     (debug-printf schedule "FAILED tests:~n")
+     (for-each (lambda (failed-test)
+                 (debug-printf schedule "  ~a // ~a~n" (car failed-test) (cdr failed-test)))
+               failed-tests)]))