From 91b6f651b475be7495476c2829b70a1557082a76 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 9 Jan 2004 19:48:54 +0000 Subject: [PATCH] tabify work original commit: 17e9e2ebedc27e6edfa193fe04d16c9e28e73fd7 --- collects/framework/private/color.ss | 11 +++- collects/framework/private/scheme.ss | 78 +++++++++++----------------- 2 files changed, 41 insertions(+), 48 deletions(-) diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss index f73ea5b5..05652da7 100644 --- a/collects/framework/private/color.ss +++ b/collects/framework/private/color.ss @@ -44,7 +44,8 @@ backward-match backward-containing-sexp forward-match - insert-close-paren)) + insert-close-paren + classify-position)) (define text-mixin (mixin (text:basic<%>) (-text<%>) @@ -540,6 +541,14 @@ ((eq? 'open p) cur-pos) ((not p) #f) (else (loop p)))))) + + ;; Determines whether a position is a 'comment, 'string, etc. + (define/public (classify-position position) + (when stopped? + (error 'classify-position "called on a color:text<%> whose colorer is stopped.")) + (tokenize-to-pos position) + (send tokens search! (- position start-pos)) + (send tokens get-root-data)) (define/private (tokenize-to-pos position) (when (and (not up-to-date?) (<= current-pos position)) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index 5674fdd9..c26fb7d7 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -393,35 +393,12 @@ backward-containing-sexp forward-match skip-whitespace - insert-close-paren) + insert-close-paren + classify-position) (inherit get-styles-fixed) (inherit has-focus? find-snip split-snip) - (define (find-enclosing-paren pos) - (let loop ([pos pos]) - (let ([paren-pos - (let loop ([pairs (scheme-paren:get-paren-pairs)] - [curr-max #f]) - (cond - [(null? pairs) curr-max] - [else (let* ([pair (car pairs)] - [fnd (find-string (car pair) 'backward pos 'eof #f)]) - (if (and fnd curr-max) - (loop (cdr pairs) - (max fnd curr-max)) - (loop (cdr pairs) - (or fnd curr-max))))]))]) - (cond - [(not paren-pos) #f] - [else - (let ([semi-pos (find-string ";" 'backward paren-pos)]) - (cond - [(or (not semi-pos) - (semi-pos . < . (paragraph-start-position (position-paragraph paren-pos)))) - paren-pos] - [else (loop (- semi-pos 1))]))])))) - (public get-limit balance-parens tabify-on-return? tabify tabify-selection tabify-all insert-return calc-last-para box-comment-out-selection comment-out-selection uncomment-selection @@ -440,7 +417,10 @@ (opt-lambda ([pos (get-start-position)]) (let* ([last-pos (last-position)] [para (position-paragraph pos)] - [okay (> para 0)] + [is-tabbable? (and (> para 0) + (not (memq (classify-position (sub1 (paragraph-start-position para))) + '(comment string error))))] + [okay (and is-tabbable? (> para 0))] [end (if okay (paragraph-start-position para) 0)] [limit (get-limit pos)] [contains @@ -533,6 +513,7 @@ #\newline))) (insert #\newline (paragraph-start-position para))) (cond + [(not is-tabbable?) (void)] [(let ([real-start (cdr (find-offset end))]) (and (<= (+ 3 real-start) (last-position)) (string=? ";;;" @@ -543,7 +524,7 @@ [(not contains) (do-indent 0)] [(not last) ;; search backwards for the opening parenthesis, and use it to align this line - (let ([enclosing (find-enclosing-paren pos)]) + (let ([enclosing (find-up-sexp pos)]) (do-indent (if enclosing (+ (visual-offset enclosing) 1) 0)))] @@ -799,27 +780,30 @@ #t))] [define find-up-sexp (lambda (start-pos) - (let* ([exp-pos - (backward-containing-sexp start-pos (get-limit start-pos))] - [paren-pos ;; find the closest open paren from this pair, behind exp-pos - (lambda (paren-pair) - (find-string - (car paren-pair) - 'backward - exp-pos))]) + (let* ([limit-pos (get-limit start-pos)] + [exp-pos + (backward-containing-sexp start-pos limit-pos)]) - (if (and exp-pos (> exp-pos 0)) - (let ([poss (let loop ([parens (scheme-paren:get-paren-pairs)]) - (cond - [(null? parens) null] - [else - (let ([pos (paren-pos (car parens))]) - (if pos - (cons pos (loop (cdr parens))) - (loop (cdr parens))))]))]) - (if (null? poss) ;; all finds failed - #f - (- (apply max poss) 1))) ;; subtract one to move outside the paren + (if (and exp-pos (> exp-pos limit-pos)) + (let* ([in-start-pos (skip-whitespace exp-pos 'backward #t)] + [paren-pos + (lambda (paren-pair) + (find-string + (car paren-pair) + 'backward + in-start-pos + limit-pos))]) + (let ([poss (let loop ([parens (scheme-paren:get-paren-pairs)]) + (cond + [(null? parens) null] + [else + (let ([pos (paren-pos (car parens))]) + (if pos + (cons pos (loop (cdr parens))) + (loop (cdr parens))))]))]) + (if (null? poss) ;; all finds failed + #f + (- (apply max poss) 1)))) ;; subtract one to move outside the paren #f)))] [define up-sexp (lambda (start-pos)