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

Add match expander for functions and arities together.

Browse Source 
original commit: 30809eb841cf372faf8423816f61cd94668ea7b9
This commit is contained in:
Eric Dobson 2014-06-20 09:13:56 -07:00
parent 17942318ba
commit 2305c21c22
4 changed files with 21 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt
View File

@ -302,7 +302,7 @@
(define (cleanup-type t [expected #f])
(match t
;; function type, prune if possible.
[(Function: (list (arr: doms rngs rests drests kws) ...))
[(Function/arrs: doms rngs rests drests kws)
(match-let ([(list pdoms rngs rests drests) (possible-domains doms rests drests rngs (and expected (ret expected)))])
(if (= (length pdoms) (length doms))
;; pruning didn't improve things, return the original
@ -324,13 +324,13 @@
(match t
[(or (Poly-names:
msg-vars
(Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests (list (Keyword: _ _ #f) ...)) ...)))
(Function/arrs: msg-doms msg-rngs msg-rests msg-drests (list (Keyword: _ _ #f) ...)))
(PolyDots-names:
msg-vars
(Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests (list (Keyword: _ _ #f) ...)) ...)))
(Function/arrs: msg-doms msg-rngs msg-rests msg-drests (list (Keyword: _ _ #f) ...)))
(PolyRow-names:
msg-vars _
(Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests (list (Keyword: _ _ #f) ...)) ...))))
(Function/arrs: msg-doms msg-rngs msg-rests msg-drests (list (Keyword: _ _ #f) ...))))
(let ([fcn-string (if name
(format "function `~a'" (syntax->datum name))
"function")])
@ -350,9 +350,9 @@
(list->seteq msg-vars)))
(string-append "Type Variables: " (stringify msg-vars) "\n")
""))))))]
[(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...)))
(PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...)))
(PolyRow-names: msg-vars _ (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...))))
[(or (Poly-names: msg-vars (Function/arrs: msg-doms msg-rngs msg-rests msg-drests kws))
(PolyDots-names: msg-vars (Function/arrs: msg-doms msg-rngs msg-rests msg-drests kws))
(PolyRow-names: msg-vars _ (Function/arrs: msg-doms msg-rngs msg-rests msg-drests kws)))
(let ([fcn-string (if name
(format "function with keywords ~a" (syntax->datum name))
"function with keywords")])

12
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt
View File

@ -39,7 +39,7 @@
;; tc/funapp1 currently cannot handle drest arities
[(Function: (list (and a (arr: _ _ _ #f _))))
(tc/funapp1 f-stx args-stx a args-res expected)]
[(Function: (and arrs (list (arr: doms rngs rests (and drests #f) kws) ...)))
[(Function/arrs: doms rngs rests (and drests #f) kws #:arrs arrs)
(or
;; find the first function where the argument types match
(for/first ([dom (in-list doms)] [rng (in-list rngs)] [rest (in-list rests)] [a (in-list arrs)]
@ -58,7 +58,7 @@
dom))))]
;; any kind of dotted polymorphic function without mandatory keyword args
[(PolyDots: (list fixed-vars ... dotted-var)
(Function: (list (and arrs (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...))) ...)))
(Function/arrs: doms rngs rests drests (list (Keyword: _ _ #f) ...) #:arrs arrs))
(handle-clauses
(doms rngs rests drests arrs) f-stx args-stx
;; only try inference if the argument lengths are appropriate
@ -85,8 +85,7 @@
f-type args-res expected)]
;; regular polymorphic functions without dotted rest,
;; we do not choose any instantiations with mandatory keyword arguments
[(Poly: vars
(Function: (list (and arrs (arr: doms rngs rests #f (list (Keyword: _ _ kw?) ...))) ...)))
[(Poly: vars (Function/arrs: doms rngs rests #f (list (Keyword: _ _ kw?) ...) #:arrs arrs))
(handle-clauses
(doms rngs rests kw? arrs) f-stx args-stx
;; only try inference if the argument lengths are appropriate
@ -103,8 +102,7 @@
;; Row polymorphism. For now we do really dumb inference that only works
;; in very restricted cases, but is probably enough for most cases in
;; the Racket codebase. Eventually this should be extended.
[(PolyRow: vars constraints
(and f-ty (Function: (list (arr: doms _ _ #f _) ...))))
[(PolyRow: vars constraints (and f-ty (Function/arrs: doms _ _ #f _)))
(define (fail)
(poly-fail f-stx args-stx f-type args-res
#:name (and (identifier? f-stx) f-stx)
@ -157,7 +155,7 @@
[(? needs-resolving?)
(tc/funapp f-stx args-stx (resolve-once f-type) args-res expected)]
;; a union of functions can be applied if we can apply all of the elements
[(Union: (and ts (list (Function: _) ...)))
[(Union: (and ts (list (? Function?) ...)))
(merge-tc-results
(for/list ([fty ts])
(tc/funapp f-stx args-stx fty argtys expected)))]

4
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt
View File

@ -309,7 +309,7 @@
(let loop ((t t))
(match t
[(Mu: _ _) (loop (unfold t))]
[(Function: (list (arr: _ _ _ _ '()) ...)) t]
[(Function/arrs: _ _ _ _ '()) t]
[_ #f]))]
[_ #f]))
@ -321,7 +321,7 @@
(define (find-matching-arrs formal-arity arities-seen)
(match-define (list formal-positionals formal-rest) formal-arity)
(match expected-type
[(Function: (and fs (list (arr: argss rets rests drests '()) ...)))
[(Function/arrs: argss rets rests drests '() #:arrs fs)
(for/list ([a (in-list argss)] [f (in-list fs)] [r (in-list rests)] [dr (in-list drests)]
#:unless (arities-seen-seen-before? arities-seen (list (length a) (or r dr)))
#:when (if formal-rest

8
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/match-expanders.rkt
View File

@ -10,7 +10,7 @@
racket/set
(for-syntax racket/base syntax/parse))
(provide Listof: List: MListof: AnyPoly: AnyPoly-names:)
(provide Listof: List: MListof: AnyPoly: AnyPoly-names: Function/arrs:)
(define-match-expander Listof:
@ -87,3 +87,9 @@
(syntax-parse stx
[(_ vars dotted-vars body)
#'(app unpoly-names vars dotted-vars body)])))
(define-match-expander Function/arrs:
(lambda (stx)
(syntax-parse stx
[(_ doms rngs rests drests kws (~optional (~seq #:arrs arrs) #:defaults ([arrs #'_])))
#'(Function: (and arrs (list (arr: doms rngs rests drests kws) (... ...))))])))