From c224d2ebfc878ddb2758cdd409cacd2dbf49e891 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 10 Feb 2010 20:23:59 +0000 Subject: [PATCH] More precise types for typed MrEd wrappers. More precise types in auto-language.ss svn: r18041 --- collects/drscheme/private/auto-language.ss | 30 +++++++++-------- collects/typed/framework/framework.ss | 19 ++++++----- collects/typed/mred/mred.ss | 38 +++++++++++++--------- collects/typed/net/mime.ss | 7 ++-- 4 files changed, 52 insertions(+), 42 deletions(-) diff --git a/collects/drscheme/private/auto-language.ss b/collects/drscheme/private/auto-language.ss index f0bf4a4f4a..d6f3cceb89 100644 --- a/collects/drscheme/private/auto-language.ss +++ b/collects/drscheme/private/auto-language.ss @@ -9,21 +9,23 @@ (: reader-tag String) (define reader-tag "#reader") -(: pick-new-language ((Instance Text%) - (Listof - (Instance (Class () () ([get-reader-module (-> Any)] - [get-metadata-lines (-> Number)] - [metadata->settings (String -> Any)])))) - Any Any -> (values Any Any))) +(define-type-alias (Language% Settings) + (Class () () ([get-reader-module (-> Sexp)] + [get-metadata-lines (-> Number)] + [metadata->settings (String -> Settings)]))) + +(: pick-new-language (All (S) + ((Instance Text%) + (Listof + (Instance (Language% S))) + (U #f (Instance (Language% S))) (U #f S) -> (values (U #f (Instance (Language% S))) (U #f S))))) (define (pick-new-language text all-languages module-language module-language-settings) (with-handlers ([exn:fail:read? (λ (x) (values #f #f))]) - (let: ([found-language? : Any #f] - [settings : Any #f]) + (let: ([found-language? : (U #f (Instance (Language% S))) #f] + [settings : (U #f S) #f]) (for-each - (λ: ([lang : (Instance (Class () () ([get-reader-module (-> Any)] - [get-metadata-lines (-> Number)] - [metadata->settings (String -> Any)])))]) + (λ: ([lang : (Instance (Language% S))]) (let ([lang-spec (send lang get-reader-module)]) (when lang-spec (let* ([lines (send lang get-metadata-lines)] @@ -51,7 +53,7 @@ (values found-language? settings)))) -(: looks-like-module? ((Instance Text%) -> Any)) +(: looks-like-module? ((Instance Text%) -> Boolean)) (define (looks-like-module? text) (or (looks-like-new-module-style? text) (looks-like-old-module-style? text))) @@ -66,11 +68,11 @@ (pair? r1) (eq? (car r1) 'module))))) -(: looks-like-new-module-style? ((Instance Text%) -> Any)) +(: looks-like-new-module-style? ((Instance Text%) -> Boolean)) (define (looks-like-new-module-style? text) (let* ([tp (open-input-text-editor text 0 'end (lambda (s) s) text #t)] [l1 (with-handlers ([exn:fail? (lambda (exn) eof)]) ;; If tp contains a snip, read-line fails. (read-line tp))]) (and (string? l1) - (regexp-match #rx"#lang .*$" l1)))) + (regexp-match? #rx"#lang .*$" l1)))) diff --git a/collects/typed/framework/framework.ss b/collects/typed/framework/framework.ss index a447016b95..ab85a77962 100644 --- a/collects/typed/framework/framework.ss +++ b/collects/typed/framework/framework.ss @@ -1,7 +1,6 @@ #lang typed-scheme -(require typed/private/utils - (only-in typed/mred/mred Font%)) +(require typed/private/utils typed/mred/mred) (dt Style-List% (Class () () @@ -25,13 +24,15 @@ [get-end-position (-> Number)] [insert (String Number Number -> Void)]))) -(require/typed/provide framework/framework - [preferences:set-default (Symbol Any Any -> Void)] - [preferences:set (Symbol Any -> Void)] - [editor:get-standard-style-list - (-> (Instance Style-List%))] - [scheme:text% Scheme:Text%] - [gui-utils:ok/cancel-buttons (Any (Any Any -> Any) (Any Any -> Any) -> (values Any Any))]) +(require/typed/provide + framework/framework + [preferences:set-default (Symbol Sexp (Any -> Boolean) -> Void)] + [preferences:set (Symbol Sexp -> Void)] + [editor:get-standard-style-list + (-> (Instance Style-List%))] + [scheme:text% Scheme:Text%] + [gui-utils:ok/cancel-buttons + ((Instance Horizontal-Panel%) ((Instance Button%) (Instance Event%) -> Void) ((Instance Button%) (Instance Event%) -> Void) -> (values Any Any))]) (require/typed/provide "prefs-contract.ss" [preferences:get-drscheme:large-letters-font (-> (U #f (Pair String Number)))]) diff --git a/collects/typed/mred/mred.ss b/collects/typed/mred/mred.ss index 60e475e4ba..91a19bc0d5 100644 --- a/collects/typed/mred/mred.ss +++ b/collects/typed/mred/mred.ss @@ -46,6 +46,8 @@ [draw-text (String Number Number -> Void)]))) (dt Color% (Class () () ([red (-> Number)]))) +(dt Snip% (Class () () ())) + (dt Text% (Class () () ([begin-edit-sequence (-> Void)] @@ -63,20 +65,26 @@ [get-text (Integer (U Integer 'eof) -> String)] [insert (String Number Number -> Void)]))) +(dt Button% (Class () () ())) +(dt Event% (Class () () ())) - -(require/typed/provide mred/mred - [the-font-list (Instance Font-List%)] - [dialog% Dialog%] - [text-field% Text-Field%] - [horizontal-panel% Horizontal-Panel%] - [choice% Choice%] - [get-face-list (-> (Listof String))] - [message% Message%] - [horizontal-pane% Horizontal-Pane%] - [editor-canvas% Editor-Canvas%] - [bitmap-dc% Bitmap-DC%] - [bitmap% Bitmap%] - [color% Color%] - [open-input-text-editor ((Instance Text%) Integer (U 'end Integer) (Any -> Any) Any Any -> Input-Port)]) +(require/typed/provide + scheme/gui + [button% Button%] + [event% Event%] + [the-font-list (Instance Font-List%)] + [dialog% Dialog%] + [text-field% Text-Field%] + [horizontal-panel% Horizontal-Panel%] + [choice% Choice%] + [get-face-list (-> (Listof String))] + [message% Message%] + [horizontal-pane% Horizontal-Pane%] + [editor-canvas% Editor-Canvas%] + [bitmap-dc% Bitmap-DC%] + [bitmap% Bitmap%] + [color% Color%] + [snip% Snip%] + [open-input-text-editor + ((Instance Text%) Integer (U 'end Integer) ((Instance Snip%) -> (Instance Snip%)) (Instance Text%) Boolean -> Input-Port)]) diff --git a/collects/typed/net/mime.ss b/collects/typed/net/mime.ss index 5a9b3f7bb9..8abfaddb75 100644 --- a/collects/typed/net/mime.ss +++ b/collects/typed/net/mime.ss @@ -9,7 +9,7 @@ [modification : String] [read : String] [size : Number] - [params : Any]) + [params : (Listof (Pair Symbol String))]) net/mime) (require-typed-struct entity ([type : (U Symbol String)] [subtype : (U Symbol String)] @@ -20,7 +20,7 @@ [id : String] [description : String] [other : String] - [fields : Any] + [fields : (Listof String)] [parts : (Listof String) ] [body : (Output-Port -> Void)]) net/mime) @@ -30,7 +30,7 @@ ;; -- exceptions raised -- -#| +#| ;; constructors not exported (require-typed-struct mime-error () net/mime) (require-typed-struct (unexpected-termination mime-error) ([msg : String]) net/mime) (require-typed-struct (missing-multipart-boundary-parameter mime-error) () net/mime) @@ -40,7 +40,6 @@ (require-typed-struct (empty-subtype mime-error) () net/mime) (require-typed-struct (empty-disposition-type mime-error) () net/mime) |# - ;; -- mime methods -- (require/typed/provide net/mime [mime-analyze ((U Bytes Input-Port) Any -> message)])