fix up some problems with ellipsis snips

Thanks to Stephen Chang for the help here.

closes PR 14754

pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt

@@ -418,49 +418,11 @@ profile todo:
           (display msg (current-error-port))])]
       [else 
        (display msg (current-error-port))]))
-  
+    
-  (define (collect-hidden-lines lines)
-    (let loop ([lines lines]
-               [ellipsis-line #f]
-               [collection #f])
-      (cond
-        [(null? lines)
-         (cond
-           [ellipsis-line
-            (list (list ellipsis-line collection))]
-           [else
-            '()])]
-        [else
-         (define line (car lines))
-         (cond
-           [ellipsis-line
-            (cond
-              [(regexp-match #rx"^   " line)
-               (loop (cdr lines) ellipsis-line (cons line collection))]
-              [else
-               (cons (list ellipsis-line collection)
-                     (loop (cdr lines) #f #f))])]
-           [else
-            (cond
-              [(regexp-match #rx"  [^ ].*[.][.][.]:$" line)
-               (loop (cdr lines) line '())]
-              [else
-               (cons line (loop (cdr lines) #f #f))])])])))
-  
   (define (ellipsis-candidate? lines)
     (and ((length lines) . > . 1)
-         (for/and ([x (in-list lines)]
+         (for/or ([x (in-list (cdr lines))])
-                   [i (in-naturals)])
+           (regexp-match ellipsis-error-message-field x))))
-           
-           (and
-            ;; if it's not the first line, it is indented.
-            (implies (not (zero? i))
-                     (regexp-match? #rx"^ " x))
-            
-            ;; if it has the indentation to match a `field' line,
-            ;; it has a colon
-            (implies (regexp-match? #rx"^  [^ ]" x)
-                     (regexp-match? #rx":" x))))))
   
   (define (srcloc->edition/pair defs ints srcloc [port-name-matches-cache #f])
     (let ([src (srcloc-source srcloc)])
@@ -2437,3 +2399,114 @@ profile todo:
 
 
   (define-values/invoke-unit/infer stacktrace@))
+
+(define ellipsis-error-message-field #rx"  [^ ].*[.][.][.]:$")
+
+(define (collect-hidden-lines lines)
+  (let loop ([lines lines]
+             [ellipsis-line #f]
+             [collection #f])
+    (cond
+      [(null? lines)
+       (cond
+         [ellipsis-line
+          (list (list ellipsis-line collection))]
+         [else
+          '()])]
+      [else
+       (define line (car lines))
+       (cond
+         [ellipsis-line
+          (cond
+            [(regexp-match #rx"^   " line)
+             (loop (cdr lines) ellipsis-line (cons line collection))]
+            [else
+             (cons (list ellipsis-line collection)
+                   (loop lines #f #f))])]
+         [else
+          (cond
+            [(regexp-match ellipsis-error-message-field line)
+             (loop (cdr lines) line '())]
+            [else
+             (cons line (loop (cdr lines) #f #f))])])])))
+
+(module+ test
+  (require rackunit)
+  (check-equal?
+   (collect-hidden-lines
+    '("car: arity mismatch;"
+      " the expected number of arguments does not match the given number"
+      "  expected: 1"
+      "  given: 3"
+      "  arguments...:"
+      "   1"
+      "   2"
+      "   3"))
+   '("car: arity mismatch;"
+     " the expected number of arguments does not match the given number"
+     "  expected: 1"
+     "  given: 3"
+     ("  arguments...:" ("   3" "   2" "   1"))))
+  
+  (check-equal?
+   (collect-hidden-lines
+    '("car: arity mismatch;"
+      " the expected number of arguments does not match the given number"
+      "  expected: 1"
+      "  given: 3"
+      "  arguments...:"
+      "   1"
+      "   2"
+      "   3"
+      "  another field:"))
+   '("car: arity mismatch;"
+     " the expected number of arguments does not match the given number"
+     "  expected: 1"
+     "  given: 3"
+     ("  arguments...:" ("   3" "   2" "   1"))
+     "  another field:"))
+  
+  (check-equal?
+   (collect-hidden-lines
+    '("car: arity mismatch;"
+      " the expected number of arguments does not match the given number"
+      "  expected: 1"
+      "  given: 3"
+      "  arguments...:"
+      "   1"
+      "   2"
+      "   3"
+      "  arguments...:"
+      "   1"
+      "   2"
+      "   3"))
+   '("car: arity mismatch;"
+     " the expected number of arguments does not match the given number"
+     "  expected: 1"
+     "  given: 3"
+     ("  arguments...:" ("   3" "   2" "   1"))
+     ("  arguments...:" ("   3" "   2" "   1"))))
+  
+  (check-equal?
+   (collect-hidden-lines
+    '("car: arity mismatch;"
+      " the expected number of arguments does not match the given number"
+      "  expected: 1"
+      "  given: 3"
+      "  arguments...:"
+      "   1"
+      "   2"
+      "   3"
+      "  a different field:"
+      "  arguments...:"
+      "   1"
+      "   2"
+      "   3"))
+   '("car: arity mismatch;"
+     " the expected number of arguments does not match the given number"
+     "  expected: 1"
+     "  given: 3"
+     ("  arguments...:" ("   3" "   2" "   1"))
+     "  a different field:"
+     ("  arguments...:" ("   3" "   2" "   1")))))
+

pkgs/drracket-pkgs/drracket/drracket/private/ellipsis-snip.rkt

@@ -1,14 +1,15 @@
 #lang racket/base
 (require racket/gui/base
+         racket/contract
          racket/class
+         (prefix-in r: racket/base)
          framework)
 (provide ellipsis-snip%)
 
 (define ellipsis-snip%
   (class snip%
-    (init-field extra)
+    (init-field extra [insertion-done? #f])
     (inherit get-style)
-    (define insertion-done? #f)
     (define str "...")
     (define/override (get-extent dc x y wb hb db sb lb rb)
       (set-box/f! lb 0)
@@ -36,7 +37,6 @@
               (do-insertion)
               (set! insertion-done? #t)
               (set! the-cursor-to-use #f)))
-          (printf "setting cursor to ~s\n" the-cursor-to-use)
           (send ed set-cursor the-cursor-to-use))))
     
     (define/private (do-insertion)
@@ -56,11 +56,13 @@
                (send ed insert/io "\n" insertion-pos (send ed get-err-style-delta))
                (loop (cdr strs))]))
           (send ed end-edit-sequence))))
-    (define/override (copy) (new ellipsis-snip% [extra extra]))
+    (define/override (copy) (new ellipsis-snip% 
+                                 [extra extra]
+                                 [insertion-done? insertion-done?]))
     (define/override (write f)
       (define bp (open-output-bytes))
-      (write extra bp)
+      (r:write (list insertion-done? extra) bp)
-      (define b (get-output-bytes b))
+      (define b (get-output-bytes bp))
       (send f put (bytes-length b) b))
     (super-new)
     (inherit set-flags get-flags get-admin set-snipclass)
@@ -72,12 +74,20 @@
 (define (set-box/f! b v) (when (box? b) (set-box! b v)))
 
 (provide snipclass)
+(define valid-data? (list/c boolean? (listof string?)))
 (define snipclass
   (new (class snip-class%
          (define/override (read f)
-           (new ellipsis-snip% [extra (read (open-input-bytes (send f get-unterminated-bytes)))]))
+           (define data (read (open-input-bytes (send f get-unterminated-bytes))))
+           (cond
+             [(valid-data? data)
+              (new ellipsis-snip% 
+                   [insertion-done? (list-ref data 0)]
+                   [extra (list-ref data 1)])]
+             [else
+              (new ellipsis-snip% [extra '()])]))
          (super-new))))
-(send snipclass set-version 1)
+(send snipclass set-version 2)
 (send snipclass set-classname 
       (format "~s" '((lib "ellipsis-snip.rkt" "drracket" "private")
                      (lib "ellipsis-snip-wxme.rkt" "drracket" "private"))))