From 372b4d072b912b88fc7e01081e246a9530be6bbe Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 19 Nov 2014 22:39:01 -0600 Subject: [PATCH] fix up some problems with ellipsis snips Thanks to Stephen Chang for the help here. closes PR 14754 --- .../drracket/drracket/private/debug.rkt | 155 +++++++++++++----- .../drracket/private/ellipsis-snip.rkt | 26 ++- 2 files changed, 132 insertions(+), 49 deletions(-) diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt index 2f8a770e14..2e3a9203aa 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt +++ b/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)] - [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)))))) + (for/or ([x (in-list (cdr lines))]) + (regexp-match ellipsis-error-message-field 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"))))) + diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/ellipsis-snip.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/ellipsis-snip.rkt index 5c4ea7de67..1165daecbf 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/ellipsis-snip.rkt +++ b/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) - (define b (get-output-bytes b)) + (r:write (list insertion-done? extra) bp) + (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"))))