Break long lines.
original commit: 5d4e5ed39352b4a1e87c5ebd9c796cc5953064a5
This commit is contained in:
Vincent St-Amour
parent
ffcc7e9f92
commit
9c848fe5a5
|
|
@ -5,14 +5,16 @@
|
|||
"tc-app-helper.rkt" "find-annotation.rkt"
|
||||
(prefix-in c: racket/contract)
|
||||
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
|
||||
(only-in racket/private/class-internal make-object do-make-object)
|
||||
(only-in '#%kernel [apply k:apply])
|
||||
;; end fixme
|
||||
(for-syntax syntax/parse racket/base (utils tc-utils))
|
||||
(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)
|
||||
(except-in (env type-env-structs tvar-env index-env) extend)
|
||||
(rep type-rep filter-rep rep-utils)
|
||||
|
|
@ -35,84 +37,112 @@
|
|||
#:when (pred vars ... a))
|
||||
(let ([substitution (infer vars ... a)])
|
||||
(and substitution
|
||||
(tc/funapp1 f-stx args-stx (subst-all substitution a) argtys expected #:check #f))))
|
||||
(poly-fail f-stx args-stx t argtys #:name (and (identifier? f-stx) f-stx) #:expected expected))))]))
|
||||
(tc/funapp1 f-stx args-stx (subst-all substitution a)
|
||||
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)
|
||||
(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)
|
||||
;; 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-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) ...)))
|
||||
(or
|
||||
;; find the first function where the argument types match
|
||||
(for/first ([dom doms] [rng rngs] [rest rests] [a arrs]
|
||||
#:when (subtypes/varargs argtys-t dom rest))
|
||||
;; 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))
|
||||
;; if nothing matched, error
|
||||
(domain-mismatches f-stx args-stx t doms rests drests rngs argtys #f #f
|
||||
#:expected expected #:return (or expected (ret (Un)))
|
||||
#:msg-thunk (lambda (dom)
|
||||
(string-append "No function domains matched in function application:\n"
|
||||
dom))))]
|
||||
(domain-mismatches
|
||||
f-stx args-stx t doms rests drests rngs argtys #f #f
|
||||
#:expected expected #:return (or expected (ret (Un)))
|
||||
#:msg-thunk (lambda (dom)
|
||||
(string-append
|
||||
"No function domains matched in function application:\n"
|
||||
dom))))]
|
||||
;; 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:
|
||||
(and t
|
||||
(Poly:
|
||||
vars
|
||||
(Function: (list (and arrs (arr: doms rngs rests (and drests #f) (list (Keyword: _ _ #f) ...))) ...)))))
|
||||
(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 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)]
|
||||
(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.
|
||||
(λ (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
|
||||
[((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
|
||||
[((tc-result1: (Param: in out)) (list)) (ret out)]
|
||||
[((tc-result1: (Param: in out)) (list (tc-result1: t)))
|
||||
(if (subtype t in)
|
||||
(ret -Void true-filter)
|
||||
(tc-error/expr #:return (ret -Void true-filter)
|
||||
"Wrong argument to parameter - expected ~a and got ~a" in t))]
|
||||
(tc-error/expr
|
||||
#:return (ret -Void true-filter)
|
||||
"Wrong argument to parameter - expected ~a and got ~a"
|
||||
in t))]
|
||||
[((tc-result1: (Param: _ _)) _)
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"Wrong number of arguments to parameter - expected 0 or 1, got ~a"
|
||||
(length argtys))]
|
||||
(tc-error/expr
|
||||
#:return (ret (Un))
|
||||
"Wrong number of arguments to parameter - expected 0 or 1, got ~a"
|
||||
(length argtys))]
|
||||
;; resolve names, polymorphic apps, mu, etc
|
||||
[((tc-result1: (? needs-resolving? t) f o) _)
|
||||
(tc/funapp f-stx args-stx (ret (resolve-once t) f o) argtys expected)]
|
||||
|
|
@ -125,8 +155,13 @@
|
|||
[((tc-result1: (Error:)) _) (ret (make-Error))]
|
||||
;; otherwise fail
|
||||
[((tc-result1: (and f-ty (Poly: ns (Function: arrs)))) _)
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"Cannot infer type instantiation for type ~a. Please add more type annotations" f-ty)]
|
||||
(tc-error/expr
|
||||
#:return (ret (Un))
|
||||
(string-append "Cannot infer type instantiation for type ~a. Please add "
|
||||
"more type annotations")
|
||||
f-ty)]
|
||||
[((tc-result1: f-ty) _)
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"Cannot apply expression of type ~a, since it is not a function type" f-ty)]))
|
||||
(tc-error/expr
|
||||
#:return (ret (Un))
|
||||
"Cannot apply expression of type ~a, since it is not a function type"
|
||||
f-ty)]))
|
||||
|
|
|
|||
|
|
@ -1,10 +1,12 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require unstable/sequence racket/require racket/match racket/list (prefix-in s: srfi/1)
|
||||
racket/string
|
||||
(path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.rkt" "rep/rep-utils.rkt"
|
||||
"types/abbrev.rkt" "types/numeric-tower.rkt" "types/subtype.rkt"
|
||||
"utils/utils.rkt" "utils/tc-utils.rkt"))
|
||||
(require racket/require racket/match racket/list racket/string
|
||||
unstable/sequence
|
||||
(prefix-in s: srfi/1)
|
||||
(path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.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?
|
||||
;; FIXME - currently broken
|
||||
|
|
@ -29,19 +31,30 @@
|
|||
(match c
|
||||
[(FilterSet: thn els) (fp "(~a | ~a)" thn els)]
|
||||
[(NoFilter:) (fp "-")]
|
||||
[(NotTypeFilter: type (list) (? syntax? id)) (fp "(! ~a @ ~a)" type (syntax-e id))]
|
||||
[(NotTypeFilter: type (list) id) (fp "(! ~a @ ~a)" type id)]
|
||||
[(NotTypeFilter: type path (? syntax? id)) (fp "(! ~a @ ~a ~a)" type path (syntax-e id))]
|
||||
[(NotTypeFilter: 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)]
|
||||
[(NotTypeFilter: type (list) (? syntax? id))
|
||||
(fp "(! ~a @ ~a)" type (syntax-e id))]
|
||||
[(NotTypeFilter: type (list) id)
|
||||
(fp "(! ~a @ ~a)" type id)]
|
||||
[(NotTypeFilter: type path (? syntax? id))
|
||||
(fp "(! ~a @ ~a ~a)" type path (syntax-e id))]
|
||||
[(NotTypeFilter: 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")]
|
||||
[(Top:) (fp "Top")]
|
||||
[(ImpFilter: a c) (fp "(ImpFilter ~a ~a)" a c)]
|
||||
[(AndFilter: a) (fp "(AndFilter") (for ([a0 a]) (fp " ~a" a0)) (fp ")")]
|
||||
[(OrFilter: a) (fp "(OrFilter") (for ([a0 a]) (fp " ~a" a0)) (fp ")")]
|
||||
[(ImpFilter: a c)
|
||||
(fp "(ImpFilter ~a ~a)" a c)]
|
||||
[(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))]))
|
||||
|
||||
(define (print-pathelem c port write?)
|
||||
|
|
@ -208,7 +221,9 @@
|
|||
(fp "~a" (cons 'List (tuple-elems t)))]
|
||||
[(Base: n cnt _ _) (fp "~s" n)]
|
||||
[(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 _ _ _ _)
|
||||
(fp "#(struct:~a ~a" nm t)
|
||||
(when proc
|
||||
|
|
@ -236,7 +251,8 @@
|
|||
;; FIXME
|
||||
[(Values: (list v)) (fp "~a" 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)
|
||||
(if (equal? in out)
|
||||
(fp "(Parameterof ~a)" in)
|
||||
|
|
@ -247,7 +263,8 @@
|
|||
[(Poly-names: names body)
|
||||
#;(fprintf (current-error-port) "POLY SEQ: ~a\n" (Type-seq 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)
|
||||
(fp "(All ~a ~a)" (append names (list dotted '...)) body)]
|
||||
#;
|
||||
|
|
@ -257,8 +274,10 @@
|
|||
(Base: 'Boolean _ _ _)
|
||||
(Base: 'Symbol _ _ _)
|
||||
(Base: 'String _ _ _)
|
||||
(Mu: var (Union: (list (Value: '()) (Pair: (F: x) (F: var)))))
|
||||
(Mu: y (Union: (list (F: x) (Pair: (F: x) (F: y)))))
|
||||
(Mu: var (Union: (list (Value: '())
|
||||
(Pair: (F: x) (F: var)))))
|
||||
(Mu: y (Union: (list (F: x)
|
||||
(Pair: (F: x) (F: y)))))
|
||||
(Vector: (F: x))
|
||||
(Box: (F: x))))))
|
||||
(fp "Syntax")]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user