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

Break long lines.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-08-03 17:38:41 -04:00
parent b124d68f40
commit 5d4e5ed393
2 changed files with 135 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

155
collects/typed-scheme/typecheck/tc-funapp.rkt
View File

@ -5,14 +5,16 @@
"tc-app-helper.rkt" "find-annotation.rkt" "tc-app-helper.rkt" "find-annotation.rkt"
(prefix-in c: racket/contract) (prefix-in c: racket/contract)
syntax/parse racket/match racket/list syntax/parse racket/match racket/list
;; fixme - don't need to be bound in this phase - only to make syntax/parse happy ;; fixme - don't need to be bound in this phase - only to make
;; syntax/parse happy
racket/bool racket/unsafe/ops racket/bool racket/unsafe/ops
(only-in racket/private/class-internal make-object do-make-object) (only-in racket/private/class-internal make-object do-make-object)
(only-in '#%kernel [apply k:apply]) (only-in '#%kernel [apply k:apply])
;; end fixme ;; end fixme
(for-syntax syntax/parse racket/base (utils tc-utils)) (for-syntax syntax/parse racket/base (utils tc-utils))
(private type-annotation) (private type-annotation)
(types utils abbrev union subtype resolve convenience type-table substitute) (types utils abbrev union subtype resolve convenience type-table
substitute)
(utils tc-utils) (utils tc-utils)
(except-in (env type-env-structs tvar-env index-env) extend) (except-in (env type-env-structs tvar-env index-env) extend)
(rep type-rep filter-rep rep-utils) (rep type-rep filter-rep rep-utils)
@ -35,84 +37,112 @@
#:when (pred vars ... a)) #:when (pred vars ... a))
(let ([substitution (infer vars ... a)]) (let ([substitution (infer vars ... a)])
(and substitution (and substitution
(tc/funapp1 f-stx args-stx (subst-all substitution a) argtys expected #:check #f)))) (tc/funapp1 f-stx args-stx (subst-all substitution a)
(poly-fail f-stx args-stx t argtys #:name (and (identifier? f-stx) f-stx) #:expected expected))))])) argtys expected #:check #f))))
(poly-fail f-stx args-stx t argtys
#:name (and (identifier? f-stx) f-stx)
#:expected expected))))]))
(define/cond-contract (tc/funapp f-stx args-stx ftype0 argtys expected) (define/cond-contract (tc/funapp f-stx args-stx ftype0 argtys expected)
(syntax? (c:and/c syntax? syntax->list) tc-results? (c:listof tc-results?) (c:or/c #f tc-results?) . c:-> . tc-results?) (syntax? (c:and/c syntax? syntax->list) tc-results? (c:listof tc-results?)
(c:or/c #f tc-results?)
. c:-> . tc-results?)
(match* (ftype0 argtys) (match* (ftype0 argtys)
;; we special-case this (no case-lambda) for improved error messages ;; we special-case this (no case-lambda) for improved error messages
[((tc-result1: (and t (Function: (list (and a (arr: dom (Values: _) rest #f kws)))))) argtys) [((tc-result1: (and t (Function: (list (and a (arr: dom (Values: _)
rest #f kws))))))
argtys)
(tc/funapp1 f-stx args-stx a argtys expected)] (tc/funapp1 f-stx args-stx a argtys expected)]
[((tc-result1: (and t (Function: (and arrs (list (arr: doms rngs rests (and drests #f) kws) ...))))) [((tc-result1: (and t (Function: (and arrs (list (arr: doms rngs rests
(and drests #f) kws)
...)))))
(and argtys (list (tc-result1: argtys-t) ...))) (and argtys (list (tc-result1: argtys-t) ...)))
(or (or
;; find the first function where the argument types match ;; find the first function where the argument types match
(for/first ([dom doms] [rng rngs] [rest rests] [a arrs] (for/first ([dom doms] [rng rngs] [rest rests] [a arrs]
#:when (subtypes/varargs argtys-t dom rest)) #:when (subtypes/varargs argtys-t dom rest))
;; then typecheck here ;; then typecheck here
;; we call the separate function so that we get the appropriate filters/objects ;; we call the separate function so that we get the appropriate
;; filters/objects
(tc/funapp1 f-stx args-stx a argtys expected #:check #f)) (tc/funapp1 f-stx args-stx a argtys expected #:check #f))
;; if nothing matched, error ;; if nothing matched, error
(domain-mismatches f-stx args-stx t doms rests drests rngs argtys #f #f (domain-mismatches
#:expected expected #:return (or expected (ret (Un))) f-stx args-stx t doms rests drests rngs argtys #f #f
#:msg-thunk (lambda (dom) #:expected expected #:return (or expected (ret (Un)))
(string-append "No function domains matched in function application:\n" #:msg-thunk (lambda (dom)
dom))))] (string-append
"No function domains matched in function application:\n"
dom))))]
;; any kind of dotted polymorphic function without mandatory keyword args ;; any kind of dotted polymorphic function without mandatory keyword args
[((tc-result1: (and t (PolyDots:
(and vars (list fixed-vars ... dotted-var))
(Function: (list (and arrs (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...))) ...)))))
(list (tc-result1: argtys-t) ...))
(handle-clauses (doms rngs rests drests arrs) f-stx args-stx
;; only try inference if the argument lengths are appropriate
(lambda (dom _ rest drest a)
(cond [rest (<= (length dom) (length argtys))]
[drest (and (<= (length dom) (length argtys))
(eq? dotted-var (cdr drest)))]
[else (= (length dom) (length argtys))]))
;; only try to infer the free vars of the rng (which includes the vars in filters/objects)
;; note that we have to use argtys-t here, since argtys is a list of tc-results
(lambda (dom rng rest drest a)
(cond
[drest
(infer/dots fixed-vars dotted-var argtys-t dom (car drest) rng (fv rng)
#:expected (and expected (tc-results->values expected)))]
[rest
(infer/vararg fixed-vars (list dotted-var) argtys-t dom rest rng
(and expected (tc-results->values expected)))]
;; no rest or drest
[else (infer fixed-vars (list dotted-var) argtys-t dom rng
(and expected (tc-results->values expected)))]))
t argtys expected)]
;; regular polymorphic functions without dotted rest, and without mandatory keyword args
[((tc-result1: [((tc-result1:
(and t (and t (PolyDots:
(Poly: (and vars (list fixed-vars ... dotted-var))
vars (Function: (list (and arrs (arr: doms rngs rests drests
(Function: (list (and arrs (arr: doms rngs rests (and drests #f) (list (Keyword: _ _ #f) ...))) ...))))) (list (Keyword: _ _ #f) ...)))
...)))))
(list (tc-result1: argtys-t) ...)) (list (tc-result1: argtys-t) ...))
(handle-clauses (doms rngs rests arrs) f-stx args-stx (handle-clauses
;; only try inference if the argument lengths are appropriate (doms rngs rests drests arrs) f-stx args-stx
(λ (dom _ rest a) ((if rest <= =) (length dom) (length argtys))) ;; only try inference if the argument lengths are appropriate
;; only try to infer the free vars of the rng (which includes the vars in filters/objects) (lambda (dom _ rest drest a)
;; note that we have to use argtys-t here, since argtys is a list of tc-results (cond [rest (<= (length dom) (length argtys))]
(λ (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (and expected (tc-results->values expected)))) [drest (and (<= (length dom) (length argtys))
t argtys expected)] (eq? dotted-var (cdr drest)))]
[else (= (length dom) (length argtys))]))
;; Only try to infer the free vars of the rng (which includes the vars
;; in filters/objects). Note that we have to use argtys-t here, since
;; argtys is a list of tc-results.
(λ (dom rng rest drest a)
(cond
[drest
(infer/dots
fixed-vars dotted-var argtys-t dom (car drest) rng (fv rng)
#:expected (and expected (tc-results->values expected)))]
[rest
(infer/vararg fixed-vars (list dotted-var) argtys-t dom rest rng
(and expected (tc-results->values expected)))]
;; no rest or drest
[else (infer fixed-vars (list dotted-var) argtys-t dom rng
(and expected (tc-results->values expected)))]))
t argtys expected)]
;; regular polymorphic functions without dotted rest, and without mandatory
;; keyword args
[((tc-result1:
(and t (Poly:
vars
(Function: (list (and arrs (arr: doms rngs rests (and drests #f)
(list (Keyword: _ _ #f) ...)))
...)))))
(list (tc-result1: argtys-t) ...))
(handle-clauses
(doms rngs rests arrs) f-stx args-stx
;; only try inference if the argument lengths are appropriate
(λ (dom _ rest a) ((if rest <= =) (length dom) (length argtys)))
;; Only try to infer the free vars of the rng (which includes the vars
;; in filters/objects). Note that we have to use argtys-t here, since
;; argtys is a list of tc-results.
(λ (dom rng rest a)
(infer/vararg vars null argtys-t dom rest rng
(and expected (tc-results->values expected))))
t argtys expected)]
;; procedural structs ;; procedural structs
[((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _))) _) [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _))) _)
(tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) (ret proc-ty) (cons ftype0 argtys) expected)] (tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) (ret proc-ty)
(cons ftype0 argtys) expected)]
;; parameters are functions too ;; parameters are functions too
[((tc-result1: (Param: in out)) (list)) (ret out)] [((tc-result1: (Param: in out)) (list)) (ret out)]
[((tc-result1: (Param: in out)) (list (tc-result1: t))) [((tc-result1: (Param: in out)) (list (tc-result1: t)))
(if (subtype t in) (if (subtype t in)
(ret -Void true-filter) (ret -Void true-filter)
(tc-error/expr #:return (ret -Void true-filter) (tc-error/expr
"Wrong argument to parameter - expected ~a and got ~a" in t))] #:return (ret -Void true-filter)
"Wrong argument to parameter - expected ~a and got ~a"
in t))]
[((tc-result1: (Param: _ _)) _) [((tc-result1: (Param: _ _)) _)
(tc-error/expr #:return (ret (Un)) (tc-error/expr
"Wrong number of arguments to parameter - expected 0 or 1, got ~a" #:return (ret (Un))
(length argtys))] "Wrong number of arguments to parameter - expected 0 or 1, got ~a"
(length argtys))]
;; resolve names, polymorphic apps, mu, etc ;; resolve names, polymorphic apps, mu, etc
[((tc-result1: (? needs-resolving? t) f o) _) [((tc-result1: (? needs-resolving? t) f o) _)
(tc/funapp f-stx args-stx (ret (resolve-once t) f o) argtys expected)] (tc/funapp f-stx args-stx (ret (resolve-once t) f o) argtys expected)]
@ -125,8 +155,13 @@
[((tc-result1: (Error:)) _) (ret (make-Error))] [((tc-result1: (Error:)) _) (ret (make-Error))]
;; otherwise fail ;; otherwise fail
[((tc-result1: (and f-ty (Poly: ns (Function: arrs)))) _) [((tc-result1: (and f-ty (Poly: ns (Function: arrs)))) _)
(tc-error/expr #:return (ret (Un)) (tc-error/expr
"Cannot infer type instantiation for type ~a. Please add more type annotations" f-ty)] #:return (ret (Un))
(string-append "Cannot infer type instantiation for type ~a. Please add "
"more type annotations")
f-ty)]
[((tc-result1: f-ty) _) [((tc-result1: f-ty) _)
(tc-error/expr #:return (ret (Un)) (tc-error/expr
"Cannot apply expression of type ~a, since it is not a function type" f-ty)])) #:return (ret (Un))
"Cannot apply expression of type ~a, since it is not a function type"
f-ty)]))

61
collects/typed-scheme/types/printer.rkt
View File

@ -1,10 +1,12 @@
#lang scheme/base #lang scheme/base
(require unstable/sequence racket/require racket/match racket/list (prefix-in s: srfi/1) (require racket/require racket/match racket/list racket/string
racket/string unstable/sequence
(path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.rkt" "rep/rep-utils.rkt" (prefix-in s: srfi/1)
"types/abbrev.rkt" "types/numeric-tower.rkt" "types/subtype.rkt" (path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.rkt"
"utils/utils.rkt" "utils/tc-utils.rkt")) "rep/rep-utils.rkt" "types/abbrev.rkt" "types/subtype.rkt"
"types/numeric-tower.rkt" "utils/utils.rkt"
"utils/tc-utils.rkt"))
;; do we attempt to find instantiations of polymorphic types to print? ;; do we attempt to find instantiations of polymorphic types to print?
;; FIXME - currently broken ;; FIXME - currently broken
@ -29,19 +31,30 @@
(match c (match c
[(FilterSet: thn els) (fp "(~a | ~a)" thn els)] [(FilterSet: thn els) (fp "(~a | ~a)" thn els)]
[(NoFilter:) (fp "-")] [(NoFilter:) (fp "-")]
[(NotTypeFilter: type (list) (? syntax? id)) (fp "(! ~a @ ~a)" type (syntax-e id))] [(NotTypeFilter: type (list) (? syntax? id))
[(NotTypeFilter: type (list) id) (fp "(! ~a @ ~a)" type id)] (fp "(! ~a @ ~a)" type (syntax-e id))]
[(NotTypeFilter: type path (? syntax? id)) (fp "(! ~a @ ~a ~a)" type path (syntax-e id))] [(NotTypeFilter: type (list) id)
[(NotTypeFilter: type path id) (fp "(! ~a @ ~a ~a)" type path id)] (fp "(! ~a @ ~a)" type id)]
[(TypeFilter: type (list) (? syntax? id)) (fp "(~a @ ~a)" type (syntax-e id))] [(NotTypeFilter: type path (? syntax? id))
[(TypeFilter: type (list) id) (fp "(~a @ ~a)" type id)] (fp "(! ~a @ ~a ~a)" type path (syntax-e id))]
[(TypeFilter: type path (? syntax? id)) (fp "(~a @ ~a ~a)" type path (syntax-e id))] [(NotTypeFilter: type path id)
[(TypeFilter: type path id) (fp "(~a @ ~a ~a)" type path id)] (fp "(! ~a @ ~a ~a)" type path id)]
[(TypeFilter: type (list) (? syntax? id))
(fp "(~a @ ~a)" type (syntax-e id))]
[(TypeFilter: type (list) id)
(fp "(~a @ ~a)" type id)]
[(TypeFilter: type path (? syntax? id))
(fp "(~a @ ~a ~a)" type path (syntax-e id))]
[(TypeFilter: type path id)
(fp "(~a @ ~a ~a)" type path id)]
[(Bot:) (fp "Bot")] [(Bot:) (fp "Bot")]
[(Top:) (fp "Top")] [(Top:) (fp "Top")]
[(ImpFilter: a c) (fp "(ImpFilter ~a ~a)" a c)] [(ImpFilter: a c)
[(AndFilter: a) (fp "(AndFilter") (for ([a0 a]) (fp " ~a" a0)) (fp ")")] (fp "(ImpFilter ~a ~a)" a c)]
[(OrFilter: a) (fp "(OrFilter") (for ([a0 a]) (fp " ~a" a0)) (fp ")")] [(AndFilter: a)
(fp "(AndFilter") (for ([a0 a]) (fp " ~a" a0)) (fp ")")]
[(OrFilter: a)
(fp "(OrFilter") (for ([a0 a]) (fp " ~a" a0)) (fp ")")]
[else (fp "(Unknown Filter: ~a)" (struct->vector c))])) [else (fp "(Unknown Filter: ~a)" (struct->vector c))]))
(define (print-pathelem c port write?) (define (print-pathelem c port write?)
@ -208,7 +221,9 @@
(fp "~a" (cons 'List (tuple-elems t)))] (fp "~a" (cons 'List (tuple-elems t)))]
[(Base: n cnt _ _) (fp "~s" n)] [(Base: n cnt _ _) (fp "~s" n)]
[(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))] [(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))]
[(Struct: (? (lambda (nm) (free-identifier=? promise-id nm))) #f (list (fld: t _ _)) _ _ _ _ _) (fp "(Promise ~a)" t)] [(Struct: (? (lambda (nm) (free-identifier=? promise-id nm)))
#f (list (fld: t _ _)) _ _ _ _ _)
(fp "(Promise ~a)" t)]
[(Struct: nm par (list (fld: t _ _) ...) proc _ _ _ _) [(Struct: nm par (list (fld: t _ _) ...) proc _ _ _ _)
(fp "#(struct:~a ~a" nm t) (fp "#(struct:~a ~a" nm t)
(when proc (when proc
@ -236,7 +251,8 @@
;; FIXME ;; FIXME
[(Values: (list v)) (fp "~a" v)] [(Values: (list v)) (fp "~a" v)]
[(Values: (list v ...)) (fp "~s" (cons 'values v))] [(Values: (list v ...)) (fp "~s" (cons 'values v))]
[(ValuesDots: v dty dbound) (fp "~s" (cons 'values (append v (list dty '... dbound))))] [(ValuesDots: v dty dbound)
(fp "~s" (cons 'values (append v (list dty '... dbound))))]
[(Param: in out) [(Param: in out)
(if (equal? in out) (if (equal? in out)
(fp "(Parameterof ~a)" in) (fp "(Parameterof ~a)" in)
@ -247,7 +263,8 @@
[(Poly-names: names body) [(Poly-names: names body)
#;(fprintf (current-error-port) "POLY SEQ: ~a\n" (Type-seq body)) #;(fprintf (current-error-port) "POLY SEQ: ~a\n" (Type-seq body))
(fp "(All ~a ~a)" names body)] (fp "(All ~a ~a)" names body)]
#;[(PolyDots-unsafe: n b) (fp "(unsafe-polydots ~a ~a ~a)" (Type-seq c) n b)] #;
[(PolyDots-unsafe: n b) (fp "(unsafe-polydots ~a ~a ~a)" (Type-seq c) n b)]
[(PolyDots-names: (list names ... dotted) body) [(PolyDots-names: (list names ... dotted) body)
(fp "(All ~a ~a)" (append names (list dotted '...)) body)] (fp "(All ~a ~a)" (append names (list dotted '...)) body)]
#; #;
@ -257,8 +274,10 @@
(Base: 'Boolean _ _ _) (Base: 'Boolean _ _ _)
(Base: 'Symbol _ _ _) (Base: 'Symbol _ _ _)
(Base: 'String _ _ _) (Base: 'String _ _ _)
(Mu: var (Union: (list (Value: '()) (Pair: (F: x) (F: var))))) (Mu: var (Union: (list (Value: '())
(Mu: y (Union: (list (F: x) (Pair: (F: x) (F: y))))) (Pair: (F: x) (F: var)))))
(Mu: y (Union: (list (F: x)
(Pair: (F: x) (F: y)))))
(Vector: (F: x)) (Vector: (F: x))
(Box: (F: x)))))) (Box: (F: x))))))
(fp "Syntax")] (fp "Syntax")]