add support for the ellipses in the error messages

according to the promise in the "Error Message Conventions"
section in the Reference

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

@@ -14,6 +14,7 @@ profile todo:
          errortrace/stacktrace
          racket/class
          racket/path
+         racket/bool
          racket/gui/base
          string-constants
          framework
@@ -22,6 +23,7 @@ profile todo:
          drracket/private/drsig
          "bindings-browser.rkt"
          "stack-checkpoint.rkt"
+         "ellipsis-snip.rkt"
          net/sendurl
          net/url
          racket/match
@@ -371,7 +373,7 @@ profile todo:
           (unless (and (null? stack1) (null? stack2))
             (print-bug-to-stderr msg stack1 stack1-editions stack2 stack2-editions defs ints)))
         (display-srclocs-in-error src-locs src-locs-edition))
-      (display msg (current-error-port))
+      (display-error-message exn msg)
       (when (exn:fail:syntax? exn)
         (unless (error-print-source-location)
           (show-syntax-error-context (current-error-port) exn)))
@@ -390,6 +392,76 @@ profile todo:
                                                       stack2
                                                       stack1))))))))
   
+  (define (render-message lines)
+    (define collected (collect-hidden-lines lines))
+    (for ([x (in-list collected)]
+          [i (in-naturals)])
+      (unless (zero? i) (newline (current-error-port)))
+      (cond
+        [(string? x)
+         (display x (current-error-port))]
+        [(pair? x)
+         (define line (list-ref x 0))
+         (define to-show-later (list-ref x 1))
+         (write-string line (current-error-port) 0 (- (string-length line) 4))
+         (write-special (new ellipsis-snip% [extra to-show-later]) (current-error-port))
+         (display "!" (current-error-port))])))
+  
+  (define (display-error-message exn msg)
+    (cond
+      [(exn:fail? exn)
+       (define lines (regexp-split #rx"\n" msg))
+       (cond
+         [(ellipsis-candidate? lines)
+          (render-message lines)]
+         [else
+          (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)]
+                   [i (in-naturals)])
+           
+           (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)])
       (cond

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

@@ -0,0 +1,10 @@
+#lang racket/base
+(require racket/class wxme)
+(provide reader)
+(define reader
+  (class* object% (snip-reader<%>)
+    (define/public (read-header) (void))
+    (define/public (read-snip text-only? version stream)
+      (send stream read-raw-bytes 'ellipsis-snip) ;; discard the 'extra' info
+      #"...")
+    (super-new)))

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

@@ -0,0 +1,91 @@
+#lang racket/base
+(require racket/gui/base
+         racket/class
+         framework)
+(provide ellipsis-snip%)
+
+(define ellipsis-snip%
+  (class snip%
+    (init-field extra)
+    (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)
+      (set-box/f! rb 0)
+      (define-values (w h d a) (send dc get-text-extent str (send (get-style) get-font)))
+      (set-box/f! wb w)
+      (set-box/f! hb h)
+      (set-box/f! db d)
+      (set-box/f! sb a))
+    (define/override (draw dc x y left top right bottom dx dy draw-caret)
+      (send dc draw-text str x y))
+    
+    (define/override (on-goodbye-event dc x y editorx editory event)
+      (handle-event dc x y editorx editory event #t))
+    (define/override (on-event dc x y editorx editory event)
+      (handle-event dc x y editorx editory event #f))
+    (define/private (handle-event dc x y editorx editory event goodbye?)
+      (unless insertion-done?
+        (define admin (get-admin))
+        (when admin
+          (define ed (send admin get-editor))
+          (define the-cursor-to-use (if goodbye? #f arrow-cursor))
+          (when (send event button-up? 'left)
+            (unless goodbye?
+              (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)
+      (define admin (get-admin))
+      (define ed (send admin get-editor))
+      (when (is-a? ed text:ports<%>)
+        (define pos (send ed get-snip-position this))
+        (when pos
+          (send ed begin-edit-sequence)
+          (define insertion-pos (+ pos 2))
+          (let loop ([strs extra])
+            (cond
+              [(null? strs) (void)]
+              [else
+               (define str (car strs))
+               (send ed insert/io str insertion-pos (send ed get-err-style-delta))
+               (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 (write f)
+      (define bp (open-output-bytes))
+      (write extra bp)
+      (define b (get-output-bytes b))
+      (send f put (bytes-length b) b))
+    (super-new)
+    (inherit set-flags get-flags get-admin set-snipclass)
+    (set-flags (cons 'handles-all-mouse-events (get-flags)))
+    (set-snipclass snipclass)))
+
+(define arrow-cursor (make-object cursor% 'arrow))
+
+(define (set-box/f! b v) (when (box? b) (set-box! b v)))
+
+(provide snipclass)
+(define snipclass
+  (new (class snip-class%
+         (define/override (read f)
+           (new ellipsis-snip% [extra (read (open-input-bytes (send f get-unterminated-bytes)))]))
+         (super-new))))
+(send snipclass set-version 1)
+(send snipclass set-classname 
+      (format "~s" '((lib "ellipsis-snip.rkt" "drracket" "private")
+                     (lib "ellipsis-snip-wxme.rkt" "drracket" "private"))))
+
+
+(module+ main
+  (define f (new frame% [label ""] [width 100] [height 100]))
+  (define t (new text%))
+  (send t insert (new ellipsis-snip% [extra '("a" "b" "c")]))
+  (define ec (new editor-canvas% [parent f] [editor t]))
+  (send f show #t))