From d6f9ebc9a42885e9a8057eb8802800dbb5516d67 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 16 Jul 2014 09:50:50 -0500 Subject: [PATCH] add support for the ellipses in the error messages according to the promise in the "Error Message Conventions" section in the Reference --- .../drracket/drracket/private/debug.rkt | 74 ++++++++++++++- .../drracket/private/ellipsis-snip-wxme.rkt | 10 ++ .../drracket/private/ellipsis-snip.rkt | 91 +++++++++++++++++++ 3 files changed, 174 insertions(+), 1 deletion(-) create mode 100644 pkgs/drracket-pkgs/drracket/drracket/private/ellipsis-snip-wxme.rkt create mode 100644 pkgs/drracket-pkgs/drracket/drracket/private/ellipsis-snip.rkt diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt index 2e5db84a33..59250dba5b 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt +++ b/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 diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/ellipsis-snip-wxme.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/ellipsis-snip-wxme.rkt new file mode 100644 index 0000000000..3c540032db --- /dev/null +++ b/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))) \ No newline at end of file diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/ellipsis-snip.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/ellipsis-snip.rkt new file mode 100644 index 0000000000..5c4ea7de67 --- /dev/null +++ b/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))