From 9e54b2bc1b8c0ca8a3d84b86a438153e8e1ff2e7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 26 Apr 2013 08:21:59 -0500 Subject: [PATCH] IN PROGRESS: working on rect support for error messages for 2d cond --- .../drracket/drracket/private/debug.rkt | 16 +++-- .../drracket/drracket/private/eval.rkt | 1 + .../drracket/drracket/private/rep.rkt | 72 +++++++++++++++++-- racket/collects/syntax/rect.rkt | 24 +++++++ racket/lib/collects/syntax/rect.rkt | 24 +++++++ 5 files changed, 126 insertions(+), 11 deletions(-) create mode 100644 racket/collects/syntax/rect.rkt create mode 100644 racket/lib/collects/syntax/rect.rkt diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt index 7442bfea0c..6c703be44d 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt @@ -28,6 +28,7 @@ profile todo: mrlib/include-bitmap images/compile-time pkg/lib + syntax/rect (for-syntax images/icons/misc images/icons/style images/icons/control images/logos) (for-syntax racket/base) (submod "frame.rkt" install-pkg)) @@ -338,9 +339,13 @@ profile todo: [(pair? stack2) (list (car stack2))] [else '()])] + [srcloc-rects (cond + [(and (exn:srcloc-rects? exn) + (exn:srclocs? exn)) ;; only look at the rects when the exn has srclocs + ((exn:srcloc-rects-accessor exn) exn)] + [else #f])] [src-locs-edition (and (pair? src-locs) (srcloc->edition/pair defs ints (car src-locs) port-name-matches-cache))]) - (print-planet-icon-to-stderr exn) (unless (exn:fail:user? exn) (unless (exn:fail:syntax? exn) @@ -362,9 +367,12 @@ profile todo: (λ () ;; need to make sure that the user's eventspace is still the same ;; and still running here? - (send ints highlight-errors src-locs (if (null? stack1) - stack2 - stack1)))))))) + (send ints highlight-errors + src-locs + (if (null? stack1) + stack2 + stack1) + srcloc-rects))))))) (define (srcloc->edition/pair defs ints srcloc [port-name-matches-cache #f]) (let ([src (srcloc-source srcloc)]) diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/eval.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/eval.rkt index 27e0107455..103c3dd893 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/eval.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/eval.rkt @@ -187,6 +187,7 @@ (list ''#%foreign '(lib "mzlib/pconvert-prop.rkt") '(lib "planet/terse-info.rkt") + '(lib "syntax/rect.rkt") ;; preserve the invariant that: ;; if a module is shared, so ;; are all of its submodules diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/rep.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/rep.rkt index b3e1faa85f..870ae327a2 100644 --- a/pkgs/drracket-pkgs/drracket/drracket/private/rep.rkt +++ b/pkgs/drracket-pkgs/drracket/drracket/private/rep.rkt @@ -23,6 +23,7 @@ TODO racket/port racket/set + syntax/rect string-constants setup/xref racket/gui/base @@ -550,10 +551,66 @@ TODO ;; error-ranges : (union false? (cons srcloc (listof srcloc))) (define error-ranges #f) (define/public (get-error-ranges) error-ranges) - (define/public (set-error-ranges ranges) - (set! error-ranges (and ranges - (not (null? ranges)) - (cleanup-locs ranges)))) + (define/public (set-error-ranges srclocs [srcloc-rects #f]) + (define candidate-srclocs + (and srclocs + (not (null? srclocs)) + (cleanup-locs srclocs))) + (cond + [(and candidate-srclocs srcloc-rects) + (set! error-ranges + (apply + append + (for/list ([srcloc (in-list candidate-srclocs)]) + (define pending-range-start #f) + (define pending-range-end #f) + (define srclocs '()) + (for ([pos (in-range (srcloc-position srcloc) + (+ (srcloc-position srcloc) + (srcloc-span srcloc)))]) + (define keep-pos? + (for/or ([srcloc-rect (in-list srcloc-rects)] + #:when (equal? (srcloc-rect-source srcloc-rect) + (srcloc-source range))) + (pos-in-rect? pos srcloc-rect))) + + (when keep-pos? + (cond + [(not pending-range-start) + (set! pending-range-start pos) + (set! pending-range-end pos)] + [(= (+ pending-range-end 1) pos) + (set! pending-range-end pos)] + [else + (set! srclocs (cons (srcloc (srcloc-source srcloc) + #f #f + pending-range-start + (- pending-range-end pending-range-start)) + srclocs)) + (set! pending-range-start pos) + (set! pending-range-end pos)]))) + srclocs)))] + [else + (set! error-ranges candidate-srclocs)])) + + (define/private (pos-in-rect? pos srcloc-rect) + (define src (srcloc-rect-source srcloc-rect)) + (define height (srcloc-rect-height srcloc-rect)) + (define width (srcloc-rect-width srcloc-rect)) + (cond + [(is-a? src text%) + (define start-para (send src position-paragraph (srcloc-rect-pos srcloc-rect))) + (define para-offset (- (srcloc-rect-pos srcloc-rect) start-para)) + (let loop ([this-line-start (srcloc-rect-pos srcloc-rect)] + [y 0]) + (cond + [(= y height) #f] + [(<= this-line-start pos (+ this-line-start width)) #t] + [else + (loop (+ (send src paragraph-start-position (+ start-para y)) para-offset) + (+ y 1))]))] + [else #f])) + (define clear-error-highlighting void) (define/public (reset-error-ranges) (set-error-ranges #f) @@ -577,11 +634,12 @@ TODO ;; =Kernel= =handler= ;; highlight-errors : (listof srcloc) ;; (union #f (listof srcloc)) + ;; (union #f (listof srcloc-rect)) ;; -> (void) - (define/public (highlight-errors raw-locs [raw-error-arrows #f]) + (define/public (highlight-errors raw-locs [raw-error-arrows #f] [srcloc-rects #f]) (clear-error-highlighting) (when definitions-text (send definitions-text set-error-arrows #f)) - (set-error-ranges raw-locs) + (set-error-ranges raw-locs srcloc-rects) (define locs (or (get-error-ranges) '())) ;; calling set-error-range cleans up the locs (define error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows))) @@ -635,7 +693,7 @@ TODO (send tlw ensure-defs-shown)))) (send first-file set-caret-owner (get-focus-snip) 'global)))) - + ;; unlike highlight-error just above, this function does not change ;; what the currently noted errors locations are, it just highlights ;; one of them. diff --git a/racket/collects/syntax/rect.rkt b/racket/collects/syntax/rect.rkt new file mode 100644 index 0000000000..2c361dcd13 --- /dev/null +++ b/racket/collects/syntax/rect.rkt @@ -0,0 +1,24 @@ +#lang racket/base +(provide (struct-out exn:fail:syntax/rects) + (struct-out exn:fail:read/rects) + (struct-out exn:fail:read:eof/rects) + (struct-out exn:fail:read:non-char/rects) + (struct-out srcloc-rect) + prop:exn:srcloc-rects + exn:srcloc-rects? + exn:srcloc-rects-accessor) + +(define-values (prop:exn:srcloc-rects exn:srcloc-rects? exn:srcloc-rects-accessor) + (make-struct-type-property 'exn:srcloc-rects)) + +(struct exn:fail:syntax/rects exn:fail:syntax (rects) + #:property prop:exn:srcloc-rects (λ (x) (exn:fail:syntax/rects-rects x))) + +(struct exn:fail:read/rects exn:fail:read (rects) + #:property prop:exn:srcloc-rects (λ (x) (exn:fail:read/rects-rects x))) +(struct exn:fail:read:eof/rects exn:fail:read:eof (rects) + #:property prop:exn:srcloc-rects (λ (x) (exn:fail:read:eof/rects-rects x))) +(struct exn:fail:read:non-char/rects exn:fail:read:non-char (rects) + #:property prop:exn:srcloc-rects (λ (x) (exn:fail:read:non-char/rects-rects x))) + +(struct srcloc-rect (source pos width height) #:transparent) diff --git a/racket/lib/collects/syntax/rect.rkt b/racket/lib/collects/syntax/rect.rkt new file mode 100644 index 0000000000..2c361dcd13 --- /dev/null +++ b/racket/lib/collects/syntax/rect.rkt @@ -0,0 +1,24 @@ +#lang racket/base +(provide (struct-out exn:fail:syntax/rects) + (struct-out exn:fail:read/rects) + (struct-out exn:fail:read:eof/rects) + (struct-out exn:fail:read:non-char/rects) + (struct-out srcloc-rect) + prop:exn:srcloc-rects + exn:srcloc-rects? + exn:srcloc-rects-accessor) + +(define-values (prop:exn:srcloc-rects exn:srcloc-rects? exn:srcloc-rects-accessor) + (make-struct-type-property 'exn:srcloc-rects)) + +(struct exn:fail:syntax/rects exn:fail:syntax (rects) + #:property prop:exn:srcloc-rects (λ (x) (exn:fail:syntax/rects-rects x))) + +(struct exn:fail:read/rects exn:fail:read (rects) + #:property prop:exn:srcloc-rects (λ (x) (exn:fail:read/rects-rects x))) +(struct exn:fail:read:eof/rects exn:fail:read:eof (rects) + #:property prop:exn:srcloc-rects (λ (x) (exn:fail:read:eof/rects-rects x))) +(struct exn:fail:read:non-char/rects exn:fail:read:non-char (rects) + #:property prop:exn:srcloc-rects (λ (x) (exn:fail:read:non-char/rects-rects x))) + +(struct srcloc-rect (source pos width height) #:transparent)