From: Taylor R. Campbell Date: Thu, 4 Sep 2008 21:55:20 +0000 (+0000) Subject: Implement kludges to incrementally expand and contract summary buffers X-Git-Tag: 20090517-FFI~179 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4484d6663d6b57af6fc607171a2d44d8e85ef47e;p=mit-scheme.git Implement kludges to incrementally expand and contract summary buffers as messages are added to and expunged from the corresponding folders. --- diff --git a/v7/src/imail/imail-summary.scm b/v7/src/imail/imail-summary.scm index 964f51331..50596eb74 100644 --- a/v7/src/imail/imail-summary.scm +++ b/v7/src/imail/imail-summary.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: imail-summary.scm,v 1.59 2008/08/31 19:32:09 riastradh Exp $ +$Id: imail-summary.scm,v 1.60 2008/09/04 21:55:20 riastradh Exp $ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, @@ -158,13 +158,16 @@ SUBJECT is a string of regexps separated by commas." "Display a summary of the search results for a string of text." "sSearch string" (lambda (pattern) - (imail-summary (string-append "Search: " pattern) - (lambda (folder) - ((imail-ui:message-wrapper "Searching for " pattern) - (lambda () - (map (lambda (index) - (get-message folder index)) - (search-folder folder pattern)))))))) + (imail-summary + (string-append "Search: " pattern) + (lambda (folder start end) + ((imail-ui:message-wrapper "Searching for " pattern) + (lambda () + (filter-map (lambda (index) + (and (<= start index) + (< index end) + (%get-message folder index))) + (%search-folder folder pattern)))))))) (define (imail-summary description procedure) (let* ((folder (selected-folder)) @@ -202,22 +205,20 @@ SUBJECT is a string of regexps separated by commas." (if (pair? windows) (select-window (car windows)) (select-buffer buffer)))) - (preload-folder-outlines folder) (rebuild-imail-summary-buffer buffer))) (define (imail-summary-by-predicate description predicate) (imail-summary description - (lambda (folder) - (let ((end (folder-length folder))) - (let loop ((i 0) (messages '())) - (if (< i end) - (loop (+ i 1) - (let ((message (get-message folder i))) - (if (predicate message) - (cons message messages) - messages))) - (reverse! messages))))))) + (lambda (folder start end) + (let loop ((i start) (messages '())) + (if (< i end) + (loop (+ i 1) + (let ((message (get-message folder i))) + (if (predicate message) + (cons message messages) + messages))) + (reverse! messages)))))) (define (imail-summary-detach buffer) (let ((folder-buffer (buffer-get buffer 'IMAIL-FOLDER-BUFFER #f))) @@ -256,26 +257,35 @@ SUBJECT is a string of regexps separated by commas." (let ((buffer (imail-folder->summary-buffer folder #f))) (if buffer (case type + ((STATUS) + (maybe-add-command-suffix! buffer-modeline-event! + buffer + 'PROCESS-STATUS)) ((FLAGS) (let ((message (car parameters))) - (call-with-values - (lambda () (imail-summary-find-message buffer message)) - (lambda (mark approximate?) - (if (and mark (not approximate?)) - (begin - (let ((mark (mark+ mark 1 'ERROR))) - (with-read-only-defeated mark - (lambda () - (group-replace-string! - (mark-group mark) - (mark-index mark) - (message-flag-markers message))))) - (buffer-not-modified! buffer))))))) + (maybe-add-command-suffix! adjust-imail-summary-flags + buffer + message))) ((SELECT-MESSAGE) (let ((message (car parameters))) (if message - (imail-summary-select-message buffer message)))) - ((EXPUNGE INCREASE-LENGTH SET-LENGTH REORDERED) + (maybe-add-command-suffix! imail-summary-select-message + buffer + message)))) + ((INCREASE-LENGTH) + (let ((index (car parameters)) + (count (cadr parameters)) + (procedure (buffer-get buffer 'IMAIL-SUMMARY-PROCEDURE))) + (expand-imail-summary-buffer buffer + (procedure folder index count)))) + ((EXPUNGE) + (let ((message (car parameters)) + (%index (cadr parameters)) + (index (caddr parameters)) + (key (cadddr parameters))) + %index key ;ignore + (expunge-from-imail-summary-buffer buffer message index))) + ((SET-LENGTH REORDERED) (maybe-add-command-suffix! rebuild-imail-summary-buffer buffer)))))) ;;;; Summary content generation @@ -283,8 +293,9 @@ SUBJECT is a string of regexps separated by commas." (define (rebuild-imail-summary-buffer buffer) (let ((folder (selected-folder #f buffer))) (if folder - (let ((msg "Generating summary buffer...")) - (message msg) + (let ((msg "Generating summary buffer")) + (preload-folder-outlines folder) + (message msg "...") (buffer-widen! buffer) (with-read-only-defeated (buffer-start buffer) (lambda () @@ -293,11 +304,12 @@ SUBJECT is a string of regexps separated by commas." folder (buffer-get buffer 'IMAIL-SUMMARY-PROCEDURE - #f)))) + #f) + msg))) (set-buffer-major-mode! buffer (ref-mode-object imail-summary)) (buffer-not-modified! buffer) (set-buffer-point! buffer (imail-summary-first-line buffer)) - (message msg "done") + (message msg "...done") (let ((message (selected-message #f (buffer-get buffer @@ -305,12 +317,13 @@ SUBJECT is a string of regexps separated by commas." (if message (imail-summary-select-message buffer message))))))) -(define (fill-imail-summary-buffer! buffer folder procedure) +(define (fill-imail-summary-buffer! buffer folder procedure msg) (buffer-remove! buffer 'IMAIL-SUMMARY-MESSAGES) (let ((end (folder-length folder))) - (let ((messages (procedure folder)) + (let ((messages (procedure folder 0 end)) (index-digits (exact-nonnegative-integer-digits end)) (show-date? (ref-variable imail-summary-show-date buffer))) + (buffer-put! buffer 'IMAIL-SUMMARY-INDEX-DIGITS index-digits) (let ((mark (mark-left-inserting-copy (buffer-start buffer)))) (insert-string " Flags" mark) (insert-string " " mark) @@ -337,7 +350,7 @@ SUBJECT is a string of regexps separated by commas." (max 4 (- (mark-x-size mark) (+ (mark-column mark) 1))) mark) (insert-newline mark) - ((imail-ui:message-wrapper "Generating summary buffer") + ((imail-ui:message-wrapper msg) (lambda () (do ((total (length messages)) (messages messages (cdr messages)) @@ -349,12 +362,148 @@ SUBJECT is a string of regexps separated by commas." (mark-temporary! mark)) (buffer-put! buffer 'IMAIL-SUMMARY-MESSAGES (list->vector messages))))) +(define (expand-imail-summary-buffer buffer new-messages) + (let ((old-messages (buffer-get buffer 'IMAIL-SUMMARY-MESSAGES #f)) + (index-digits (buffer-get buffer 'IMAIL-SUMMARY-INDEX-DIGITS #f)) + (folder (imail-summary-buffer->folder buffer #t)) + (msg "Expanding IMAIL summary buffer")) + (define (lose) + (message msg "...failed") + (maybe-add-command-suffix! rebuild-imail-summary-buffer buffer)) + (define (win messages) + (buffer-put! buffer 'IMAIL-SUMMARY-MESSAGES + (list->vector (reverse! messages))) + (message msg "...done")) + (define (insert new-message mark) + (message msg "...message " (number->string (message-index new-message))) + (with-read-only-defeated buffer + (lambda () + (write-imail-summary-line! new-message index-digits mark)))) + (define (merge new-messages old-messages mark messages) + (cond ((not (pair? new-messages)) + (win (append-reverse old-messages messages))) + ((not (pair? old-messages)) + (let ((mark (mark-permanent-copy mark))) + (for-each (lambda (new-message) + (insert new-message mark)) + new-messages)) + (win (append-reverse new-messages messages))) + (else + (let ((new-message (car new-messages)) + (old-message (car old-messages))) + (cond ((< (message-index new-message) + (message-index old-message)) + (let ((mark* (mark-permanent-copy mark))) + (insert new-message mark*) + (mark-temporary! mark*) + (merge (cdr new-messages) + old-messages + mark* + (cons new-message messages)))) + ((eqv? (imail-summary-selected-message-index mark) + (message-index old-message)) + (merge new-messages + (cdr old-messages) + (line-start mark 1) + (cons old-message messages))) + (else + (lose))))))) + (message msg "...") + (preload-folder-outlines folder) + (if (and old-messages + (positive? (vector-length old-messages)) + (eqv? index-digits + (exact-nonnegative-integer-digits (folder-length folder)))) + (receive (mark approximate?) + (imail-summary-find-message buffer (vector-ref old-messages 0) #f) + (if (or (not mark) approximate?) + (lose) + (merge new-messages + (vector->list old-messages) + mark + '()))) + (lose)))) + +(define (expunge-from-imail-summary-buffer buffer expunged-message index) + (let ((messages (buffer-get buffer 'IMAIL-SUMMARY-MESSAGES #f)) + (msg + (string-append "Expunging message " + (number->string index) + " from IMAIL summary buffer"))) + (define (lose) + (message msg "...failed") + (maybe-add-command-suffix! rebuild-imail-summary-buffer buffer)) + (define (win index) + (let* ((end (vector-length messages)) + (copy (make-vector (- end 1)))) + (subvector-move-right! messages 0 index copy 0) + (subvector-move-right! messages (+ index 1) end copy index) + (buffer-put! buffer 'IMAIL-SUMMARY-MESSAGES copy)) + (message msg "...done")) + (message msg "...") + (if messages + (let ((summary-index + (vector-find-next-element messages expunged-message))) + (if summary-index + (let ((mark + (line-start (imail-summary-first-line buffer) + summary-index + #f))) + (if (and mark + (eqv? (imail-summary-selected-message-index mark) + index)) + (begin + (with-read-only-defeated buffer + (lambda () + (delete-string mark (line-start mark 1 'LIMIT)))) + (if (maybe-decrement-imail-summary-indices buffer index) + (win summary-index) + (lose))) + (lose))) + (lose))) + (lose)))) + +(define (maybe-decrement-imail-summary-indices buffer index) + (let ((index-digits (buffer-get buffer 'IMAIL-SUMMARY-INDEX-DIGITS #f))) + (and index-digits + (let loop ((mark (imail-summary-first-line buffer))) + (or (group-end? mark) + ;; One space, five flags, and one more space: seven columns. + (let* ((mark (mark+ mark 7)) + (mark* (mark+ mark index-digits)) + (index* + (string->number + (string-trim (extract-string mark mark*))))) + (and index* + (begin + (if (> index* index) + (let ((mark (mark-permanent-copy mark))) + (with-read-only-defeated buffer + (lambda () + (delete-string mark mark*) + (insert-message-index (- index* 1) + index-digits + mark))) + (mark-temporary! mark))) + (loop (line-start mark 1 'LIMIT)))))))))) + +(define (adjust-imail-summary-flags buffer message) + (receive (mark approximate?) (imail-summary-find-message buffer message #f) + (if (and mark (not approximate?)) + (begin + (let ((mark (mark+ mark 1 'ERROR))) + (with-read-only-defeated mark + (lambda () + (group-replace-string! (mark-group mark) + (mark-index mark) + (message-flag-markers message)))) + (buffer-not-modified! buffer)))))) + (define (write-imail-summary-line! message index-digits mark) (insert-char #\space mark) (insert-string (message-flag-markers message) mark) (insert-char #\space mark) - (insert-string-pad-left (number->string (+ (message-index message) 1)) - index-digits #\space mark) + (insert-message-index (+ (message-index message) 1) index-digits mark) (insert-string " " mark) (insert-string (message-summary-length-string message) mark) (if (ref-variable imail-summary-show-date mark) @@ -373,6 +522,9 @@ SUBJECT is a string of regexps separated by commas." (insert-string (message-summary-from-string message) mark) (insert-newline mark)) +(define (insert-message-index index index-digits mark) + (insert-string-pad-left (number->string index) index-digits #\space mark)) + (define (imail-summary-subject-width mark) (max (let ((w (ref-variable imail-summary-subject-width mark))) (if (< w 0) @@ -408,6 +560,10 @@ SUBJECT is a string of regexps separated by commas." (month/short-string (decoded-time/month dt)))) (make-string 6 #\space)))) +;++ When the RFC (2)822 parser works better so that we can rely on it +;++ in all folders, we'll use the message's MIME envelope rather than +;++ this pile of cruft. + (define (message-summary-from-string message) (let* ((s (decorated-string-append @@ -446,11 +602,16 @@ SUBJECT is a string of regexps separated by commas." (define (imail-summary-navigators buffer) (define (first-unseen-message folder) - (let loop ((message (first-message folder))) - (and message - (if (message-unseen? message) - message - (loop (next-message message #f)))))) + folder ;ignore + (let ((messages (buffer-get buffer 'IMAIL-SUMMARY-MESSAGES #f))) + (and messages + (let ((length (vector-length messages))) + (let loop ((index 0)) + (and (< index length) + (let ((message (vector-ref messages index))) + (if (message-unseen? message) + message + (loop (+ index 1)))))))))) (define (first-message folder) (imail-summary-navigator/edge buffer folder @@ -487,15 +648,14 @@ SUBJECT is a string of regexps separated by commas." (eq? folder (imail-summary-buffer->folder buffer #f)) (let loop ((m - (call-with-values - (lambda () (imail-summary-find-message buffer message)) - (lambda (m approximate?) - (if (and approximate? - ((if (< delta 0) < >) - (imail-summary-selected-message-index m) - (message-index message))) - m - (and m (line-start m delta #f))))))) + (receive (m approximate?) + (imail-summary-find-message buffer message #t) + (if (and approximate? + ((if (< delta 0) < >) + (imail-summary-selected-message-index m) + (message-index message))) + m + (and m (line-start m delta #f)))))) (and m (let ((index (imail-summary-selected-message-index m))) (and index @@ -540,22 +700,21 @@ SUBJECT is a string of regexps separated by commas." (define (imail-summary-select-message buffer message) (highlight-region (buffer-unclipped-region buffer) #f) - (call-with-values (lambda () (imail-summary-find-message buffer message)) - (lambda (mark approximate?) - (if mark - (begin - (set-buffer-point! buffer mark) - (if (and (not approximate?) - (ref-variable imail-summary-highlight-message buffer)) - (begin - (highlight-region - (make-region (if (imail-summary-match-line mark) - (or (re-match-start 3) - (re-match-end 0)) - mark) - (line-end mark 0)) - #t) - (buffer-not-modified! buffer))))))) + (receive (mark approximate?) (imail-summary-find-message buffer message #t) + (if mark + (begin + (set-buffer-point! buffer mark) + (if (and (not approximate?) + (ref-variable imail-summary-highlight-message buffer)) + (begin + (highlight-region + (make-region (if (imail-summary-match-line mark) + (or (re-match-start 3) + (re-match-end 0)) + mark) + (line-end mark 0)) + #t) + (buffer-not-modified! buffer)))))) (if (ref-variable imail-summary-pop-up-message buffer) (imail-summary-pop-up-message-buffer buffer))) @@ -574,7 +733,7 @@ SUBJECT is a string of regexps separated by commas." height (round->exact (* (window-y-size window) height))))) -(define (imail-summary-find-message buffer message) +(define (imail-summary-find-message buffer message approximate?) (let ((mark (let ((index (let ((mv (buffer-get buffer 'IMAIL-SUMMARY-MESSAGES))) @@ -587,7 +746,7 @@ SUBJECT is a string of regexps separated by commas." (message-index message))) (values mark #f) (let ((index (message-index message))) - (if index + (if (and index approximate?) (let ((m (imail-summary-first-line buffer))) (let ((index* (imail-summary-selected-message-index m))) (cond ((not index*)