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

IN PROGRESS: working on rect support for error messages for 2d cond

Browse Source
This commit is contained in:
Robby Findler 2013-04-26 08:21:59 -05:00
parent 43a584f710
commit 9e54b2bc1b
5 changed files with 126 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

1
pkgs/drracket-pkgs/drracket/drracket/private/eval.rkt
View File

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

70
pkgs/drracket-pkgs/drracket/drracket/private/rep.rkt
View File

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

24
racket/collects/syntax/rect.rkt Normal file
View File

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

24
racket/lib/collects/syntax/rect.rkt Normal file
View File

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