suzanne.soy/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
This commit is contained in:
Eric Dobson 2014-06-20 09:13:56 -07:00
parent 11e19caa02
commit 30809eb841
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]) (define (cleanup-type t [expected #f])
(match t (match t
;; function type, prune if possible. ;; 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)))]) (match-let ([(list pdoms rngs rests drests) (possible-domains doms rests drests rngs (and expected (ret expected)))])
(if (= (length pdoms) (length doms)) (if (= (length pdoms) (length doms))
;; pruning didn't improve things, return the original ;; pruning didn't improve things, return the original
@ -324,13 +324,13 @@
(match t (match t
[(or (Poly-names: [(or (Poly-names:
msg-vars 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: (PolyDots-names:
msg-vars 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: (PolyRow-names:
msg-vars _ 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 (let ([fcn-string (if name
(format "function `~a'" (syntax->datum name)) (format "function `~a'" (syntax->datum name))
"function")]) "function")])
@ -350,9 +350,9 @@
(list->seteq msg-vars))) (list->seteq msg-vars)))
(string-append "Type Variables: " (stringify msg-vars) "\n") (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) ...))) [(or (Poly-names: msg-vars (Function/arrs: 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) ...))) (PolyDots-names: msg-vars (Function/arrs: 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) ...)))) (PolyRow-names: msg-vars _ (Function/arrs: msg-doms msg-rngs msg-rests msg-drests kws)))
(let ([fcn-string (if name (let ([fcn-string (if name
(format "function with keywords ~a" (syntax->datum name)) (format "function with keywords ~a" (syntax->datum name))
"function with keywords")]) "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 ;; tc/funapp1 currently cannot handle drest arities
[(Function: (list (and a (arr: _ _ _ #f _)))) [(Function: (list (and a (arr: _ _ _ #f _))))
(tc/funapp1 f-stx args-stx a args-res expected)] (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 (or
;; find the first function where the argument types match ;; 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)] (for/first ([dom (in-list doms)] [rng (in-list rngs)] [rest (in-list rests)] [a (in-list arrs)]
@ -58,7 +58,7 @@
dom))))] dom))))]
;; any kind of dotted polymorphic function without mandatory keyword args ;; any kind of dotted polymorphic function without mandatory keyword args
[(PolyDots: (list fixed-vars ... dotted-var) [(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 (handle-clauses
(doms rngs rests drests arrs) f-stx args-stx (doms rngs rests drests arrs) f-stx args-stx
;; only try inference if the argument lengths are appropriate ;; only try inference if the argument lengths are appropriate
@ -85,8 +85,7 @@
f-type args-res expected)] f-type args-res expected)]
;; regular polymorphic functions without dotted rest, ;; regular polymorphic functions without dotted rest,
;; we do not choose any instantiations with mandatory keyword arguments ;; we do not choose any instantiations with mandatory keyword arguments
[(Poly: vars [(Poly: vars (Function/arrs: doms rngs rests #f (list (Keyword: _ _ kw?) ...) #:arrs arrs))
(Function: (list (and arrs (arr: doms rngs rests #f (list (Keyword: _ _ kw?) ...))) ...)))
(handle-clauses (handle-clauses
(doms rngs rests kw? arrs) f-stx args-stx (doms rngs rests kw? arrs) f-stx args-stx
;; only try inference if the argument lengths are appropriate ;; 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 ;; Row polymorphism. For now we do really dumb inference that only works
;; in very restricted cases, but is probably enough for most cases in ;; in very restricted cases, but is probably enough for most cases in
;; the Racket codebase. Eventually this should be extended. ;; the Racket codebase. Eventually this should be extended.
[(PolyRow: vars constraints [(PolyRow: vars constraints (and f-ty (Function/arrs: doms _ _ #f _)))
(and f-ty (Function: (list (arr: doms _ _ #f _) ...))))
(define (fail) (define (fail)
(poly-fail f-stx args-stx f-type args-res (poly-fail f-stx args-stx f-type args-res
#:name (and (identifier? f-stx) f-stx) #:name (and (identifier? f-stx) f-stx)
@ -157,7 +155,7 @@
[(? needs-resolving?) [(? needs-resolving?)
(tc/funapp f-stx args-stx (resolve-once f-type) args-res expected)] (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 ;; 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 (merge-tc-results
(for/list ([fty ts]) (for/list ([fty ts])
(tc/funapp f-stx args-stx fty argtys expected)))] (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)) (let loop ((t t))
(match t (match t
[(Mu: _ _) (loop (unfold t))] [(Mu: _ _) (loop (unfold t))]
[(Function: (list (arr: _ _ _ _ '()) ...)) t] [(Function/arrs: _ _ _ _ '()) t]
[_ #f]))] [_ #f]))]
[_ #f])) [_ #f]))
@ -321,7 +321,7 @@
(define (find-matching-arrs formal-arity arities-seen) (define (find-matching-arrs formal-arity arities-seen)
(match-define (list formal-positionals formal-rest) formal-arity) (match-define (list formal-positionals formal-rest) formal-arity)
(match expected-type (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)] (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))) #:unless (arities-seen-seen-before? arities-seen (list (length a) (or r dr)))
#:when (if formal-rest #: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 racket/set
(for-syntax racket/base syntax/parse)) (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: (define-match-expander Listof:
@ -87,3 +87,9 @@
(syntax-parse stx (syntax-parse stx
[(_ vars dotted-vars body) [(_ vars dotted-vars body)
#'(app unpoly-names 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) (... ...))))])))