From 63d2f3ecb2440409b48d81b92a8a466d37517e22 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 17 Mar 2009 02:14:11 +0000 Subject: [PATCH 1/9] Fix docs for HashTable. Add string->list, list->string, sort. svn: r14138 original commit: 6b5b193815bd469a2119e1227503fe446f89e8d2 --- collects/typed-scheme/private/base-env.ss | 4 ++++ collects/typed-scheme/ts-reference.scrbl | 2 ++ 2 files changed, 6 insertions(+) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index dea4afde..08cacb6c 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -538,6 +538,10 @@ [maybe-print-message (-String . -> . -Void)] +[list->string ((-lst -Char) . -> . -String)] +[string->list (-String . -> . (-lst -Char))] +[sort (-poly (a) ((-lst a) (a a . -> . B) . -> . (-lst a)))] + ;; scheme/list [last-pair (-poly (a) ((-mu x (Un a (-val '()) (-pair a x))) . -> . diff --git a/collects/typed-scheme/ts-reference.scrbl b/collects/typed-scheme/ts-reference.scrbl index 102a13e9..b1d44a0c 100644 --- a/collects/typed-scheme/ts-reference.scrbl +++ b/collects/typed-scheme/ts-reference.scrbl @@ -52,6 +52,8 @@ The following base types are parameteric in their type arguments. the first is the type the parameter accepts, and the second is the type returned.} @defform[(Pair s t)]{is the pair containing @scheme[s] as the @scheme[car] and @scheme[t] as the @scheme[cdr]} +@defform[(HashTable k v)]{is the type of a @rtech{hash table} with key type + @scheme[k] and value type @scheme[v].} @subsubsub*section{Type Constructors} From 3bcaed5d415ddea987d1360ed08cdfce35e3cb6d Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 17 Mar 2009 12:43:20 +0000 Subject: [PATCH 2/9] add new section about libraries in ts svn: r14145 original commit: fee4c1944dca20f41b0dc3217dfaf3295ee89215 --- collects/typed-scheme/ts-reference.scrbl | 51 +++++++++++++++++++++++- 1 file changed, 49 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/ts-reference.scrbl b/collects/typed-scheme/ts-reference.scrbl index b1d44a0c..c2982e25 100644 --- a/collects/typed-scheme/ts-reference.scrbl +++ b/collects/typed-scheme/ts-reference.scrbl @@ -1,7 +1,10 @@ #lang scribble/doc -@begin[(require scribble/manual) - (require (for-label typed-scheme))] +@begin[(require scribble/manual scribble/eval + scheme/sandbox) + (require (for-label typed-scheme + scheme/list srfi/14 + version/check))] @begin[ (define (item* header . args) (apply item @bold[header]{: } args)) @@ -247,3 +250,47 @@ known to Typed Scheme, either via @scheme[define-struct:] or Like @scheme[do], but each @scheme[id] having the associated type @scheme[t], and the final body @scheme[expr] having the type @scheme[u]. } + +@section{Libraries Provided With Typed Scheme} + +The @schememodname[typed-scheme] language corresponds to the +@schememodname[scheme/base] language---that is, any identifier provided +by @schememodname[scheme/base], such as @scheme[mod] is available by default in +@schememodname[typed-scheme]. + +@schememod[typed-scheme +(modulo 12 2) +] + +Any value provided by @schememodname[scheme] is available by simply +@scheme[require]ing it; use of @scheme[require/typed] is not +neccessary. + +@schememod[typed-scheme +(require scheme/list) +(display (first (list 1 2 3))) +] + +Some libraries have counterparts in the @schemeidfont{typed} +collection, which provide the same exports as the untyped versions. +Such libraries include @schememodname[srfi/14], +@schememodname[net/url], and many others. + +@schememod[typed-scheme +(require typed/srfi/14) +(char-set= (string->char-set "hello") + (string->char-set "olleh")) +] + +To participate in making more libraries available, please visit +@link["http://www.ccs.neu.edu/home/samth/adapt/"]{here}. + + +Other libraries can be used with Typed Scheme via +@scheme[require/typed]. + +@schememod[typed-scheme +(require/typed version/check + [check-version (-> (U Symbol (Listof Any)))]) +(check-version) +] From fdfa1cd04a3aa1c842adacfd725378d7176da037 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 17 Mar 2009 21:18:50 +0000 Subject: [PATCH 3/9] Allow `apply' of non-uniform polymorphic functions to fixed-length list arguments. Please backport. svn: r14162 original commit: 0ed8d251bff94224448a2d860d329a7427513a61 --- .../typed-scheme/succeed/apply-dots-list.ss | 25 +++++++++++++++++++ .../typed-scheme/typecheck/tc-app-unit.ss | 13 ++++++++++ 2 files changed, 38 insertions(+) create mode 100644 collects/tests/typed-scheme/succeed/apply-dots-list.ss diff --git a/collects/tests/typed-scheme/succeed/apply-dots-list.ss b/collects/tests/typed-scheme/succeed/apply-dots-list.ss new file mode 100644 index 00000000..d068a14e --- /dev/null +++ b/collects/tests/typed-scheme/succeed/apply-dots-list.ss @@ -0,0 +1,25 @@ + +;; Change the lang to scheme for untyped version +#lang typed-scheme + +(define tests (list (list (λ() 1) 1 "test 1") + (list (λ() 2) 2 "test 2"))) + +; Comment out the type signature when running untyped +(: check-all (All (A ...) ((List (-> A) A String) ... A -> Void))) +(define (check-all . tests) + (let aux ([tests tests] + [num-passed 0]) + (if (null? tests) + (printf "~a tests passed.~n" num-passed) + (let ((test (car tests))) + (let ((actual ((car test))) + (expected (cadr test)) + (msg (caddr test))) + (if (equal? actual expected) + (aux (cdr tests) (+ num-passed 1)) + (printf "Test failed: ~a. Expected ~a, got ~a.~n" + msg expected actual))))))) + +(apply check-all tests) ; Works in untyped, but not in typed +(check-all (car tests) (cadr tests)) ; Works in typed or untyped \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index dbe864f1..61b4f54b 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -342,6 +342,19 @@ drest-bound (subst-all (alist-delete drest-bound substitution eq?) (car rngs*)))))] + ;; ... function, (List A B C etc) arg + [(and (car drests*) + (not tail-bound) + (eq? (cdr (car drests*)) dotted-var) + (= (length (car doms*)) + (length arg-tys)) + (untuple tail-ty) + (infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*) + (car (car drests*)) (car rngs*) (fv (car rngs*)))) + => (lambda (substitution) + (define drest-bound (cdr (car drests*))) + (do-apply-log substitution 'dots 'dots) + (ret (subst-all substitution (car rngs*))))] ;; if nothing matches, around the loop again [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] [(tc-result: (PolyDots: vars (Function: '()))) From 56216d320e44366ef9ee6edce8964d026751ebaa Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 22 Mar 2009 12:41:26 +0000 Subject: [PATCH 4/9] =?UTF-8?q?Use=20'no-free-identifier=3D=3F=20property?= =?UTF-8?q?=20with=20rename=20transformers.=20Allow=20use=20of=20...=20wit?= =?UTF-8?q?hout=20bound=20when=20only=20one=20...=20var=20in=20scope.?= svn: r14214 original commit: 6d8014783b16c2d31624f8bd5f6d25d9fb10b5e2 --- .../tests/typed-scheme/succeed/no-bound-fl.ss | 11 ++++++ .../unit-tests/parse-type-tests.ss | 6 +++ .../typed-scheme/env/type-environments.ss | 14 +++++++ collects/typed-scheme/private/parse-type.ss | 37 +++++++++++++++++++ .../typecheck/provide-handling.ss | 12 ++++-- 5 files changed, 76 insertions(+), 4 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/no-bound-fl.ss diff --git a/collects/tests/typed-scheme/succeed/no-bound-fl.ss b/collects/tests/typed-scheme/succeed/no-bound-fl.ss new file mode 100644 index 00000000..1f9bd526 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/no-bound-fl.ss @@ -0,0 +1,11 @@ +#lang typed-scheme + +(: fold-left (All (a b ...) ((a b ... -> a) a (Listof b) ... -> a))) +(define (fold-left f a . bss) + (if (ormap null? bss) + a + (apply fold-left + f + (apply f a (map car bss)) + (map cdr bss)))) + diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index cfe775ea..c14f64d8 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -80,6 +80,10 @@ [(All (a ...) (a ... a -> Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))] [(∀ (a) (Listof a)) (-poly (a) (make-Listof a))] [(∀ (a ...) (a ... a -> Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))] + [(All (a ...) (a ... -> Number)) + (-polydots (a) ((list) [a a] . ->... . N))] + [(All (a ...) (values a ...)) + (-polydots (a) (make-ValuesDots (list) a 'a))] [(case-lambda (Number -> Boolean) (Number Number -> Number)) (cl-> [(N) B] [(N N) N])] [1 (-val 1)] @@ -91,6 +95,8 @@ [a (-v a) (extend-env (list 'a) (list (-v a)) initial-tvar-env)] + [(All (a ...) (a ... -> Number)) + (-polydots (a) ((list) [a a] . ->... . N))] )) diff --git a/collects/typed-scheme/env/type-environments.ss b/collects/typed-scheme/env/type-environments.ss index 0f159ec0..42eb02c9 100644 --- a/collects/typed-scheme/env/type-environments.ss +++ b/collects/typed-scheme/env/type-environments.ss @@ -8,6 +8,9 @@ extend/values dotted-env initial-tvar-env + env-filter + env-vals + env-keys+vals with-dotted-env/extend) (require (prefix-in r: "../utils/utils.ss")) @@ -17,6 +20,17 @@ ;; eq? has the type of equal?, and l is an alist (with conses!) (define-struct env (eq? l)) +(define (env-vals e) + (map cdr (env-l e))) + +(define (env-keys+vals e) + (env-l e)) + +(define (env-filter f e) + (match e + [(struct env (eq? l)) + (make-env eq? (filter f l))])) + ;; the initial type variable environment - empty ;; this is used in the parsing of types (define initial-tvar-env (make-env eq? '())) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 135384af..8cc2d1ce 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -350,6 +350,26 @@ (current-tvars))]) (parse-type #'rest)) (syntax-e #'bound)))))))] + [(dom ... rest ::: -> rng) + (and (eq? (syntax-e #'->) '->) + (eq? (syntax-e #':::) '...)) + (begin + (add-type-name-reference #'->) + (let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))]) + (when (null? bounds) + (tc-error/stx stx "No type variable bound with ... in scope for ... type")) + (unless (null? (cdr bounds)) + (tc-error/stx stx "Cannot infer bound for ... type")) + (match-let ([(cons var (struct Dotted (t))) (car bounds)]) + (make-Function + (list + (make-arr-dots (map parse-type (syntax->list #'(dom ...))) + (parse-type #'rng) + (parameterize ([current-tvars (extend-env (list var) + (list (make-DottedBoth t)) + (current-tvars))]) + (parse-type #'rest)) + var))))))] ;; has to be below the previous one [(dom ... -> rng) (eq? (syntax-e #'->) '->) @@ -369,6 +389,23 @@ (current-tvars))]) (parse-type #'dty)) (syntax-e #'bound))))] + [(values tys ... dty dd) + (and (eq? (syntax-e #'values) 'values) + (eq? (syntax-e #'dd) '...)) + (begin + (add-type-name-reference #'values) + (let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))]) + (when (null? bounds) + (tc-error/stx stx "No type variable bound with ... in scope for ... type")) + (unless (null? (cdr bounds)) + (tc-error/stx stx "Cannot infer bound for ... type")) + (match-let ([(cons var (struct Dotted (t))) (car bounds)]) + (make-ValuesDots (map parse-type (syntax->list #'(tys ...))) + (parameterize ([current-tvars (extend-env (list var) + (list (make-DottedBoth t)) + (current-tvars))]) + (parse-type #'dty)) + var))))] [(values tys ...) (eq? (syntax-e #'values) 'values) (-values (map parse-type (syntax->list #'(tys ...))))] diff --git a/collects/typed-scheme/typecheck/provide-handling.ss b/collects/typed-scheme/typecheck/provide-handling.ss index 791d6384..66b3576a 100644 --- a/collects/typed-scheme/typecheck/provide-handling.ss +++ b/collects/typed-scheme/typecheck/provide-handling.ss @@ -54,15 +54,18 @@ (define/contract cnt-id #,cnt id) (define-syntax export-id (if (unbox typed-context?) - (make-rename-transformer #'id) - (make-rename-transformer #'cnt-id))) + (make-rename-transformer (syntax-property #'id + 'not-free-identifier=? #t)) + (make-rename-transformer (syntax-property #'cnt-id + 'not-free-identifier=? #t)))) (#%provide (rename export-id out-id)))))] [else (with-syntax ([(export-id) (generate-temporaries #'(id))]) #`(begin (define-syntax export-id (if (unbox typed-context?) - (make-rename-transformer #'id) + (make-rename-transformer (syntax-property #'id + 'not-free-identifier=? #t)) (lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))))) (provide (rename-out [export-id out-id]))))])))] [(mem? internal-id stx-defs) @@ -76,7 +79,8 @@ (if (unbox typed-context?) (begin (add-alias #'export-id #'id) - (make-rename-transformer #'id)) + (make-rename-transformer (syntax-property #'id + 'not-free-identifier=? #t))) (lambda (stx) (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id))))) (provide (rename-out [export-id out-id]))))))] From 2e7fb8105f21051630283e79178597fb4d8319c1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 23 Mar 2009 12:02:46 +0000 Subject: [PATCH 5/9] improve types for foldl, foldr svn: r14228 original commit: bb2268b9be8243a7e928df4e83ef6bc19a68a213 --- collects/typed-scheme/private/base-env.ss | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 08cacb6c..7f3ee7e5 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -101,10 +101,14 @@ [fold-right (-polydots (c a b) ((list ((list c a) (b b) . ->... . c) c (-lst a)) ((-lst b) b) . ->... . c))] [foldl - (-poly (a b c) + (-poly (a b c d) (cl-> [((a b . -> . b) b (-lst a)) b] - [((a b c . -> . c) c (-lst a) (-lst b)) c]))] -[foldr (-poly (a b c) ((a b . -> . b) b (-lst a) . -> . b))] + [((a b c . -> . c) c (-lst a) (-lst b)) c] + [((a b c d . -> . d) d (-lst a) (-lst b) (-lst d)) d]))] +[foldr (-poly (a b c d) + (cl-> [((a b . -> . b) b (-lst a)) b] + [((a b c . -> . c) c (-lst a) (-lst b)) c] + [((a b c d . -> . d) d (-lst a) (-lst b) (-lst d)) d]))] [filter (-poly (a b) (cl->* ((a . -> . B : From 31acd517ab31684a9d878a38f6f8fec6e3e6b7e0 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 23 Mar 2009 15:34:34 +0000 Subject: [PATCH 6/9] Typed wrapper for file/tar contributed by YC. svn: r14233 original commit: 746446d4ac5f05a8876859a6a1de26541d654e5c --- collects/typed/file/tar.ss | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 collects/typed/file/tar.ss diff --git a/collects/typed/file/tar.ss b/collects/typed/file/tar.ss new file mode 100644 index 00000000..625a45a8 --- /dev/null +++ b/collects/typed/file/tar.ss @@ -0,0 +1,22 @@ +#lang typed-scheme +;; typed-scheme wrapper on file/tar +;; yc 2009/2/25 + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; basic type aliases. +(define-type-alias Path-String (U Path String)) + +(require/typed file/tar + ;; tar appears to return exact-nonenegative-integer? instead of void? + [tar (Path-String Path-String * -> Integer)] + ;; tar->output appears to take (listof path) instead of (listof path-string?) + ;; it also appears to return exact-nonenegative-integer? + [tar->output (case-lambda ((Listof Path) -> Integer) + ((Listof Path) Output-Port -> Integer))] + ;; tar->gzip + ;; missing from file/tar but available in mzlib/tar + ;; actually returns void? + [tar-gzip (Path-String Path-String * -> Void)] + ) + +(provide tar tar->output tar-gzip) \ No newline at end of file From bb80c7809e24ee819f8d80f83106c8b73c5d0e16 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 23 Mar 2009 17:25:57 +0000 Subject: [PATCH 7/9] Types for `scheme/path', from Harsha. svn: r14240 original commit: 6108dc873cb9c07a86f64fb20ef6b5f89f3c79ab --- collects/typed-scheme/private/base-env.ss | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 7f3ee7e5..4579ee34 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -576,3 +576,18 @@ [real->decimal-string (N [-Nat] . ->opt . -String)] [current-continuation-marks (-> -Cont-Mark-Set)] + +;; path.ss + +[explode-path (-Pathlike . -> . (-lst (Un -Path (-val 'up) (-val 'same))))] +[find-relative-path (-Pathlike -Pathlike . -> . -Path)] +[simple-form-path (-Pathlike . -> . -Path)] +[normalize-path (cl->* (-Pathlike . -> . -Path) + (-Pathlike -Pathlike . -> . -Path))] +[filename-extension (-Pathlike . -> . (-opt -Bytes))] +[file-name-from-path (-Pathlike . -> . (-opt -Path))] +[path-only (-Pathlike . -> . -Path)] +[some-system-path->string (-Path . -> . -String)] +[string->some-system-path + (-String (Un (-val 'unix) (-val 'windows)) . -> . -Path)] + From 8fa0ec60799cb136d17f4230a22c01062b8c6b14 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 23 Mar 2009 18:29:07 +0000 Subject: [PATCH 8/9] First step to polymorphic functions in typed/untyped interface - poly/c contract from Carl/Stevie - generate the contracts - test - use in typed/srfi/14 svn: r14241 original commit: 60e096913d18554592f4dd6e024d3f58cc94b88e --- .../tests/typed-scheme/fail/bad-map-poly.ss | 15 +++++++++ collects/typed-scheme/utils/utils.ss | 1 + collects/typed/srfi/14.ss | 33 ++++++++++--------- 3 files changed, 33 insertions(+), 16 deletions(-) create mode 100644 collects/tests/typed-scheme/fail/bad-map-poly.ss diff --git a/collects/tests/typed-scheme/fail/bad-map-poly.ss b/collects/tests/typed-scheme/fail/bad-map-poly.ss new file mode 100644 index 00000000..280bd9bc --- /dev/null +++ b/collects/tests/typed-scheme/fail/bad-map-poly.ss @@ -0,0 +1,15 @@ +#; +(exn-pred exn:fail:contract? ".*interface for bad-map.*") +#lang scheme/load + +(module bad-map scheme + (provide bad-map) + (define (bad-map f l) + (list (f 'quux)))) + +(module use-bad-map typed-scheme + (require/typed 'bad-map + [bad-map (All (A B) ((A -> B) (Listof A) -> (Listof B)))]) + (bad-map add1 (list 12 13 14))) + +(require 'use-bad-map) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 485bc20b..d90e27ee 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -19,6 +19,7 @@ extend debug in-syntax + symbol-append ;; require macros rep utils typecheck infer env private) diff --git a/collects/typed/srfi/14.ss b/collects/typed/srfi/14.ss index 48670078..4c656e91 100644 --- a/collects/typed/srfi/14.ss +++ b/collects/typed/srfi/14.ss @@ -91,23 +91,28 @@ [char-set:ascii Char-Set] [char-set:empty Char-Set] [char-set:full Char-Set] + [char-set-fold (All (A) ((Char A -> A) A Char-Set -> A))] + [char-set-unfold + (All (A) + (case-lambda + ((A -> Any) (A -> Char) (A -> A) A -> Char-Set) + ((A -> Any) (A -> Char) (A -> A) A Char-Set -> Char-Set)))] + [char-set-unfold! + (All (A) ((A -> Any) (A -> Char) (A -> A) A Char-Set -> Char-Set))] + [char-set-for-each (All (A) ((Char -> A) Char-Set -> (U A Void)))] + [char-set-any (All (A) ((Char -> A) Char-Set -> (U A #f)))] + [char-set-every (All (A) ((Char -> A) Char-Set -> (U A Boolean)))] ) ; end of require/typed ;; Definitions provided here for polymorphism - -(: char-set-fold (All (A) ((Char A -> A) A Char-Set -> A))) +#; (define (char-set-fold comb base cs) (let loop ((c (char-set-cursor cs)) (b base)) (cond [(end-of-char-set? c) b] [else (loop (char-set-cursor-next cs c) (comb (char-set-ref cs c) b))]))) - -(: char-set-unfold - (All (A) - (case-lambda - ((A -> Any) (A -> Char) (A -> A) A -> Char-Set) - ((A -> Any) (A -> Char) (A -> A) A Char-Set -> Char-Set)))) +#; (define char-set-unfold (pcase-lambda: (A) [([p : (A -> Any)] [f : (A -> Char)] [g : (A -> A)] [seed : A]) @@ -115,29 +120,25 @@ [([p : (A -> Any)] [f : (A -> Char)] [g : (A -> A)] [seed : A] [base-cs : Char-Set]) (char-set-unfold! p f g seed (char-set-copy base-cs))])) - -(: char-set-unfold! - (All (A) ((A -> Any) (A -> Char) (A -> A) A Char-Set -> Char-Set))) +#; (define (char-set-unfold! p f g seed base-cs) (let lp ((seed seed) (cs base-cs)) (if (p seed) cs ; P says we are done. (lp (g seed) ; Loop on (G SEED). (char-set-adjoin! cs (f seed)))))) -(: char-set-for-each (All (A) ((Char -> A) Char-Set -> (U A Void)))) +#; (define (char-set-for-each f cs) (char-set-fold (lambda: ([c : Char] [b : (U A Void)]) (f c)) (void) cs)) - -(: char-set-any (All (A) ((Char -> A) Char-Set -> (U A #f)))) +#; (define (char-set-any pred cs) (let loop ((c (char-set-cursor cs))) (and (not (end-of-char-set? c)) (or (pred (char-set-ref cs c)) (loop (char-set-cursor-next cs c)))))) - -(: char-set-every (All (A) ((Char -> A) Char-Set -> (U A Boolean)))) +#; (define (char-set-every pred cs) (let loop ((c (char-set-cursor cs)) (b (ann #t (U #t A)))) (cond [(end-of-char-set? c) b] From 23a33e158ccb0ff2b65b77610994a52a3d9d26a1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 24 Mar 2009 17:49:15 +0000 Subject: [PATCH 9/9] Add fake type name -Real Add `scheme/math' types from Jos Koot. svn: r14251 original commit: 43443652b8d4c0b73ec950c3ead818c262ddf0bb --- collects/typed-scheme/private/base-env.ss | 12 +++++++++++- collects/typed-scheme/private/type-abbrev.ss | 2 ++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 4579ee34..f314d272 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -577,7 +577,7 @@ [current-continuation-marks (-> -Cont-Mark-Set)] -;; path.ss +;; scheme/path [explode-path (-Pathlike . -> . (-lst (Un -Path (-val 'up) (-val 'same))))] [find-relative-path (-Pathlike -Pathlike . -> . -Path)] @@ -591,3 +591,13 @@ [string->some-system-path (-String (Un (-val 'unix) (-val 'windows)) . -> . -Path)] +;; scheme/math + +[sgn (-Real . -> . -Real)] +[pi N] +[sqr (N . -> . N)] +[sgn (N . -> . N)] +[conjugate (N . -> . N)] +[sinh (N . -> . N)] +[cosh (N . -> . N)] +[tanh (N . -> . N)] \ No newline at end of file diff --git a/collects/typed-scheme/private/type-abbrev.ss b/collects/typed-scheme/private/type-abbrev.ss index 35de27f4..ea415730 100644 --- a/collects/typed-scheme/private/type-abbrev.ss +++ b/collects/typed-scheme/private/type-abbrev.ss @@ -204,6 +204,8 @@ (define -Pattern (*Un -String -Bytes -Regexp -Byte-Regexp -PRegexp -Byte-PRegexp)) (define -Byte N) +(define -Real N) + (define (-Tuple l) (foldr -pair (-val '()) l))