suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix up some problems with ellipsis snips

Browse Source 
Thanks to Stephen Chang for the help here.

closes PR 14754
This commit is contained in:
Robby Findler 2014-11-19 22:39:01 -06:00
parent b6ebd4101a
commit 372b4d072b
2 changed files with 132 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

153
pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt
View File

@ -419,48 +419,10 @@ profile todo:
[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")))))

26
pkgs/drracket-pkgs/drracket/drracket/private/ellipsis-snip.rkt
View File

@ -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"))))