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

Add new Class type representation

Browse Source 
This commit introduces a new Class type representation
and adds initial support for parsing the new types.

Existing uses of Class types are adjusted to compile.
This commit is contained in:
Asumu Takikawa 2013-05-07 11:02:42 -04:00
parent 1f27fb7848
commit 72c991c1de
14 changed files with 424 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
pkgs/drracket-pkgs/drracket/drracket/private/auto-language.rkt
View File

@ -1,4 +1,4 @@
#lang typed/racket/base
#lang typed/racket
(require typed/framework/framework
typed/mred/mred
@ -6,13 +6,13 @@
(provide pick-new-language looks-like-module?)
(define-type-alias (Language:Language% Settings)
(Class () () ([get-reader-module (-> Sexp)]
[get-metadata-lines (-> Number)]
[metadata->settings (String -> Settings)])))
(define-type (Language:Language% Settings)
(Class [get-reader-module (-> Sexp)]
[get-metadata-lines (-> Number)]
[metadata->settings (String -> Settings)]))
(define-type-alias (Language:Object Settings)
(Instance (Class () () ())))
(define-type (Language:Object Settings)
(Instance (Class)))
(: pick-new-language (All (S)
((Instance Text%)

21
pkgs/drracket-pkgs/drracket/drracket/private/insert-large-letters.rkt
View File

@ -1,14 +1,13 @@
#lang typed/racket/base
#lang typed/racket
(require typed/mred/mred
typed/framework/framework
racket/class
string-constants)
(define-type-alias Bitmap-Message% (Class ()
([parent (Instance Horizontal-Panel%)])
([set-bm ((Instance Bitmap%) -> Void)])))
(define-type Bitmap-Message%
(Class (init [parent (Instance Horizontal-Panel%)])
[set-bm ((Instance Bitmap%) -> Void)]))
(require/typed "bitmap-message.rkt"
[bitmap-message% Bitmap-Message%])
@ -61,7 +60,7 @@
[parent dlg]
[stretchable-height #f]))
(define: font-choice : (Instance Choice%)
(let ([tmp-bdc (make-object bitmap-dc% (make-object bitmap% 1 1 #f))])
(let ([tmp-bdc (new bitmap-dc% [bitmap (make-bitmap 1 1 #f)])])
(new choice%
[label (string-constant fonts)]
[parent info-bar]
@ -157,11 +156,11 @@
(: render-large-letters (String Char (Instance Font%) String (Instance Text:Basic%) -> (Instance Bitmap%)))
(define (render-large-letters comment-prefix comment-character the-font str edit)
(define bdc (make-object bitmap-dc% (make-object bitmap% 1 1 #t)))
(define bdc (new bitmap-dc% [bitmap (make-bitmap 1 1 #t)]))
(define-values (tw raw-th td ta) (send bdc get-text-extent str the-font))
(define th (let-values ([(_1 h _2 _3) (send bdc get-text-extent "X" the-font)])
(max raw-th h)))
(define tmp-color (make-object color%))
(define tmp-color (make-color 0 0 0))
(: get-char (Real Real -> Char))
(define (get-char x y)
@ -171,9 +170,9 @@
comment-character
#\space)))
(define bitmap
(make-object bitmap%
(max 1 (inexact->exact tw))
(inexact->exact th)
(make-bitmap
(max 1 (assert (exact-floor tw) positive?))
(assert (exact-floor th) positive?)
#t))
(: fetch-line (Real -> String))

22
pkgs/images-pkgs/images-lib/images/private/flomap.rkt
View File

@ -14,18 +14,16 @@
;; but requiring that produces an error when building
;; the docs
(define-type Bitmap%
(Class (Real Real Boolean)
()
([get-width (-> Integer)]
[get-height (-> Integer)]
[get-argb-pixels
(case->
(Integer Integer Integer Integer Bytes [#:unscaled? Boolean]
-> Void)
(Integer Integer Integer Integer Bytes Boolean [#:unscaled? Boolean]
-> Void)
(Integer Integer Integer Integer Bytes Boolean Boolean [#:unscaled? Boolean]
-> Void))])))
(Class [get-width (-> Integer)]
[get-height (-> Integer)]
[get-argb-pixels
(case->
(Integer Integer Integer Integer Bytes [#:unscaled? Boolean]
-> Void)
(Integer Integer Integer Integer Bytes Boolean [#:unscaled? Boolean]
-> Void)
(Integer Integer Integer Integer Bytes Boolean Boolean [#:unscaled? Boolean]
-> Void))]))
(require/typed
"flomap-convert.rkt"

6
pkgs/plot-pkgs/plot-lib/plot/typed/private/common/types.rkt
View File

@ -12,9 +12,9 @@
(define-type (Treeof A) (Rec T (U A (Listof T))))
(define-type Plot-Device% (Class () () ()))
(define-type 2D-Plot-Area% (Class () () ()))
(define-type 3D-Plot-Area% (Class () () ()))
(define-type Plot-Device% (Class))
(define-type 2D-Plot-Area% (Class))
(define-type 3D-Plot-Area% (Class))
;; ===================================================================================================
;; Struct types

163
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt
View File

@ -10,7 +10,12 @@
syntax/stx (prefix-in c: (contract-req))
syntax/parse unstable/sequence
(env tvar-env type-name-env type-alias-env lexical-env index-env)
(only-in racket/class init init-field field)
(for-template (only-in racket/class init init-field field))
(only-in racket/list flatten)
racket/match
racket/syntax
(only-in unstable/list check-duplicate)
"parse-classes.rkt"
(for-label
(except-in racket/base case-lambda)
@ -241,19 +246,8 @@
[(fst . rst)
#:fail-unless (not (syntax->list #'rst)) #f
(-pair (parse-type #'fst) (parse-type #'rst))]
[(:Class^ (pos-args ...) ([fname fty . rest] ...) ([mname mty] ...))
(make-Class
(parse-types #'(pos-args ...))
(map list
(stx-map syntax-e #'(fname ...))
(parse-types #'(fty ...))
(for/list ((e (in-syntax #'(rest ...))))
(syntax-case e ()
[(#t) #t]
[_ #f])))
(map list
(stx-map syntax-e #'(mname ...))
(parse-types #'(mty ...))))]
[(:Class^ e ...)
(parse-class-type stx)]
[(:Refinement^ p?:id)
(match (lookup-type/lexical #'p?)
[(and t (Function: (list (arr: (list dom) _ #f #f '()))))
@ -536,6 +530,149 @@
[t
(-values (list (parse-type #'t)))])))
;;; Syntax classes and utilities for (Class ...) type parsing
;; Syntax -> Syntax
;; removes two levels of nesting
(define (flatten-class-clause stx)
(flatten (map stx->list (stx->list stx))))
(define-splicing-syntax-class class-type-clauses
#:description "Class type clause"
#:attributes (extends-type
init-names init-types init-optional?s
init-field-names init-field-types
init-field-optional?s
field-names field-types
method-names method-types)
#:literals (init init-field field)
(pattern (~seq (~or (~optional (~seq #:extends extends-type))
(init init-clause:init-type ...)
(init-field init-field-clause:init-type ...)
(field field-clause:field-or-method-type ...)
method-clause:field-or-method-type)
...)
;; FIXME: improve these somehow
#:with init-names (flatten-class-clause #'((init-clause.label ...) ...))
#:with init-types (flatten-class-clause #'((init-clause.type ...) ...))
#:attr init-optional?s (flatten (attribute init-clause.optional?))
#:with init-field-names (flatten-class-clause #'((init-field-clause.label ...) ...))
#:with init-field-types (flatten-class-clause #'((init-field-clause.type ...) ...))
#:attr init-field-optional?s (flatten (attribute init-field-clause.optional?))
#:with field-names (flatten-class-clause #'((field-clause.label ...) ...))
#:with field-types (flatten-class-clause #'((field-clause.type ...) ...))
#:with method-names #'(method-clause.label ...)
#:with method-types #'(method-clause.type ...)
#:fail-when
(check-duplicate-identifier
(append (syntax->list #'init-names)
(syntax->list #'init-field-names)))
"duplicate init or init-field clause"
#:fail-when
(check-duplicate-identifier
(append (syntax->list #'field-names)
(syntax->list #'init-field-names)))
"duplicate field or init-field clause"
#:fail-when
(check-duplicate-identifier (syntax->list #'method-names))
"duplicate method clause"))
(define-syntax-class init-type
#:description "Initialization argument label and type"
#:attributes (label type optional?)
(pattern
(label:id type:expr
(~optional (~and #:optional (~bind [optional? #t]))))))
(define-syntax-class field-or-method-type
#:description "Pair of field or method label and type"
#:attributes (label type)
(pattern (label:id type:expr)))
;; process-class-clauses :
;; (U #f Type)
;; (Listof Symbol) (Listof Type) (Listof Boolean) x2
;; (Listof Symbol) (Listof Type) x2
;; -> (L (List Name Type Boolean)) (L (List Name Type)) (L (List Name Type))
;; Merges #:extends class type and the current class clauses appropriately
(define (process-class-clauses maybe-parent
init-names init-types init-optional?s
init-field-names init-field-types
init-field-optional?s
field-names field-types
method-names method-types)
;; (Listof Symbol) String -> Void
;; check for duplicates in a class clause
(define (check-duplicate-clause clause-lst err-msg)
(define maybe-dup (check-duplicate clause-lst))
(when maybe-dup
(tc-error err-msg maybe-dup)))
(define-values (super-inits super-fields super-methods)
(match maybe-parent
[(Class: _ inits fields methods)
(values inits fields methods)]
[_ (values null null null)]))
(match-define (list (list super-init-names _ _) ...) super-inits)
(match-define (list (list super-field-names _) ...) super-fields)
(match-define (list (list super-method-names _) ...) super-methods)
;; if any duplicates are found between this class and the superclass
;; type, then raise an error
(check-duplicate-clause
(append init-names init-field-names super-init-names)
"init or init-field name ~a conflicts with #:extends clause")
(check-duplicate-clause
(append field-names init-field-names super-field-names)
"field or init-field name ~a conflicts with #:extends clause")
(check-duplicate-clause
(append method-names super-method-names)
"method name ~a conflicts with #:extends clause")
;; then append the super types if there were no errors
(define inits
(append
super-inits
(map list
(append init-names init-field-names)
(append init-types init-field-types)
(append init-optional?s init-field-optional?s))))
(define fields
(append
super-fields
(map list
(append field-names init-field-names)
(append field-types init-field-types))))
(define methods
(append
super-methods
(map list method-names method-types)))
(values inits fields methods))
;; Syntax (Syntax -> Type) -> Type
;; Parse a (Class ...) type
(define (parse-class-type stx)
(syntax-parse stx
[(kw clause:class-type-clauses)
(add-disappeared-use #'kw)
(define parent-type (and (attribute clause.extends-type)
(parse-type (attribute clause.extends-type))))
(define-values (inits fields methods)
(process-class-clauses parent-type
(stx-map syntax-e #'clause.init-names)
(stx-map parse-type #'clause.init-types)
(attribute clause.init-optional?s)
(stx-map syntax-e #'clause.init-field-names)
(stx-map parse-type #'clause.init-field-types)
(attribute clause.init-field-optional?s)
(stx-map syntax-e #'clause.field-names)
(stx-map parse-type #'clause.field-types)
(stx-map syntax-e #'clause.method-names)
(stx-map parse-type #'clause.method-types)))
(make-Class
#f ;; FIXME: put type if it's a row variable
inits fields methods)]))
(define (parse-tc-results stx)
(syntax-parse stx
[(:values^ t ...)

6
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt
View File

@ -289,9 +289,11 @@
(recursive-sc-use (if (from-typed? typed-side) typed-n* untyped-n*)))])]
[(Instance: (? Mu? t))
(t->sc (make-Instance (resolve-once t)))]
[(Instance: (Class: _ _ (list (list names functions) ...)))
[(Instance: (Class: _ _ _ (list (list names functions) ...)))
(object/sc (map (λ (n sc) (member-spec 'method n sc)) names (map t->sc/method functions)))]
[(Class: _ (list (list by-name-inits by-name-init-tys _) ...) (list (list names functions) ...))
[(Class: _ (list (list by-name-inits by-name-init-tys _) ...)
fields
(list (list names functions) ...))
(class/sc (append
(map (λ (n sc) (member-spec 'method n sc))
names (map t->sc/method functions))

31
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt
View File

@ -434,28 +434,39 @@
;; t : Type
(def-type Syntax ([t Type/c]) [#:key 'syntax])
;; pos-flds : (Listof Type)
;; name-flds : (Listof (Tuple Symbol Type Boolean))
;; methods : (Listof (Tuple Symbol Function))
(def-type Class ([pos-flds (listof Type/c)]
[name-flds (listof (list/c symbol? Type/c boolean?))]
;; extended-tvar : RowVar
;; name-inits : (Listof (Tuple Symbol Type Boolean))
;; fields : (Listof (Tuple Symbol Type))
;; methods : (Listof (Tuple Symbol Function))
;;
;; interp. The first field represents a row variable.
;; The second field represents the named
;; initialization argument types.
;; The remainder are the types for public fields and
;; public methods, respectively.
;;
(def-type Class ([extended-tvar (listof Type/c)]
[inits (listof (list/c symbol? Type/c boolean?))]
[fields (listof (list/c symbol? Type/c))]
[methods (listof (list/c symbol? Function?))])
[#:frees (λ (f) (combine-frees
(map f (append pos-flds
(map cadr name-flds)
(map f (append (map cadr inits)
(map cadr fields)
(map cadr methods)))))]
[#:key 'class]
[#:fold-rhs (match (list pos-flds name-flds methods)
[#:fold-rhs (match (list extended-tvar inits fields methods)
[(list
pos-tys
tvar
(list (list init-names init-tys reqd) ___)
(list (list fname fty) ___)
(list (list mname mty) ___))
(*Class
(map type-rec-id pos-tys)
tvar ;; FIXME: is this correct?
(map list
init-names
(map type-rec-id init-tys)
reqd)
(map list fname (map type-rec-id fty))
(map list mname (map type-rec-id mty)))])])
;; cls : Class

3
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt
View File

@ -37,7 +37,8 @@
[name-assoc (stx-map cons names named-args)])
(match (resolve (tc-expr/t cl))
[(Union: '()) (ret (Un))]
[(and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _))
[(and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...)
fields _))
(unless (= (length pos-tys)
(syntax-length pos-args))
(tc-error/delayed "expected ~a positional arguments, but got ~a"

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-send.rkt
View File

@ -13,7 +13,7 @@
(define (tc/send form rcvr method args [expected #f])
(match (tc-expr rcvr)
[(tc-result1: (Instance: (and c (Class: _ _ methods))))
[(tc-result1: (Instance: (and c (Class: _ _ _ methods))))
(match (tc-expr method)
[(tc-result1: (Value: (? symbol? s)))
(let* ([ftype (cond [(assq s methods) => cadr]

30
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt
View File

@ -327,6 +327,34 @@
`(case-> ,@cover)
(car cover))])]))
;; class->sexp : Class -> S-expression
;; Convert a class type to an s-expression
(define (class->sexp cls)
(match-define (Class: _ inits fields methods) cls)
(define inits*
(if (null? inits)
null
(list
(cons 'init
(for/list ([init inits])
(match-define (list name type opt?) init)
(if opt?
(list name (type->sexp type) '#:optional)
(list name (type->sexp type))))))))
(define fields*
(if (null? fields)
null
(list
(cons 'field
(for/list ([name+type (in-list fields)])
(match-define (list name type) name+type)
`(,name ,(type->sexp type)))))))
(define methods*
(for/list ([name+type (in-list methods)])
(match-define (list name type) name+type)
`(,name ,(type->sexp type))))
`(Class ,@inits* ,@fields* ,@methods*))
;; type->sexp : Type -> S-expression
;; convert a type to an s-expression that can be printed
(define (type->sexp type [ignored-names '()])
@ -461,7 +489,7 @@
[(B: idx) `(B ,idx)]
[(Syntax: t) `(Syntaxof ,(t->s t))]
[(Instance: t) `(Instance ,(t->s t))]
[(Class: pf nf ms) '(Class)]
[(? Class?) (class->sexp type)]
[(Result: t (FilterSet: (Top:) (Top:)) (Empty:)) (type->sexp t)]
[(Result: t fs (Empty:)) `(,(type->sexp t) : ,(filter->sexp fs))]
[(Result: t fs lo) `(,(type->sexp t) : ,(filter->sexp fs) : ,(object->sexp lo))]

10
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt
View File

@ -579,12 +579,12 @@
(subtype* A0 (cl->* (-> out) (-> in -Void)) t)]
[((Instance: t) (Instance: t*))
(subtype* A0 t t*)]
[((Class: '() '() (list (and s (list names meths )) ...))
(Class: '() '() (list (and s* (list names* meths*)) ...)))
[((Class: _ '() fields (list (and s (list names meths )) ...))
(Class: _ '() fields (list (and s* (list names* meths*)) ...)))
(for/fold ([A A0])
([n (in-list names*)] [m (in-list meths*)] #:break (not A))
(and A (cond [(assq n s) => (lambda (spec) (subtype* A (cadr spec) m))]
[else #f])))]
([n (in-list names*)] [m (in-list meths*)] #:break (not A))
(and A (cond [(assq n s) => (lambda (spec) (subtype* A (cadr spec) m))]
[else #f])))]
;; otherwise, not a subtype
[(_ _) #f])))
(when (null? A)

12
pkgs/typed-racket-pkgs/typed-racket-more/typed/framework/framework.rkt
View File

@ -1,13 +1,11 @@
#lang typed/racket/base
(require typed/private/utils typed/mred/mred)
(require racket/class
typed/private/utils
typed/mred/mred)
(dt Style-List% (Class ()
()
([find-named-style
(String -> (Instance (Class ()
()
([get-font (-> (Instance Font%))]))))])))
(define-type Style-List%
(Class [find-named-style (String -> (Instance (Class [get-font (-> (Instance Font%))])))]))
(require/typed/provide
framework/framework

233
pkgs/typed-racket-pkgs/typed-racket-more/typed/mred/mred.rkt
View File

@ -1,97 +1,150 @@
#lang typed/racket/base
(require typed/private/utils)
(require racket/class
typed/private/utils)
(dt Frame% (Class ()
([label String])
([show (Any -> Void)])))
(provide Frame%
Bitmap%
Font-List%
Font%
Dialog%
Text-Field%
Horizontal-Panel%
Choice%
Message%
Horizontal-Pane%
Editor-Canvas%
Bitmap-DC%
Color%
Snip%
Text:Basic%
Text%
Button%
Event%)
(dt Bitmap% (Class (Real Real Boolean)
()
([get-width (-> Integer)]
[get-height (-> Integer)])))
(dt Font-List% (Class () () ([find-or-create-font
(case-lambda
(Integer Symbol Symbol Symbol -> (Instance Font%))
(Integer String Symbol Symbol Symbol -> (Instance Font%)))])))
(dt Font% (Class () () ([get-face (-> (Option String))]
[get-point-size (-> Integer)])))
(dt Dialog% (Class ()
([parent Any] [width Integer] [label String])
([show (Any -> Void)])))
(dt Text-Field% (Class ()
([parent (Instance Dialog%)]
[callback (Any Any -> Any)]
[label String])
([get-value (-> String)]
[focus (-> Void)])))
(dt Horizontal-Panel% (Class ()
([parent (Instance Dialog%)]
[stretchable-height Any #t]
[alignment (List Symbol Symbol) #t])
()))
(dt Choice% (Class ()
([parent (Instance Horizontal-Panel%)] [label String] [choices (Listof Any)] [callback (Any Any -> Any)])
([get-selection (-> (Option Natural))]
[set-selection (Integer -> Any)]
[get-string-selection (-> (Option String))]
[set-string-selection (String -> Void)])))
(dt Message% (Class ()
([parent (Instance Horizontal-Panel%)] [label String])
([set-label ((U String (Instance Bitmap%)) -> Void)])))
(dt Horizontal-Pane% (Class ()
([parent (Instance Horizontal-Panel%)])
()))
(dt Editor-Canvas% (Class ()
([parent (Instance Dialog%)] [editor (Instance Text:Basic%)])
([set-line-count ((U #f Integer) -> Void)])))
(dt Bitmap-DC% (Class ((Instance Bitmap%))
()
([get-text-extent (String (Instance Font%) -> (values Real Real Real Real))]
[get-pixel (Number Number (Instance Color%) -> Boolean)]
[set-bitmap ((Option (Instance Bitmap%)) -> Void)]
[clear (-> Void)]
[set-font ((Instance Font%) -> Void)]
[draw-text (String Number Number -> Void)])))
(dt Color% (Class () () ([red (-> Number)])))
(define-type Frame%
(Rec This
(Class (init [label String]
[parent (Option This) #:optional]
[width (Option Integer) #:optional]
[height (Option Integer) #:optional]
[x (Option Integer) #:optional]
[y (Option Integer) #:optional]
;; more
)
[show (Any -> Void)])))
(dt Snip% (Class () () ([get-count (-> Integer)])))
(define-type Bitmap%
(Class [get-width (-> Integer)]
[get-height (-> Integer)]))
(dt Text:Basic% (Class ()
()
([begin-edit-sequence (-> Void)]
[end-edit-sequence (-> Void)]
[lock (Boolean -> Void)]
[last-position (-> Number)]
[last-paragraph (-> Exact-Nonnegative-Integer)]
[delete (Number Number -> Void)]
[auto-wrap (Any -> Void)]
[paragraph-end-position (Number -> Integer)]
[paragraph-start-position (Number -> Integer)]
[get-start-position (-> Integer)]
[get-end-position (-> Integer)]
[get-text (Integer (U Integer 'eof) -> String)]
[insert (String Number Number -> Void)])))
(define-type Font-List%
(Class
[find-or-create-font
(case-> (Integer Symbol Symbol Symbol -> (Instance Font%))
(Integer String Symbol Symbol Symbol -> (Instance Font%)))]))
(dt Text% (Class ()
()
([begin-edit-sequence (-> Void)]
[end-edit-sequence (-> Void)]
[lock (Boolean -> Void)]
[last-position (-> Number)]
[last-paragraph (-> Exact-Nonnegative-Integer)]
[delete (Number Number -> Void)]
[auto-wrap (Any -> Void)]
[paragraph-end-position (Number -> Integer)]
[paragraph-start-position (Number -> Integer)]
[get-start-position (-> Integer)]
[get-end-position (-> Integer)]
[while-unlocked ((-> Any) -> Any)]
[get-text (Integer (U Integer 'eof) -> String)]
[insert (String Number Number -> Void)])))
(define-type Font%
(Class [get-face (-> (Option String))]
[get-point-size (-> Integer)]))
(dt Button% (Rec B% (Class (String (Instance Frame%) (B% Any -> Any)) () ())))
(dt Event% (Class () () ()))
(define-type Dialog%
(Class (init [label String]
[parent Any #:optional]
[width Integer #:optional])
[show (Any -> Void)]))
(define-type Text-Field%
(Class (init [label String]
[parent (Instance Dialog%)]
[callback (Any Any -> Any) #:optional])
[get-value (-> String)]
[focus (-> Void)]))
(define-type Horizontal-Panel%
(Class (init [parent (Instance Dialog%)]
[stretchable-height Any #:optional]
[alignment (List Symbol Symbol) #:optional])))
(define-type Choice%
(Class (init [parent (Instance Horizontal-Panel%)]
[label String]
[choices (Listof Any)]
[callback (Any Any -> Any)])
[get-selection (-> (Option Natural))]
[set-selection (Integer -> Any)]
[get-string-selection (-> (Option String))]
[set-string-selection (String -> Void)]))
(define-type Message%
(Class (init [parent (Instance Horizontal-Panel%)]
[label String])
[set-label ((U String (Instance Bitmap%)) -> Void)]))
(define-type Horizontal-Pane%
(Class (init [parent (Instance Horizontal-Panel%)])))
(define-type Editor-Canvas%
(Class (init [parent (Instance Dialog%)]
[editor (Instance Text:Basic%)])
[set-line-count ((U #f Integer) -> Void)]))
(define-type Bitmap-DC%
(Class (init [bitmap (Instance Bitmap%)])
[get-text-extent (String (Instance Font%) ->
(values Nonnegative-Real Nonnegative-Real
Nonnegative-Real Nonnegative-Real))]
[get-pixel (Number Number (Instance Color%) -> Boolean)]
[set-bitmap ((Option (Instance Bitmap%)) -> Void)]
[clear (-> Void)]
[set-font ((Instance Font%) -> Void)]
[draw-text (String Number Number -> Void)]))
(define-type Color%
(Class [red (-> Number)]))
(define-type Snip%
(Class [get-count (-> Integer)]))
(define-type Text:Basic%
(Class [begin-edit-sequence (-> Void)]
[end-edit-sequence (-> Void)]
[lock (Boolean -> Void)]
[last-position (-> Number)]
[last-paragraph (-> Exact-Nonnegative-Integer)]
[delete (Number Number -> Void)]
[auto-wrap (Any -> Void)]
[paragraph-end-position (Number -> Integer)]
[paragraph-start-position (Number -> Integer)]
[get-start-position (-> Integer)]
[get-end-position (-> Integer)]
[get-text (Integer (U Integer 'eof) -> String)]
[insert (String Number Number -> Void)]))
(define-type Text%
(Class [begin-edit-sequence (-> Void)]
[end-edit-sequence (-> Void)]
[lock (Boolean -> Void)]
[last-position (-> Number)]
[last-paragraph (-> Exact-Nonnegative-Integer)]
[delete (Number Number -> Void)]
[auto-wrap (Any -> Void)]
[paragraph-end-position (Number -> Integer)]
[paragraph-start-position (Number -> Integer)]
[get-start-position (-> Integer)]
[get-end-position (-> Integer)]
[while-unlocked ((-> Any) -> Any)]
[get-text (Integer (U Integer 'eof) -> String)]
[insert (String Number Number -> Void)]))
(define-type Button%
(Rec B%
(Class (init [label String]
[parent (Instance Frame%)]
[callback (B% Any -> Any)]))))
(define-type Event%
(Class))
(require/typed/provide
racket/gui
@ -109,7 +162,15 @@
[editor-canvas% Editor-Canvas%]
[bitmap-dc% Bitmap-DC%]
[bitmap% Bitmap%]
[make-bitmap
(case->
(Exact-Positive-Integer Exact-Positive-Integer -> (Instance Bitmap%))
(Exact-Positive-Integer Exact-Positive-Integer Any -> (Instance Bitmap%)))]
[color% Color%]
[make-color
(case->
(Byte Byte Byte -> (Instance Color%))
(Byte Byte Byte Real -> (Instance Color%)))]
[snip% Snip%]
[message-box (String String -> (U 'ok 'cancel 'yes 'no))]
[open-input-text-editor

30
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt
View File

@ -17,6 +17,7 @@
(base-env base-types base-types-extra colon)
;; needed for parsing case-lambda/case-> types
(only-in (base-env case-lambda) case-lambda)
(only-in racket/class init init-field field)
rackunit)
@ -196,6 +197,35 @@
(->optkey -String [] #:rest -String #:a -String #t -String)]
[(String [#:a String] String * -> String)
(->optkey -String [] #:rest -String #:a -String #f -String)]
;;; Classes
[(Class) (make-Class #f null null null)]
[(Class (init [x Number] [y Number]))
(make-Class #f `((x ,-Number #f) (y ,-Number #f)) null null)]
[(Class (init [x Number] [y Number #:optional]))
(make-Class #f `((x ,-Number #f) (y ,-Number #t)) null null)]
[(Class (init [x Number]) (init-field [y Number]))
(make-Class #f `((x ,-Number #f) (y ,-Number #f)) `((y ,-Number))
null)]
[(Class [m (Number -> Number)])
(make-Class #f null null `((m ,(t:-> N N))))]
[(Class [m (Number -> Number)] (init [x Number]))
(make-Class #f `((x ,-Number #f)) null `((m ,(t:-> N N))))]
[(Class [m (Number -> Number)] (field [x Number]))
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))]
[FAIL (Class foobar)]
[FAIL (Class [x UNBOUND])]
[FAIL (Class [x Number #:random-keyword])]
[FAIL (Class (random-clause [x Number]))]
;; test duplicates
[FAIL (Class [x Number] [x Number])]
[FAIL (Class (init [x Number]) (init [x Number]))]
[FAIL (Class (init [x Number]) (init-field [x Number]))]
[FAIL (Class (field [x Number]) (init-field [x Number]))]
;; test #:extends
[(Class #:extends (Class [m (Number -> Number)]) (field [x Number]))
(make-Class #f null `((x ,-Number)) `((m ,(t:-> N N))))]
[FAIL (Class #:extends (Class [m (Number -> Number)]) [m String])]
))
;; FIXME - add tests for parse-values-type, parse-tc-results