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

Revert "IN PROGRESS: add opt/c to with-contract and provide/contract"

Browse Source 
and "IN PROGRESS: working on syntax error messages for 2d"

This reverts commit bbb0d27e85.

This reverts commit 1452563250.
This commit is contained in:
Robby Findler 2013-04-25 18:13:59 -05:00
parent 0f47ec4af7
commit e8f8217070
6 changed files with 48 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/drracket/private/debug.rkt
View File

@ -27,7 +27,6 @@ profile todo:
racket/match racket/match
mrlib/include-bitmap mrlib/include-bitmap
images/compile-time images/compile-time
syntax/rect
(for-syntax images/icons/misc images/icons/style images/icons/control images/logos) (for-syntax images/icons/misc images/icons/style images/icons/control images/logos)
(for-syntax racket/base)) (for-syntax racket/base))
@ -304,13 +303,9 @@ profile todo:
[(pair? stack2) [(pair? stack2)
(list (car stack2))] (list (car stack2))]
[else '()])] [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) [src-locs-edition (and (pair? src-locs)
(srcloc->edition/pair defs ints (car src-locs) port-name-matches-cache))]) (srcloc->edition/pair defs ints (car src-locs) port-name-matches-cache))])
(print-planet-icon-to-stderr exn) (print-planet-icon-to-stderr exn)
(unless (exn:fail:user? exn) (unless (exn:fail:user? exn)
(unless (exn:fail:syntax? exn) (unless (exn:fail:syntax? exn)
@ -331,12 +326,9 @@ profile todo:
(λ () (λ ()
;; need to make sure that the user's eventspace is still the same ;; need to make sure that the user's eventspace is still the same
;; and still running here? ;; and still running here?
(send ints highlight-errors (send ints highlight-errors src-locs (if (null? stack1)
src-locs stack2
(if (null? stack1) stack1))))))))
stack2
stack1)
srcloc-rects)))))))
(define (srcloc->edition/pair defs ints srcloc [port-name-matches-cache #f]) (define (srcloc->edition/pair defs ints srcloc [port-name-matches-cache #f])
(let ([src (srcloc-source srcloc)]) (let ([src (srcloc-source srcloc)])

3
collects/drracket/private/eval.rkt
View File

@ -185,8 +185,7 @@
(define to-be-copied-module-specs (define to-be-copied-module-specs
(list ''#%foreign (list ''#%foreign
'(lib "mzlib/pconvert-prop.rkt") '(lib "mzlib/pconvert-prop.rkt")
'(lib "planet/terse-info.rkt") '(lib "planet/terse-info.rkt")))
'(lib "syntax/rect.rkt")))
;; ensure that they are all here. ;; ensure that they are all here.
(for-each (λ (x) (dynamic-require x #f)) to-be-copied-module-specs) (for-each (λ (x) (dynamic-require x #f)) to-be-copied-module-specs)

70
collects/drracket/private/rep.rkt
View File

@ -23,7 +23,6 @@ TODO
racket/port racket/port
racket/set racket/set
syntax/rect
string-constants string-constants
setup/xref setup/xref
racket/gui/base racket/gui/base
@ -544,66 +543,10 @@ TODO
;; error-ranges : (union false? (cons srcloc (listof srcloc))) ;; error-ranges : (union false? (cons srcloc (listof srcloc)))
(define error-ranges #f) (define error-ranges #f)
(define/public (get-error-ranges) error-ranges) (define/public (get-error-ranges) error-ranges)
(define/public (set-error-ranges srclocs [srcloc-rects #f]) (define/public (set-error-ranges ranges)
(define candidate-srclocs (set! error-ranges (and ranges
(and srclocs (not (null? ranges))
(not (null? srclocs)) (cleanup-locs ranges))))
(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 clear-error-highlighting void)
(define/public (reset-error-ranges) (define/public (reset-error-ranges)
(set-error-ranges #f) (set-error-ranges #f)
@ -627,12 +570,11 @@ TODO
;; =Kernel= =handler= ;; =Kernel= =handler=
;; highlight-errors : (listof srcloc) ;; highlight-errors : (listof srcloc)
;; (union #f (listof srcloc)) ;; (union #f (listof srcloc))
;; (union #f (listof srcloc-rect))
;; -> (void) ;; -> (void)
(define/public (highlight-errors raw-locs [raw-error-arrows #f] [srcloc-rects #f]) (define/public (highlight-errors raw-locs [raw-error-arrows #f])
(clear-error-highlighting) (clear-error-highlighting)
(when definitions-text (send definitions-text set-error-arrows #f)) (when definitions-text (send definitions-text set-error-arrows #f))
(set-error-ranges raw-locs srcloc-rects) (set-error-ranges raw-locs)
(define locs (or (get-error-ranges) '())) ;; calling set-error-range cleans up the locs (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))) (define error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows)))

44
collects/racket/contract/private/provide.rkt
View File

@ -23,10 +23,14 @@
"guts.rkt" "guts.rkt"
"misc.rkt" "misc.rkt"
"exists.rkt" "exists.rkt"
"opt.rkt"
syntax/location syntax/location
syntax/srcloc) syntax/srcloc)
(define-syntax (verify-contract stx)
(syntax-case stx ()
[(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(coerce-contract name x)]))
(define-for-syntax (self-ctor-transformer orig stx) (define-for-syntax (self-ctor-transformer orig stx)
(with-syntax ([orig orig]) (with-syntax ([orig orig])
(syntax-case stx () (syntax-case stx ()
@ -358,10 +362,12 @@
#t))] #t))]
[mutator-ids (reverse (list-ref the-struct-info 4))] ;; (listof (union #f identifier)) [mutator-ids (reverse (list-ref the-struct-info 4))] ;; (listof (union #f identifier))
[field-contract-ids (map (λ (field-name field-contract) [field-contract-ids (map (λ (field-name field-contract)
(a:mangle-id provide-stx (if (a:known-good-contract? field-contract)
"provide/contract-field-contract" field-contract
field-name (a:mangle-id provide-stx
struct-name)) "provide/contract-field-contract"
field-name
struct-name)))
field-names field-names
field-contracts)] field-contracts)]
[struct:struct-name [struct:struct-name
@ -513,9 +519,11 @@
[(field-contract-id-definitions ...) [(field-contract-id-definitions ...)
(filter values (map (λ (field-contract-id field-contract) (filter values (map (λ (field-contract-id field-contract)
(with-syntax ([field-contract-id field-contract-id] (if (a:known-good-contract? field-contract)
[field-contract field-contract]) #f
#'(define field-contract-id (opt/c field-contract #:error-name provide/contract)))) (with-syntax ([field-contract-id field-contract-id]
[field-contract field-contract])
#'(define field-contract-id (verify-contract 'provide/contract field-contract)))))
field-contract-ids field-contract-ids
field-contracts))] field-contracts))]
[(field-contracts ...) field-contracts] [(field-contracts ...) field-contracts]
@ -715,14 +723,17 @@
(define (code-for-one-id/new-name stx id reflect-id ctrct/no-prop user-rename-id (define (code-for-one-id/new-name stx id reflect-id ctrct/no-prop user-rename-id
[mangle-for-maker? #f] [mangle-for-maker? #f]
[provide? #t]) [provide? #t])
(let ([ex-id (or reflect-id id)] (let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct/no-prop)]
[ex-id (or reflect-id id)]
[ctrct (syntax-property ctrct/no-prop [ctrct (syntax-property ctrct/no-prop
'racket/contract:contract-on-boundary 'racket/contract:contract-on-boundary
(gensym 'provide/contract-boundary))]) (gensym 'provide/contract-boundary))])
(with-syntax ([id-rename (id-for-one-id user-rename-id reflect-id id mangle-for-maker?)] (with-syntax ([id-rename (id-for-one-id user-rename-id reflect-id id mangle-for-maker?)]
[contract-id (a:mangle-id provide-stx [contract-id (if no-need-to-check-ctrct?
"provide/contract-contract-id" ctrct
(or user-rename-id ex-id))] (a:mangle-id provide-stx
"provide/contract-contract-id"
(or user-rename-id ex-id)))]
[pos-stx (datum->syntax id 'here)] [pos-stx (datum->syntax id 'here)]
[id id] [id id]
[ex-id ex-id] [ex-id ex-id]
@ -740,10 +751,11 @@
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
(define contract-id #,@(if no-need-to-check-ctrct?
;; let is here to give the right name. (list)
(let ([ex-id (opt/c ctrct #:error-name provide/contract)]) (list #'(define contract-id
ex-id)) (let ([ex-id ctrct]) ;; let is here to give the right name.
(verify-contract 'provide/contract ex-id)))))
(define-syntax id-rename (define-syntax id-rename
(make-provide/contract-transformer (quote-syntax contract-id) (make-provide/contract-transformer (quote-syntax contract-id)
(a:update-loc (a:update-loc

16
collects/racket/contract/region.rkt
View File

@ -19,14 +19,14 @@
"private/arrow.rkt" "private/arrow.rkt"
"private/base.rkt" "private/base.rkt"
"private/guts.rkt" "private/guts.rkt"
"private/misc.rkt" "private/misc.rkt")
"private/opt.rkt")
;; These are useful for all below. ;; These are useful for all below.
(define-syntax (add-opt-contract stx) (define-syntax (verify-contract stx)
(syntax-case stx () (syntax-case stx ()
[(_ x) #'(opt/c x #:error-name with-contract)])) [(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(coerce-contract name x)]))
@ -688,14 +688,14 @@
(with-syntax ([new-stx (add-context #'(syntax-parameterize (with-syntax ([new-stx (add-context #'(syntax-parameterize
([current-contract-region (λ (stx) #'blame-stx)]) ([current-contract-region (λ (stx) #'blame-stx)])
(let-values ([(res ...) (let () . body)]) (let-values ([(res ...) (let () . body)])
(values (contract (add-opt-contract rc.ctc) (values (contract (verify-contract 'with-contract rc.ctc)
res res
blame-stx blame-stx
blame-id) ...))))]) blame-id) ...))))])
(syntax/loc stx (syntax/loc stx
(let () (let ()
(define-values (free-ctc-id ...) (define-values (free-ctc-id ...)
(values (add-opt-contract free-ctc) ...)) (values (verify-contract 'with-contract free-ctc) ...))
(define blame-id (define blame-id
(current-contract-region)) (current-contract-region))
(define-values () (define-values ()
@ -757,7 +757,7 @@
(syntax/loc stx (syntax/loc stx
(begin (begin
(define-values (free-ctc-id ...) (define-values (free-ctc-id ...)
(values (add-opt-contract free-ctc) ...)) (values (verify-contract 'with-contract free-ctc) ...))
(define blame-id (define blame-id
(current-contract-region)) (current-contract-region))
(define-values () (define-values ()
@ -787,7 +787,7 @@
ext-id ext-id
(contract ctc-id true-p blame-stx blame-id (quote ext-id) (quote-srcloc ext-id)) (contract ctc-id true-p blame-stx blame-id (quote ext-id) (quote-srcloc ext-id))
ctc-id ctc-id
(add-opt-contract ctc)) (verify-contract 'with-contract ctc))
...) ...)
blame-stx blame-stx
. .

24
collects/syntax/rect.rkt
View File

@ -1,24 +0,0 @@
#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)