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

Tweak snip/draw contracts for better error messages.

Browse Source 
This commit names some intermediate class contracts,
which now print better due to a recent change by Robby.
This commit is contained in:
Asumu Takikawa 2012-04-08 12:45:42 -04:00
parent a376725c77
commit c40ce285cf
2 changed files with 68 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/racket/draw.rkt
View File

@ -28,7 +28,7 @@
the-pen-list the-pen-list
the-brush-list the-brush-list
dc<%> dc<%>
record-dc% recorded-datum->procedure recorded-datum->procedure
ps-setup% current-ps-setup ps-setup% current-ps-setup
get-face-list get-face-list
get-family-builtin-face get-family-builtin-face
@ -45,10 +45,11 @@
[pen-list% pen-list%/c] [pen-list% pen-list%/c]
[brush% brush%/c] [brush% brush%/c]
[brush-list% brush-list%/c] [brush-list% brush-list%/c]
[bitmap-dc% bitmap-dc%/c] [bitmap-dc% (and/c dc<%>/c bitmap-dc%/c)]
[post-script-dc% post-script-dc%/c] [post-script-dc% (and/c dc<%>/c post-script-dc%/c)]
[pdf-dc% pdf-dc%/c] [pdf-dc% (and/c dc<%>/c pdf-dc%/c)]
[svg-dc% svg-dc%/c] [svg-dc% (and/c dc<%>/c svg-dc%/c)]
[record-dc% (and/c dc<%>/c record-dc%/c)]
[linear-gradient% linear-gradient%/c] [linear-gradient% linear-gradient%/c]
[radial-gradient% radial-gradient%/c] [radial-gradient% radial-gradient%/c]
[region% region%/c] [region% region%/c]

129
collects/racket/draw/private/contract.rkt
View File

@ -306,81 +306,76 @@
[get-stops (->m (listof (list/c real? (is-a?/c color%))))])) [get-stops (->m (listof (list/c real? (is-a?/c color%))))]))
(define bitmap-dc%/c (define bitmap-dc%/c
(and/c dc<%>/c (class/c
(class/c (init [bitmap (or/c (is-a?/c bitmap%) #f)])
(init [bitmap (or/c (is-a?/c bitmap%) #f)]) [draw-bitmap-section-smooth
[draw-bitmap-section-smooth (->*m ((is-a?/c bitmap%)
(->*m ((is-a?/c bitmap%) real? real?
real? real? (and/c real? (not/c negative?))
(and/c real? (not/c negative?)) (and/c real? (not/c negative?))
(and/c real? (not/c negative?)) real? real?
real? real? (and/c real? (not/c negative?))
(and/c real? (not/c negative?)) (and/c real? (not/c negative?)))
(and/c real? (not/c negative?))) ((or/c 'solid 'opaque 'xor)
((or/c 'solid 'opaque 'xor) (or/c (is-a?/c color%) #f)
(or/c (is-a?/c color%) #f) (or/c (is-a?/c bitmap%) #f))
(or/c (is-a?/c bitmap%) #f)) boolean?)]
boolean?)] [get-argb-pixels
[get-argb-pixels (->*m (exact-nonnegative-integer?
(->*m (exact-nonnegative-integer? exact-nonnegative-integer?
exact-nonnegative-integer? exact-nonnegative-integer?
exact-nonnegative-integer? exact-nonnegative-integer?
exact-nonnegative-integer? (and/c bytes? (not/c immutable?)))
(and/c bytes? (not/c immutable?))) (any/c any/c)
(any/c any/c) void?)]
void?)] [get-bitmap (->m (or/c (is-a?/c bitmap%) #f))]
[get-bitmap (->m (or/c (is-a?/c bitmap%) #f))] [get-pixel (->m real? real? (is-a?/c color%) boolean?)]
[get-pixel (->m real? real? (is-a?/c color%) boolean?)] [set-argb-pixels
[set-argb-pixels (->*m (exact-nonnegative-integer?
(->*m (exact-nonnegative-integer? exact-nonnegative-integer?
exact-nonnegative-integer? exact-nonnegative-integer?
exact-nonnegative-integer? exact-nonnegative-integer?
exact-nonnegative-integer? bytes?)
bytes?) (any/c any/c)
(any/c any/c) void?)]
void?)] [set-bitmap (->m (or/c (is-a?/c bitmap%) #f) void?)]
[set-bitmap (->m (or/c (is-a?/c bitmap%) #f) void?)] [set-pixel (->m real? real? (is-a?/c color%) void?)]))
[set-pixel (->m real? real? (is-a?/c color%) void?)])))
(define post-script-dc%/c (define post-script-dc%/c
(and/c dc<%>/c (class/c
(class/c (init [interactive any/c]
(init [interactive any/c] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f)]
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f)] [use-paper-bbox any/c]
[use-paper-bbox any/c] [as-eps any/c]
[as-eps any/c] [width (or/c (and/c real? (not/c negative?)) #f)]
[width (or/c (and/c real? (not/c negative?)) #f)] [height (or/c (and/c real? (not/c negative?)) #f)]
[height (or/c (and/c real? (not/c negative?)) #f)] [output (or/c path-string? output-port? #f)])))
[output (or/c path-string? output-port? #f)]))))
(define pdf-dc%/c (define pdf-dc%/c
(and/c dc<%>/c (class/c
(class/c (init [interactive any/c]
(init [interactive any/c] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f)]
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f)] [use-paper-bbox any/c]
[use-paper-bbox any/c] [as-eps any/c]
[as-eps any/c] [width (or/c (and/c real? (not/c negative?)) #f)]
[width (or/c (and/c real? (not/c negative?)) #f)] [height (or/c (and/c real? (not/c negative?)) #f)]
[height (or/c (and/c real? (not/c negative?)) #f)] [output (or/c path-string? output-port? #f)])))
[output (or/c path-string? output-port? #f)]))))
(define svg-dc%/c (define svg-dc%/c
(and/c dc<%>/c (class/c
(class/c (init [width (or/c (and/c real? (not/c negative?)) #f)]
(init [width (or/c (and/c real? (not/c negative?)) #f)] [height (or/c (and/c real? (not/c negative?)) #f)]
[height (or/c (and/c real? (not/c negative?)) #f)] [output (or/c path-string? output-port? #f)]
[output (or/c path-string? output-port? #f)] [exists (or/c 'error 'append 'update 'can-update
[exists (or/c 'error 'append 'update 'can-update 'replace 'truncate
'replace 'truncate 'must-truncate 'truncate/replace)])))
'must-truncate 'truncate/replace)]))))
(define record-dc%/c (define record-dc%/c
(and/c dc<%>/c (class/c
(class/c (init [width (>=/c 0)]
(init [width (>=/c 0)] [height (>=/c 0)])
[height (>=/c 0)]) [get-recorded-datum (->m any/c)]
[get-recorded-datum (->m any/c)] [get-recorded-procedure (->m ((is-a?/c dc<%>) . -> . void?))]))
[get-recorded-procedure (->m ((is-a?/c dc<%>) . -> . void?))])))
(define region%/c (define region%/c
(class/c (class/c