From c40ce285cfb08bc78f3085e4f337e07e6932fd90 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Sun, 8 Apr 2012 12:45:42 -0400 Subject: [PATCH] Tweak snip/draw contracts for better error messages. This commit names some intermediate class contracts, which now print better due to a recent change by Robby. --- collects/racket/draw.rkt | 11 +- collects/racket/draw/private/contract.rkt | 129 +++++++++++----------- 2 files changed, 68 insertions(+), 72 deletions(-) diff --git a/collects/racket/draw.rkt b/collects/racket/draw.rkt index 67949db876..4a366400ad 100644 --- a/collects/racket/draw.rkt +++ b/collects/racket/draw.rkt @@ -28,7 +28,7 @@ the-pen-list the-brush-list dc<%> - record-dc% recorded-datum->procedure + recorded-datum->procedure ps-setup% current-ps-setup get-face-list get-family-builtin-face @@ -45,10 +45,11 @@ [pen-list% pen-list%/c] [brush% brush%/c] [brush-list% brush-list%/c] - [bitmap-dc% bitmap-dc%/c] - [post-script-dc% post-script-dc%/c] - [pdf-dc% pdf-dc%/c] - [svg-dc% svg-dc%/c] + [bitmap-dc% (and/c dc<%>/c bitmap-dc%/c)] + [post-script-dc% (and/c dc<%>/c post-script-dc%/c)] + [pdf-dc% (and/c dc<%>/c pdf-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] [radial-gradient% radial-gradient%/c] [region% region%/c] diff --git a/collects/racket/draw/private/contract.rkt b/collects/racket/draw/private/contract.rkt index 640823c05b..3293245358 100644 --- a/collects/racket/draw/private/contract.rkt +++ b/collects/racket/draw/private/contract.rkt @@ -306,81 +306,76 @@ [get-stops (->m (listof (list/c real? (is-a?/c color%))))])) (define bitmap-dc%/c - (and/c dc<%>/c - (class/c - (init [bitmap (or/c (is-a?/c bitmap%) #f)]) - [draw-bitmap-section-smooth - (->*m ((is-a?/c bitmap%) - real? real? - (and/c real? (not/c negative?)) - (and/c real? (not/c negative?)) - real? real? - (and/c real? (not/c negative?)) - (and/c real? (not/c negative?))) - ((or/c 'solid 'opaque 'xor) - (or/c (is-a?/c color%) #f) - (or/c (is-a?/c bitmap%) #f)) - boolean?)] - [get-argb-pixels - (->*m (exact-nonnegative-integer? - exact-nonnegative-integer? - exact-nonnegative-integer? - exact-nonnegative-integer? - (and/c bytes? (not/c immutable?))) - (any/c any/c) - void?)] - [get-bitmap (->m (or/c (is-a?/c bitmap%) #f))] - [get-pixel (->m real? real? (is-a?/c color%) boolean?)] - [set-argb-pixels - (->*m (exact-nonnegative-integer? - exact-nonnegative-integer? - exact-nonnegative-integer? - exact-nonnegative-integer? - bytes?) - (any/c any/c) - void?)] - [set-bitmap (->m (or/c (is-a?/c bitmap%) #f) void?)] - [set-pixel (->m real? real? (is-a?/c color%) void?)]))) + (class/c + (init [bitmap (or/c (is-a?/c bitmap%) #f)]) + [draw-bitmap-section-smooth + (->*m ((is-a?/c bitmap%) + real? real? + (and/c real? (not/c negative?)) + (and/c real? (not/c negative?)) + real? real? + (and/c real? (not/c negative?)) + (and/c real? (not/c negative?))) + ((or/c 'solid 'opaque 'xor) + (or/c (is-a?/c color%) #f) + (or/c (is-a?/c bitmap%) #f)) + boolean?)] + [get-argb-pixels + (->*m (exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + (and/c bytes? (not/c immutable?))) + (any/c any/c) + void?)] + [get-bitmap (->m (or/c (is-a?/c bitmap%) #f))] + [get-pixel (->m real? real? (is-a?/c color%) boolean?)] + [set-argb-pixels + (->*m (exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + bytes?) + (any/c any/c) + void?)] + [set-bitmap (->m (or/c (is-a?/c bitmap%) #f) void?)] + [set-pixel (->m real? real? (is-a?/c color%) void?)])) (define post-script-dc%/c - (and/c dc<%>/c - (class/c - (init [interactive any/c] - [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f)] - [use-paper-bbox any/c] - [as-eps any/c] - [width (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)])))) + (class/c + (init [interactive any/c] + [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f)] + [use-paper-bbox any/c] + [as-eps any/c] + [width (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)]))) (define pdf-dc%/c - (and/c dc<%>/c - (class/c - (init [interactive any/c] - [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f)] - [use-paper-bbox any/c] - [as-eps any/c] - [width (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)])))) + (class/c + (init [interactive any/c] + [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f)] + [use-paper-bbox any/c] + [as-eps any/c] + [width (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)]))) (define svg-dc%/c - (and/c dc<%>/c - (class/c - (init [width (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)] - [exists (or/c 'error 'append 'update 'can-update - 'replace 'truncate - 'must-truncate 'truncate/replace)])))) + (class/c + (init [width (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)] + [exists (or/c 'error 'append 'update 'can-update + 'replace 'truncate + 'must-truncate 'truncate/replace)]))) (define record-dc%/c - (and/c dc<%>/c - (class/c - (init [width (>=/c 0)] - [height (>=/c 0)]) - [get-recorded-datum (->m any/c)] - [get-recorded-procedure (->m ((is-a?/c dc<%>) . -> . void?))]))) + (class/c + (init [width (>=/c 0)] + [height (>=/c 0)]) + [get-recorded-datum (->m any/c)] + [get-recorded-procedure (->m ((is-a?/c dc<%>) . -> . void?))])) (define region%/c (class/c