From 2e1d59f7b2fb1e1de6fa32a5fdec4353b3b9d832 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Wed, 15 Feb 2012 17:16:29 -0500 Subject: [PATCH] Class contracts for racket/snip. --- collects/racket/snip.rkt | 29 +- collects/racket/snip/contracts.rkt | 583 +++++++++++++++++++++++++++++ 2 files changed, 605 insertions(+), 7 deletions(-) create mode 100644 collects/racket/snip/contracts.rkt diff --git a/collects/racket/snip.rkt b/collects/racket/snip.rkt index 10cd615e09..bde495f137 100644 --- a/collects/racket/snip.rkt +++ b/collects/racket/snip.rkt @@ -1,12 +1,27 @@ #lang racket/base -(require "snip/private/snip.rkt" - "snip/private/snip-admin.rkt" - "snip/private/style.rkt") +(require racket/contract/base + "snip/contracts.rkt" + "snip/private/snip.rkt" + "snip/private/snip-admin.rkt" + "snip/private/style.rkt") + (provide mult-color<%> add-color<%> - style-delta% style<%> - style-list% the-style-list - (all-from-out "snip/private/snip.rkt" - "snip/private/snip-admin.rkt")) + + (except-out (all-from-out "snip/private/snip.rkt") + snip% + snip-class% + string-snip% + tab-snip% + image-snip%)) + +(provide/contract [style-delta% style-delta%/c] + [style-list% style-list%/c] + [snip% snip%/c] + [snip-class% snip-class%/c] + [string-snip% string-snip%/c] + [tab-snip% tab-snip%/c] + [image-snip% image-snip%/c] + [snip-admin% snip-admin%/c]) diff --git a/collects/racket/snip/contracts.rkt b/collects/racket/snip/contracts.rkt new file mode 100644 index 0000000000..87e65dda7d --- /dev/null +++ b/collects/racket/snip/contracts.rkt @@ -0,0 +1,583 @@ +#lang racket + +(require racket/class + racket/draw + "private/snip.rkt" + "private/snip-admin.rkt" + "private/style.rkt") + +(provide (all-defined-out)) + +;; dummy definitions for contracts +(define-values (cursor% mouse-event% key-event% pasteboard% + editor-stream-in% editor-stream-out% text% popup-menu%) + (values object% object% object% object% + object% object% object% object%)) + +;; interfaces: +(define (equal<%>/c cls) + (class/c + (equal-to? (->m (is-a?/c cls) (-> any/c any/c boolean?) boolean?)) + (equal-hash-code-of (->m (-> any/c exact-integer?) exact-integer?)) + (equal-secondary-hash-code-of (->m (-> any/c exact-integer?) exact-integer?)) + (override + (equal-to? (->m (is-a?/c cls) (-> any/c any/c boolean?) boolean?)) + (equal-hash-code-of (->m (-> any/c exact-integer?) exact-integer?)) + (equal-secondary-hash-code-of (->m (-> any/c exact-integer?) exact-integer?))))) + +(define readable-snip<%>/c + (class/c + (read-special + (->m any/c + (or/c exact-nonnegative-integer? #f) + (or/c exact-nonnegative-integer? #f) + (or/c exact-nonnegative-integer? #f) + any/c)))) + +;; contract utilities: +(define font-family/c + (or/c 'base 'default 'decorative 'roman 'script + 'swiss 'modern 'symbol 'system)) + +(define font-smoothing/c + (or/c 'base 'default 'partly-smoothed 'smoothed 'unsmoothed)) + +(define font-style/c + (or/c 'base 'normal 'italic 'slant)) + +(define font-weight/c + (or/c 'base 'normal 'bold 'light)) + +(define alignment/c + (or/c 'base 'top 'center 'bottom)) + +(define tab-snip-filetype/c + (one-of/c 'unknown 'unknown/mask 'unknown/alpha + 'gif 'gif/mask 'gif/alpha + 'jpeg 'png 'png/mask 'png/alpha + 'xbm 'xpm 'bmp 'pict)) + +(define style-delta%/c + (class/c + (collapse (->m (is-a?/c style-delta%) boolean?)) + (copy (->m (is-a?/c style-delta%) void?)) + (equal? (->m (is-a?/c style-delta%) boolean?)) + (get-alignment-off (->m alignment/c)) + (get-alignment-on (->m alignment/c)) + (get-background-add (->m (is-a?/c add-color<%>))) + (get-background-mult (->m (is-a?/c mult-color<%>))) + (get-face (->m (or/c string? false/c))) + (get-family (->m font-family/c)) + (get-foreground-add (->m (is-a?/c add-color<%>))) + (get-foreground-mult (->m (is-a?/c mult-color<%>))) + (get-size-add (->m (integer-in 0 255))) + (get-size-in-pixels-off (->m boolean?)) + (get-size-in-pixels-on (->m boolean?)) + (get-size-mult (->m real?)) + (get-smoothing-off (->m font-smoothing/c)) + (get-style-off (->m font-style/c)) + (get-style-on (->m font-style/c)) + (get-transparent-text-backing-off (->m boolean?)) + (get-transparent-text-backing-on (->m boolean?)) + (get-underlined-off (->m boolean?)) + (get-underlined-on (->m boolean?)) + (get-weight-off (->m font-weight/c)) + (get-weight-on (->m font-weight/c)) + (set-alignment-off (->m alignment/c void?)) + (set-alignment-on (->m alignment/c void?)) + (set-delta (case->m + (-> (is-a?/c style-delta%)) + (-> (or/c 'change-nothing + 'change-normal + 'change-toggle-underline + 'change-toggle-size-in-pixels + 'change-normal-color + 'change-italic + 'change-bold) + (is-a?/c style-delta%)) + (-> (or/c 'change-family + 'change-style + 'change-toggle-style + 'change-weight + 'change-toggle-weight + 'change-smoothing + 'change-toggle-smoothing + 'change-alignment + 'change-size + 'change-bigger + 'change-smaller + 'change-underline + 'change-size-in-pixels) + any/c + (is-a?/c style-delta%)))) + (set-delta-background (->m (or/c string? (is-a?/c color%)) + (is-a?/c style-delta%))) + (set-delta-face (->*m (string?) (font-family/c) (is-a?/c style-delta%))) + (set-delta-foreground (->m (or/c string? (is-a?/c color%)) + (is-a?/c style-delta%))) + (set-face (->m (or/c string? false/c) void?)) + (set-family (->m font-family/c void?)) + (set-size-add (->m (integer-in 0 255) void?)) + (set-size-in-pixels-off (->m any/c void?)) + (set-size-in-pixels-on (->m any/c void?)) + (set-size-mult (->m real? void?)) + (set-smoothing-off (->m font-smoothing/c void?)) + (set-smoothing-on (->m font-smoothing/c void?)) + (set-style-off (->m font-style/c void?)) + (set-style-on (->m font-style/c void?)) + (set-transparent-text-backing-off (->m any/c void?)) + (set-transparent-text-backing-on (->m any/c void?)) + (set-underlined-off (->m any/c void?)) + (set-underlined-on (->m any/c void?)) + (set-weight-off (->m font-weight/c void?)) + (set-weight-on (->m font-weight/c void?)))) + +(define style-list%/c + (class/c + (basic-style (->m (is-a?/c style<%>))) + (convert (->m (is-a?/c style<%>) (is-a?/c style<%>))) + (find-named-style (->m string? (or/c (is-a?/c style<%>) false/c))) + (find-or-create-join-style (->m (is-a?/c style<%>) (is-a?/c style<%>) (is-a?/c style<%>))) + (find-or-create-style (->m (is-a?/c style<%>) (is-a?/c style-delta%) (is-a?/c style<%>))) + (forget-notification (->m any/c void?)) + (index-to-style (->m exact-nonnegative-integer? (or/c (is-a?/c style<%>) false/c))) + (new-named-style (->m string? (is-a?/c style<%>) (is-a?/c style<%>))) + (notify-on-change (->m (-> (or/c (is-a?/c style<%>) false/c) any) any/c)) + (number (->m exact-nonnegative-integer?)) + (replace-named-style (->m string? (is-a?/c style<%>) (is-a?/c style<%>))) + (style-to-index (->m (is-a?/c style<%>) (or/c exact-nonnegative-integer? false/c))))) + +;; snip% utils +(define snip%-edit-operation/c + (one-of/c 'undo 'redo 'clear 'cut + 'copy 'paste 'kill 'select-all + 'insert-text-box 'insert-pasteboard-box 'insert-image)) + +;; snip% methods +(define snip%-adjust-cursor/c + (->m (is-a?/c dc<%>) + real? + real? + real? + real? + (is-a?/c mouse-event%) + (or/c (is-a?/c cursor%) false/c))) + +(define snip%-blink-caret/c + (->m (is-a?/c dc<%>) real? real? void?)) + +(define snip%-can-do-edit-operation/c + (->*m (snip%-edit-operation/c) + (any/c) + boolean?)) + +(define snip%-copy/c + (->m (is-a?/c snip%))) + +(define snip%-draw/c + (->m (is-a?/c dc<%>) + real? + real? + real? + real? + real? + real? + real? + real? + (one-of/c 'no-caret 'show-inactive-caret 'show-caret) + void?)) + +(define snip%-other-equal-to?/c + (->m (is-a?/c snip%) (-> any/c any/c boolean?) boolean?)) + +(define snip%-find-scroll-step/c + (->m real? exact-nonnegative-integer?)) + +(define snip%-get-admin/c + (->m (or/c (is-a?/c snip-admin%) false/c))) + +(define snip%-get-count/c + (->m exact-nonnegative-integer?)) + +(define snip%-get-extent/c + (->*m ((is-a?/c dc<%>) real? real?) + ((or/c (box/c (>=/c 0)) false/c) + (or/c (box/c (>=/c 0)) false/c) + (or/c (box/c (>=/c 0)) false/c) + (or/c (box/c (>=/c 0)) false/c) + (or/c (box/c (>=/c 0)) false/c) + (or/c (box/c (>=/c 0)) false/c)) + void?)) + +(define snip%-get-extent-override/c + (->m (is-a?/c dc<%>) + real? + real? + (or/c (box/c (>=/c 0)) false/c) + (or/c (box/c (>=/c 0)) false/c) + (or/c (box/c (>=/c 0)) false/c) + (or/c (box/c (>=/c 0)) false/c) + (or/c (box/c (>=/c 0)) false/c) + (or/c (box/c (>=/c 0)) false/c) + void?)) + +(define snip%-get-flags/c + (->m (listof symbol?))) + +(define snip%-get-num-scroll-steps/c + (->m exact-nonnegative-integer?)) + +(define snip%-get-scroll-step-offset/c + (->m exact-nonnegative-integer? + (>=/c 0))) + +(define snip%-get-snipclass/c + (->m (or/c #f (is-a?/c snip-class%)))) + +(define snip%-get-style/c + (->m (is-a?/c style<%>))) + +(define snip%-get-text/c + (->*m (exact-nonnegative-integer? exact-nonnegative-integer?) + (any/c) + string?)) + +(define snip%-get-text-override/c + (->m exact-nonnegative-integer? + exact-nonnegative-integer? + any/c + string?)) + +(define snip%-get-text!/c + (->m + (and/c string? (not/c immutable?)) + exact-nonnegative-integer? + exact-nonnegative-integer? + exact-nonnegative-integer? + void?)) + +(define snip%-is-owned?/c + (->m boolean?)) + +(define snip%-match?/c + (->m (is-a?/c snip%) boolean?)) + +(define snip%-merge-with/c + (->m (is-a?/c snip%) (or/c (is-a?/c snip%) false/c))) + +(define snip%-next/c + (->m (or/c (is-a?/c snip%) false/c))) + +(define snip%-on-char/c + (->m (is-a?/c dc<%>) + real? real? real? real? + (is-a?/c key-event%) + void?)) + +(define snip%-on-event/c + (->m (is-a?/c dc<%>) + real? real? real? real? + (is-a?/c mouse-event%) + void?)) + +(define snip%-own-caret/c + (->m any/c void?)) + +(define snip%-partial-offset/c + (->m (is-a?/c dc<%>) + real? real? + exact-nonnegative-integer? + real?)) + +(define snip%-previous/c + (->m (or/c (is-a?/c snip%) false/c))) + +(define snip%-release-from-owner/c + (->m boolean?)) + +(define snip%-resize/c + (->m (>=/c 0) + (>=/c 0) + boolean?)) + +(define snip%-set-admin/c + (->m (or/c (is-a?/c snip-admin%) false/c) void?)) + +(define snip%-set-count/c + (->m exact-positive-integer? void?)) + +(define snip%-set-flags/c + (->m (listof symbol?) void?)) + +(define snip%-set-snipclass/c + (->m (is-a?/c snip-class%) void?)) + +(define snip%-set-style/c + (->m (is-a?/c style<%>) void?)) + +(define snip%-set-unmodified/c + (->m void?)) + +(define snip%-size-cache-invalid/c + (->m void?)) + +(define snip%-split/c + (->m exact-nonnegative-integer? + (box/c (is-a?/c snip%)) + (box/c (is-a?/c snip%)) + void?)) + +(define snip%-write/c + (->m (is-a?/c editor-stream-out%) void?)) + +;; snip% class contract +(define snip%/c + (and/c + (equal<%>/c snip%) + (class/c + (adjust-cursor snip%-adjust-cursor/c) + (blink-caret snip%-blink-caret/c) + (can-do-edit-operation? snip%-can-do-edit-operation/c) + (copy snip%-copy/c) + (draw snip%-draw/c) + (other-equal-to? snip%-other-equal-to?/c) + (find-scroll-step snip%-find-scroll-step/c) + (get-admin snip%-get-admin/c) + (get-count snip%-get-count/c) + (get-extent snip%-get-extent/c) + (get-flags snip%-get-flags/c) + (get-num-scroll-steps snip%-get-num-scroll-steps/c) + (get-scroll-step-offset snip%-get-scroll-step-offset/c) + (get-snipclass snip%-get-snipclass/c) + (get-style snip%-get-style/c) + (get-text snip%-get-text/c) + (get-text! snip%-get-text!/c) + (is-owned? snip%-is-owned?/c) + (match? snip%-match?/c) + (merge-with snip%-merge-with/c) + (next snip%-next/c) + (on-char snip%-on-char/c) + (on-event snip%-on-event/c) + (own-caret snip%-own-caret/c) + (partial-offset snip%-partial-offset/c) + (previous snip%-previous/c) + (release-from-owner snip%-release-from-owner/c) + (resize snip%-resize/c) + (set-admin snip%-set-admin/c) + (set-count snip%-set-count/c) + (set-flags snip%-set-flags/c) + (set-snipclass snip%-set-snipclass/c) + (set-style snip%-set-style/c) + (set-unmodified snip%-set-unmodified/c) + (size-cache-invalid snip%-size-cache-invalid/c) + (split snip%-split/c) + (write snip%-write/c) + (override + (adjust-cursor snip%-adjust-cursor/c) + (draw snip%-draw/c) + (other-equal-to? snip%-other-equal-to?/c) + (find-scroll-step snip%-find-scroll-step/c) + (get-extent snip%-get-extent-override/c) + (get-num-scroll-steps snip%-get-num-scroll-steps/c) + (get-scroll-step-offset snip%-get-scroll-step-offset/c) + (get-text snip%-get-text-override/c) + (get-text! snip%-get-text!/c) + (match? snip%-match?/c) + (merge-with snip%-merge-with/c) + (on-char snip%-on-char/c) + (on-event snip%-on-event/c) + (own-caret snip%-own-caret/c) + (partial-offset snip%-partial-offset/c) + (release-from-owner snip%-release-from-owner/c) + (resize snip%-resize/c) + (set-count snip%-set-count/c) + (set-flags snip%-set-flags/c) + (set-unmodified snip%-set-unmodified/c) + (size-cache-invalid snip%-size-cache-invalid/c) + (split snip%-split/c))))) + + +;; snip-class% method contracts +(define snip-class%-get-classname/c + (->m string?)) + +(define snip-class%-get-version/c + (->m exact-integer?)) + +(define snip-class%-read/c + (->m (is-a?/c editor-stream-in%) + (or/c (is-a?/c snip%) false/c))) + +(define snip-class%-read-header/c + (->m (is-a?/c editor-stream-in%) boolean?)) + +(define snip-class%-reading-version/c + (->m (is-a?/c editor-stream-in%) exact-integer?)) + +(define snip-class%-set-classname/c + (->m string? void?)) + +(define snip-class%-set-version/c + (->m exact-integer? void?)) + +(define snip-class%-write-header/c + (->m (is-a?/c editor-stream-out%) boolean?)) + +;; snip-class% class contract +(define snip-class%/c + (class/c + (get-classname snip-class%-get-classname/c) + (get-version snip-class%-get-version/c) + (read snip-class%-read/c) + (read-header snip-class%-read-header/c) + (reading-version snip-class%-reading-version/c) + (set-classname snip-class%-set-classname/c) + (set-version snip-class%-set-version/c) + (write-header snip-class%-write-header/c) + (override + (read snip-class%-read/c) + (read-header snip-class%-read-header/c) + (write-header snip-class%-write-header/c)))) + +(define string-snip%/c + (class/c + (insert (->*m (string? exact-nonnegative-integer?) + (exact-nonnegative-integer?) + void?)) + (read (->m exact-nonnegative-integer? + (is-a?/c editor-stream-in%) + void?)))) + +(define tab-snip%/c + (class/c)) + +(define image-snip%/c + (class/c + (equal-hash-code-of (->m (any/c . -> . exact-integer?) exact-integer?)) + (equal-secondary-hash-code-of (->m (any/c . -> . exact-integer?) exact-integer?)) + (get-bitmap (->m (or/c (is-a?/c bitmap%) #f))) + (get-bitmap-mask (->m (or/c (is-a?/c bitmap%) #f))) + (get-filename (->*m () ((or/c (box/c any/c) #f)) (or/c path-string? #f))) + (get-filetype (->m tab-snip-filetype/c)) + (load-file (->*m ((or/c path-string? input-port? #f)) + (tab-snip-filetype/c any/c any/c) + void?)) + (other-equal-to? (->m (is-a?/c image-snip%) + (any/c any/c . -> . boolean?) + boolean?)) + (resize (->m (>=/c 0) + (>=/c 0) + boolean?)) + (set-bitmap (->*m ((is-a?/c bitmap%)) ((or/c (is-a?/c bitmap%) #f)) void?)) + (set-offset (->m real? real? void?)))) + +;; snip-admin% method contracts +(define snip-admin%-get-view/c + (->*m ((or/c (box/c real?) false/c) + (or/c (box/c real?) false/c) + (or/c (box/c (>=/c 0)) false/c) + (or/c (box/c (>=/c 0)) false/c)) + ((or/c (is-a?/c snip%) false/c)) + void?)) + +(define snip-admin%-get-view-size/c + (->m (or/c (box/c (>=/c 0)) false/c) + (or/c (box/c (>=/c 0)) false/c) + void?)) + +(define snip-admin%-modified/c + (->m (is-a?/c snip%) any/c void?)) + +(define snip-admin%-needs-update/c + (->m (is-a?/c snip%) + real? + real? + (>=/c 0) + (>=/c 0) + void?)) + +(define snip-admin%-popup-menu/c + (->m (is-a?/c popup-menu%) + (is-a?/c snip%) + real? + real? + boolean?)) + +(define snip-admin%-recounted/c + (->m (is-a?/c snip%) any/c void?)) + +(define snip-admin%-release-snip/c + (->m (is-a?/c snip%) boolean?)) + +(define snip-admin%-resized/c + (->m (is-a?/c snip%) any/c void?)) + +(define snip-admin%-scroll-to/c + (->*m ((is-a?/c snip%) + real? + real? + (>=/c 0) + (>=/c 0) + any/c) + ((one-of/c 'start 'end 'none)) + boolean?)) + +(define snip-admin%-set-caret-owner/c + (->m (is-a?/c snip%) + (one-of/c 'immediate 'display 'global) + void?)) + +(define snip-admin%-update-cursor/c + (->m void?)) + +(define snip-admin%-get-line-spacing/c + (->m (>=/c 0))) + +(define snip-admin%-get-selected-text-color/c + (->m (or/c (is-a?/c color%) #f))) + +(define snip-admin%-call-with-busy-cursor/c + (->m (-> any) any)) + +(define snip-admin%-get-tabs/c + (->*m () + ((or/c (box/c exact-nonnegative-integer?) false/c) + (or/c (box/c real?) false/c) + (or/c (box/c real?) false/c)) + (listof real?))) + +(define snip-admin%/c + (class/c + (get-dc (->m (or/c (is-a?/c dc<%>) false/c))) + (get-editor (->m (or/c (is-a?/c text%) (is-a?/c pasteboard%)))) + (get-view snip-admin%-get-view/c) + (get-view-size snip-admin%-get-view-size/c) + (modified snip-admin%-modified/c) + (needs-update snip-admin%-needs-update/c) + (popup-menu snip-admin%-popup-menu/c) + (recounted snip-admin%-recounted/c) + (release-snip snip-admin%-release-snip/c) + (resized snip-admin%-resized/c) + (scroll-to snip-admin%-scroll-to/c) + (set-caret-owner snip-admin%-set-caret-owner/c) + (update-cursor snip-admin%-update-cursor/c) + (get-line-spacing snip-admin%-get-line-spacing/c) + (get-selected-text-color snip-admin%-get-selected-text-color/c) + (call-with-busy-cursor snip-admin%-call-with-busy-cursor/c) + (get-tabs snip-admin%-get-tabs/c) + (override + (get-view snip-admin%-get-view/c) + (get-view-size snip-admin%-get-view-size/c) + (modified snip-admin%-modified/c) + (needs-update snip-admin%-needs-update/c) + (popup-menu snip-admin%-popup-menu/c) + (recounted snip-admin%-recounted/c) + (release-snip snip-admin%-release-snip/c) + (resized snip-admin%-resized/c) + (scroll-to snip-admin%-scroll-to/c) + (set-caret-owner snip-admin%-set-caret-owner/c) + (update-cursor snip-admin%-update-cursor/c) + (get-line-spacing snip-admin%-get-line-spacing/c) + (get-selected-text-color snip-admin%-get-selected-text-color/c) + (call-with-busy-cursor snip-admin%-call-with-busy-cursor/c) + (get-tabs snip-admin%-get-tabs/c))))