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

New true-filter and false-filter abbrevs

Browse Source 
Fix for Stevie's d-s/c fix.
tc-expr now compiles

svn: r14007

original commit: 18e03efc840e0df5dec1a6333a0d6ba42fc10bb1
This commit is contained in:
Sam Tobin-Hochstadt 2009-03-07 22:51:54 +00:00
commit fc229e12cb
5 changed files with 259 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/typed-scheme/typecheck/tc-expr-unit.ss
View File

@ -1,14 +1,14 @@
#lang scheme/unit
(require (rename-in "../utils/utils.ss" [private r:private]))
(require (rename-in "../utils/utils.ss" [private private-in]))
(require syntax/kerncase
scheme/match
"signatures.ss"
(r:private type-utils type-effect-convenience union subtype
parse-type type-annotation stxclass-util)
(rep type-rep effect-rep)
(utils tc-utils)
(types utils convenience union subtype)
(private-in parse-type type-annotation)
(rep type-rep)
(utils tc-utils stxclass-util)
(env lexical-env)
(only-in (env type-environments) lookup current-tvars extend-env)
scheme/private/class-internal
@ -23,12 +23,18 @@
;; return the type of a literal value
;; scheme-value -> type
(define (tc-literal v-stx)
(define (tc-literal v-stx [expected #f])
(define-syntax-class exp
(pattern i
#:when expected
#:with datum (syntax-e #'i)
#:when (subtype (-val #'datum) expected)))
(syntax-parse v-stx
[i:exp expected]
[i:boolean (-val #'i.datum)]
[i:identifier (-val #'i.datum)]
[i:exact-integer -Integer]
[i:number N]
[i:number -Number]
[i:str -String]
[i:char -Char]
[i:keyword (-val #'i.datum)]
@ -99,12 +105,15 @@
;; tc-id : identifier -> tc-result
(define (tc-id id)
(let* ([ty (lookup-type/lexical id)])
(ret ty (list (make-Var-True-Effect id)) (list (make-Var-False-Effect id)))))
(ret ty
(make-LFilterSet (list (make-NotTypeFilter (-val #f) null id))
(list (make-TypeFilter (-val #f) null id)))
(make-Path null id))))
;; typecheck an expression, but throw away the effect
;; tc-expr/t : Expr -> Type
(define (tc-expr/t e) (match (tc-expr e)
[(tc-result: t) t]
[(tc-result: t _ _) t]
[t (int-err "tc-expr returned ~a, not a tc-result, for ~a" t (syntax->datum e))]))
(define (tc-expr/check/t e t)
@ -148,9 +157,9 @@
(int-err "internal error: ignore-some"))
(check-below ty expected))]
;; data
[(quote #f) (ret (-val #f) (list (make-False-Effect)) (list (make-False-Effect)))]
[(quote #t) (ret (-val #t) (list (make-True-Effect)) (list (make-True-Effect)))]
[(quote val) (ret (tc-literal #'val))]
[(quote #f) (ret (-val #f) false-filter)]
[(quote #t) (ret (-val #t) true-filter)]
[(quote val) (ret (tc-literal #'val expected))]
;; syntax
[(quote-syntax datum) (ret (-Syntax (tc-literal #'datum)))]
;; mutation!
@ -232,8 +241,8 @@
ty)]
;; data
[(quote #f) (ret (-val #f) (list (make-False-Effect)) (list (make-False-Effect)))]
[(quote #t) (ret (-val #t) (list (make-True-Effect)) (list (make-True-Effect)))]
[(quote #f) (ret (-val #f) false-filter)]
[(quote #t) (ret (-val #t) true-filter)]
[(quote val) (ret (tc-literal #'val))]
;; syntax

4
collects/typed-scheme/types/abbrev.ss
View File

@ -24,6 +24,7 @@
(define -box make-Box)
(define -vec make-Vector)
(define -LFS make-LFilterSet)
(define -FS make-FilterSet)
(define-syntax *Un
(syntax-rules ()
@ -251,6 +252,9 @@
(->* in out : (-LFS (list (-filter t)) (list (-not-filter t))))]
[(t) (make-pred-ty (list Univ) -Boolean t)]))
(define true-filter (-FS (list) (list (make-Bot))))
(define false-filter (-FS (list (make-Bot)) (list)))
(define (opt-fn args opt-args result)
(apply cl->* (for/list ([i (in-range (add1 (length opt-args)))])

7
collects/typed-scheme/types/utils.ss
View File

@ -167,15 +167,16 @@
;; this structure represents the result of typechecking an expression
(d-s/c tc-result ([t Type/c] [f FilterSet?] [o Object?]) #:transparent)
(define-struct tc-result (t f o) #:transparent #:omit-define-values)
(define-match-expander tc-result:
(syntax-parser
[(_ tp fp op) #'(struct tc-result (tp fp op))]))
[(_ tp fp op) #'(struct tc-result (tp fp op))]
[(_ tp) #'(struct tc-result (tp _ _))]))
(define-match-expander tc-results:
(syntax-parser
[(_ tp fp op) #'(list (struct tc-result (tp fp op)) (... ...))]))
[(_ tp fp op) #'(list (struct tc-result (tp fp op)) (... ...))]
[(_ tp) #'(list (struct tc-result (tp _ _)) (... ...))]))
(provide tc-result: tc-results:)

4
collects/typed/file/md5.ss Normal file
View File

@ -0,0 +1,4 @@
#lang typed-scheme
(require/typed file/md5
[md5 ((U Bytes Input-Port) -> Bytes)])
(provide md5)

224
collects/typed/srfi/14.ss Normal file
View File

@ -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