From 40c68df514e54212113db57cdd7855ec7bd51098 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 8 Aug 2011 19:29:22 -0500 Subject: [PATCH] fix the auto-square-bracket thing for with-syntax closes PR 12096 --- collects/framework/private/scheme.rkt | 9 ++++--- collects/tests/framework/scheme.rkt | 35 +++++++++++++++++++++++++++ 2 files changed, 41 insertions(+), 3 deletions(-) diff --git a/collects/framework/private/scheme.rkt b/collects/framework/private/scheme.rkt index 898188173f..f10ef10a2e 100644 --- a/collects/framework/private/scheme.rkt +++ b/collects/framework/private/scheme.rkt @@ -13,6 +13,7 @@ "../preferences.rkt" scheme/match) + (import mred^ [prefix preferences: framework:preferences^] [prefix icon: framework:icon^] @@ -34,7 +35,7 @@ (init-depend mred^ framework:keymap^ framework:color^ framework:mode^ framework:text^ framework:editor^) - +(define-local-member-name stick-to-next-sexp?) (define (scheme-paren:get-paren-pairs) '(("(" . ")") @@ -879,7 +880,7 @@ (delete snip-pos (+ snip-pos 1))) (set-position pos pos))) - (define/private (stick-to-next-sexp? start-pos) + (define/public (stick-to-next-sexp? start-pos) (let ([end-pos (forward-match start-pos (last-position))]) (and end-pos (member (get-text start-pos end-pos) @@ -1592,7 +1593,9 @@ [backward-match (let ([before-whitespace-pos (send text skip-whitespace backward-match 'backward #t)]) (loop before-whitespace-pos - (+ n 1)))] + (if (send text stick-to-next-sexp? backward-match) + n + (+ n 1))))] [else (let* ([afterwards (send text get-forward-sexp pos)] [keyword diff --git a/collects/tests/framework/scheme.rkt b/collects/tests/framework/scheme.rkt index bac60ad988..217d41d7ec 100644 --- a/collects/tests/framework/scheme.rkt +++ b/collects/tests/framework/scheme.rkt @@ -54,3 +54,38 @@ (test-indentation 6 "(define x\n (let/ec return\n (when 1\n (when 2\n\t\t 3))\n 2))" "(define x\n (let/ec return\n (when 1\n (when 2\n 3))\n 2))") + +(define (test-magic-square-bracket which before after) + (test + (string->symbol (format "scheme:test-magic-square-bracket-~a" which)) + (λ (x) (equal? x after)) + (λ () + (queue-sexp-to-mred + `(let* ([t (new scheme:text%)] + [f (new frame% [label ""] [width 600] [height 600])] + [ec (new editor-canvas% [parent f] [editor t])]) + (send f reflow-container) + (send t insert ,before) + (send t rewrite-square-paren) + (send t get-text)))))) + +(test-magic-square-bracket 'mt "" "(") +(test-magic-square-bracket 'mt2 "(() " "(() (") +(test-magic-square-bracket 'mt3 "([] " "([] [") +(test-magic-square-bracket 'mt4 "(\"" "(\"[") +(test-magic-square-bracket 'mt4 "(#\\" "(#\\[") +(test-magic-square-bracket 'let1 "(let " "(let (") +(test-magic-square-bracket 'let2 "(let (" "(let ([") +(test-magic-square-bracket 'let3 "(let loop " "(let loop (") +(test-magic-square-bracket 'let3 "(let loop (" "(let loop ([") +(test-magic-square-bracket 'cond1 "(cond " "(cond [") +(test-magic-square-bracket 'cond2 "(cond [" "(cond [(") +(test-magic-square-bracket 'with-syntax1 "(syntax-case x " "(syntax-case x (") +(test-magic-square-bracket 'with-syntax2 "(syntax-case x () " "(syntax-case x () [") +(test-magic-square-bracket 'with-syntax3 "(syntax-case 'x " "(syntax-case 'x (") +(test-magic-square-bracket 'with-syntax4 "(syntax-case 'x () " "(syntax-case 'x () [") +(test-magic-square-bracket 'with-syntax3 "(syntax-case #'x " "(syntax-case #'x (") +(test-magic-square-bracket 'with-syntax4 "(syntax-case #'x () " "(syntax-case #'x () [") +(test-magic-square-bracket 'local1 "(local " "(local [") +(test-magic-square-bracket 'local2 "(local [" "(local [(") +(test-magic-square-bracket 'local2 "(local [(define x 1)] " "(local [(define x 1)] (")