From 04a87a60b5d236b205642c06b8ea18d1038b2716 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 3 Mar 2009 02:09:33 +0000 Subject: [PATCH 1/2] Typed version of SRFI 14, from David Van Horn. svn: r13905 original commit: 2b0e89ee2ae1359f4088aa1d768c90eea5d61da2 --- collects/typed/srfi/14.ss | 224 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 224 insertions(+) create mode 100644 collects/typed/srfi/14.ss diff --git a/collects/typed/srfi/14.ss b/collects/typed/srfi/14.ss new file mode 100644 index 00000000..48670078 --- /dev/null +++ b/collects/typed/srfi/14.ss @@ -0,0 +1,224 @@ +#lang typed-scheme +(require/opaque-type Char-Set char-set? srfi/14) + +(define-type-alias Cursor (Pair 0 (Listof (Pair Integer Integer)))) + +(require/typed + srfi/14 + ;; Predicates & comparison + [char-set= (Char-Set * -> Boolean)] + [char-set<= (Char-Set * -> Boolean)] + [char-set-hash + (case-lambda (Char-Set -> Integer) + (Char-Set Integer -> Integer))] + + ;; Iterating over character sets + [char-set-cursor (Char-Set -> Cursor)] + [char-set-ref (Char-Set Cursor -> Char)] + [char-set-cursor-next (Char-Set Cursor -> Cursor)] + [end-of-char-set? (Cursor -> Boolean)] + [char-set-map ((Char -> Char) Char-Set -> Char-Set)] + + ;; Creating character sets + [char-set-copy (Char-Set -> Char-Set)] + [char-set (Char * -> Char-Set)] + [list->char-set + (case-lambda + ((Listof Char) -> Char-Set) + ((Listof Char) Char-Set -> Char-Set))] + [list->char-set! ((Listof Char) Char-Set -> Char-Set)] + [string->char-set + (case-lambda + (String -> Char-Set) + (String Char-Set -> Char-Set))] + [string->char-set! (String Char-Set -> Char-Set)] + [char-set-filter + (case-lambda + ((Char -> Any) Char-Set -> Char-Set) + ((Char -> Any) Char-Set Char-Set -> Char-Set))] + [char-set-filter! + ((Char -> Any) Char-Set Char-Set -> Char-Set)] + [ucs-range->char-set + (case-lambda (Integer Integer -> Char-Set) + (Integer Integer Any -> Char-Set) + (Integer Integer Any Char-Set -> Char-Set))] + [ucs-range->char-set! + (Integer Integer Any Char-Set -> Char-Set)] + [->char-set ((U String Char Char-Set) -> Char-Set)] + + ;; Querying character sets + [char-set-size (Char-Set -> Integer)] + [char-set-count ((Char -> Any) Char-Set -> Integer)] + [char-set->list (Char-Set -> (Listof Char))] + [char-set->string (Char-Set -> String)] + [char-set-contains? (Char-Set Char -> Boolean)] + + ;; Character-set algebra + [char-set-adjoin (Char-Set Char * -> Char-Set)] + [char-set-delete (Char-Set Char * -> Char-Set)] + [char-set-adjoin! (Char-Set Char * -> Char-Set)] + [char-set-delete! (Char-Set Char * -> Char-Set)] + [char-set-complement (Char-Set -> Char-Set)] + [char-set-union (Char-Set * -> Char-Set)] + [char-set-intersection (Char-Set * -> Char-Set)] + [char-set-difference (Char-Set Char-Set * -> Char-Set)] + [char-set-xor (Char-Set * -> Char-Set)] + [char-set-diff+intersection + (Char-Set Char-Set * -> (values Char-Set Char-Set))] + [char-set-complement! (Char-Set -> Char-Set)] + [char-set-union! (Char-Set Char-Set * -> Char-Set)] + [char-set-intersection! (Char-Set Char-Set * -> Char-Set)] + [char-set-difference! (Char-Set Char-Set * -> Char-Set)] + [char-set-xor! (Char-Set Char-Set * -> Char-Set)] + [char-set-diff+intersection! + (Char-Set Char-Set Char-Set * -> (values Char-Set Char-Set))] + + ;; Standard character sets + [char-set:lower-case Char-Set] + [char-set:upper-case Char-Set] + [char-set:title-case Char-Set] + [char-set:letter Char-Set] + [char-set:digit Char-Set] + [char-set:letter+digit Char-Set] + [char-set:graphic Char-Set] + [char-set:printing Char-Set] + [char-set:whitespace Char-Set] + [char-set:iso-control Char-Set] + [char-set:punctuation Char-Set] + [char-set:symbol Char-Set] + [char-set:hex-digit Char-Set] + [char-set:blank Char-Set] + [char-set:ascii Char-Set] + [char-set:empty Char-Set] + [char-set:full Char-Set] + ) ; 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]) + (char-set-unfold p f g seed char-set:empty)] + [([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] + [else (and b + (loop (char-set-cursor-next cs c) + (pred (char-set-ref cs c))))]))) + +(provide + ;; Predicates & comparison + char-set? + char-set= + char-set<= + char-set-hash + + ;; Iterating over character sets + char-set-cursor + char-set-ref + char-set-cursor-next + end-of-char-set? + char-set-fold + char-set-unfold + char-set-unfold! + char-set-for-each + char-set-map + + ;; Creating character sets + char-set-copy + char-set + list->char-set + list->char-set! + string->char-set + string->char-set! + char-set-filter + char-set-filter! + ucs-range->char-set + ucs-range->char-set! + ->char-set + + ;; Querying character sets + char-set-size + char-set-count + char-set->list + char-set->string + char-set-contains? + char-set-every + char-set-any + + ;; Character-set algebra + char-set-adjoin + char-set-delete + char-set-adjoin! + char-set-delete! + char-set-complement + char-set-union + char-set-intersection + char-set-difference + char-set-xor + char-set-diff+intersection + char-set-complement! + char-set-union! + char-set-intersection! + char-set-difference! + char-set-xor! + char-set-diff+intersection! + + ;; Standard character sets + char-set:lower-case + char-set:upper-case + char-set:title-case + char-set:letter + char-set:digit + char-set:letter+digit + char-set:graphic + char-set:printing + char-set:whitespace + char-set:iso-control + char-set:punctuation + char-set:symbol + char-set:hex-digit + char-set:blank + char-set:ascii + char-set:empty + char-set:full + ) ; end of provide From 593d7cf24c2e526ce4ab78d2d80e8bdd6e9cb0da Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 3 Mar 2009 20:01:41 +0000 Subject: [PATCH 2/2] Typed wrapper for md5.ss from YC. svn: r13921 original commit: 089ebfe49203fe8aa55571a773e659eca1a078a4 --- collects/typed/file/md5.ss | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 collects/typed/file/md5.ss diff --git a/collects/typed/file/md5.ss b/collects/typed/file/md5.ss new file mode 100644 index 00000000..0cab46d7 --- /dev/null +++ b/collects/typed/file/md5.ss @@ -0,0 +1,4 @@ +#lang typed-scheme +(require/typed file/md5 + [md5 ((U Bytes Input-Port) -> Bytes)]) +(provide md5)