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

Add match expander for all polymorphic functions. Use it in tc-apply error messages.

Browse Source 
original commit: d6ef3d774c7f5fe18a0e33159c45f5c2d71f862e
This commit is contained in:
Eric Dobson 2014-04-28 21:40:36 -07:00
parent be1e28cb5d
commit 34c54f4ecd
2 changed files with 38 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt
View File

@ -45,9 +45,7 @@
(define (failure)
(match f-ty
[(tc-result1:
(and t (or (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))
(Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))
(PolyDots-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))))
(and t (AnyPoly-names: _ _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))))
(domain-mismatches f args t doms rests drests rngs arg-tres full-tail-ty #f
#:msg-thunk (lambda (dom)
(string-append
@ -151,7 +149,7 @@
=> finish]
[else #f]))
(failure))]
[(tc-result1: (or (Function: '()) (Poly: _ (Function: '())) (PolyDots: _ (Function: '()))))
[(tc-result1: (AnyPoly: _ _ (Function: '())))
(tc-error/expr "Function has no cases")]
[(tc-result1: f-ty)
(tc-error/expr "Type of argument to apply is not a function type: \n~a" f-ty)]))

37
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:)
(provide Listof: List: MListof: AnyPoly: AnyPoly-names:)
(define-match-expander Listof:
@ -52,3 +52,38 @@
;; see note above
#'(or (Mu: var (Union: (list (Value: '()) (MPair: elem-pat (F: var)))))
(Mu: var (Union: (list (MPair: elem-pat (F: var)) (Value: '())))))])))
(define (unpoly t)
(match t
[(Poly: fixed-vars t)
(let-values ([(vars dotted t) (unpoly t)])
(values (append fixed-vars vars) dotted t))]
[(PolyDots: (list fixed-vars ... dotted-var) t)
(let-values ([(vars dotted t) (unpoly t)])
(values (append fixed-vars vars) (cons dotted-var dotted) t))]
[t (values null null t)]))
(define (unpoly-names t)
(match t
[(Poly-names: fixed-vars t)
(let-values ([(vars dotted t) (unpoly t)])
(values (append fixed-vars vars) dotted t))]
[(PolyDots-names: (list fixed-vars ... dotted-var) t)
(let-values ([(vars dotted t) (unpoly t)])
(values (append fixed-vars vars) (cons dotted-var dotted) t))]
[t (values null null t)]))
;; Match expanders that match any type and separate the outer layers of the poly and poly-dots, from
;; the inner non polymorphic type.
(define-match-expander AnyPoly:
(lambda (stx)
(syntax-parse stx
[(_ vars dotted-vars body)
#'(app unpoly vars dotted-vars body)])))
(define-match-expander AnyPoly-names:
(lambda (stx)
(syntax-parse stx
[(_ vars dotted-vars body)
#'(app unpoly-names vars dotted-vars body)])))