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]